section \<open>Basics\<close>

theory Basic_Extensions
imports "HOL-Library.Infinite_Set"
begin

  subsection \<open>Types\<close>

    type_synonym 'a step = "'a \<Rightarrow> 'a"

  subsection \<open>Rules\<close>

    declare less_imp_le[dest, simp]

    declare le_funI[intro]
    declare le_funE[elim]
    declare le_funD[dest]

    lemma IdI'[intro]:
      assumes "x = y"
      shows "(x, y) \<in> Id"
      using assms by auto

    lemma (in order) order_le_cases:
      assumes "x \<le> y"
      obtains (eq) "x = y" | (lt) "x < y"
      using assms le_less by auto

    lemma (in linorder) linorder_cases':
      obtains (le) "x \<le> y" | (gt) "x > y"
      by force

    lemma monoI_comp[intro]:
      assumes "mono f" "mono g"
      shows "mono (f \<circ> g)"
      using assms by (intro monoI, auto dest: monoD)
    lemma strict_monoI_comp[intro]:
      assumes "strict_mono f" "strict_mono g"
      shows "strict_mono (f \<circ> g)"
      using assms by (intro strict_monoI, auto dest: strict_monoD)

    lemma eq_le_absorb[simp]:
      fixes x y :: "'a :: order"
      shows "x = y \<and> x \<le> y \<longleftrightarrow> x = y" "x \<le> y \<and> x = y \<longleftrightarrow> x = y"
      by auto

    lemma INFM_Suc[simp]: "(\<exists>\<^sub>\<infinity> i. P (Suc i)) \<longleftrightarrow> (\<exists>\<^sub>\<infinity> i. P i)"
      unfolding INFM_nat using Suc_lessE less_Suc_eq by metis

  subsection \<open>Constants\<close>

    definition const :: "'a \<Rightarrow> 'b \<Rightarrow> 'a"
      where "const x \<equiv> \<lambda> _. x"
    definition const2 :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'a"
      where "const2 x \<equiv> \<lambda> _ _. x"
    definition const3 :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'a"
      where "const3 x \<equiv> \<lambda> _ _ _. x"
    definition const4 :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'a"
      where "const4 x \<equiv> \<lambda> _ _ _ _. x"
    definition const5 :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'f \<Rightarrow> 'a"
      where "const5 x \<equiv> \<lambda> _ _ _ _ _. x"

    lemma const_apply[simp]: "const x y = x" unfolding const_def by rule
    lemma const2_apply[simp]: "const2 x y z = x" unfolding const2_def by rule
    lemma const3_apply[simp]: "const3 x y z u = x" unfolding const3_def by rule
    lemma const4_apply[simp]: "const4 x y z u v = x" unfolding const4_def by rule
    lemma const5_apply[simp]: "const5 x y z u v w = x" unfolding const5_def by rule

    definition zip_fun :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'c" (infixr "\<parallel>" 51)
      where "f \<parallel> g \<equiv> \<lambda> x. (f x, g x)"

    lemma zip_fun_simps[simp]:
      "(f \<parallel> g) x = (f x, g x)"
      "fst \<circ> (f \<parallel> g) = f"
      "snd \<circ> (f \<parallel> g) = g"
      "fst \<circ> h \<parallel> snd \<circ> h = h"
      "fst ` range (f \<parallel> g) = range f"
      "snd ` range (f \<parallel> g) = range g"
      unfolding zip_fun_def by force+

    lemma zip_fun_eq[dest]:
      assumes "f \<parallel> g = h \<parallel> i"
      shows "f = h" "g = i"
      using assms unfolding zip_fun_def by (auto dest: fun_cong)

    lemma zip_fun_range_subset[intro, simp]: "range (f \<parallel> g) \<subseteq> range f \<times> range g"
      unfolding zip_fun_def by blast
    lemma zip_fun_range_finite[elim]:
      assumes "finite (range (f \<parallel> g))"
      obtains "finite (range f)" "finite (range g)"
    proof
      show "finite (range f)" using finite_imageI [OF assms(1), of fst]
        by (simp add: image_image)
      show "finite (range g)" using finite_imageI [OF assms(1), of snd]
        by (simp add: image_image)
    qed

    lemma zip_fun_split:
      obtains f g
      where "h = f \<parallel> g"
    proof
      show "h = fst \<circ> h \<parallel> snd \<circ> h" by simp
    qed

    abbreviation "None_None \<equiv> (None, None)"
    abbreviation "None_Some \<equiv> \<lambda> (y). (None, Some y)"
    abbreviation "Some_None \<equiv> \<lambda> (x). (Some x, None)"
    abbreviation "Some_Some \<equiv> \<lambda> (x, y). (Some x, Some y)"

    abbreviation "None_None_None \<equiv> (None, None, None)"
    abbreviation "None_None_Some \<equiv> \<lambda> (z). (None, None, Some z)"
    abbreviation "None_Some_None \<equiv> \<lambda> (y). (None, Some y, None)"
    abbreviation "None_Some_Some \<equiv> \<lambda> (y, z). (None, Some y, Some z)"
    abbreviation "Some_None_None \<equiv> \<lambda> (x). (Some x, None, None)"
    abbreviation "Some_None_Some \<equiv> \<lambda> (x, z). (Some x, None, Some z)"
    abbreviation "Some_Some_None \<equiv> \<lambda> (x, y). (Some x, Some y, None)"
    abbreviation "Some_Some_Some \<equiv> \<lambda> (x, y, z). (Some x, Some y, Some z)"

    lemma inj_Some2[simp, intro]:
      "inj None_Some"
      "inj Some_None"
      "inj Some_Some"
      by (rule injI, force)+

    lemma inj_Some3[simp, intro]:
      "inj None_None_Some"
      "inj None_Some_None"
      "inj None_Some_Some"
      "inj Some_None_None"
      "inj Some_None_Some"
      "inj Some_Some_None"
      "inj Some_Some_Some"
      by (rule injI, force)+

    definition swap :: "'a \<times> 'b \<Rightarrow> 'b \<times> 'a"
      where "swap x \<equiv> (snd x, fst x)"

    lemma swap_simps[simp]: "swap (a, b) = (b, a)" unfolding swap_def by simp
    lemma swap_inj[intro, simp]: "inj swap" by (rule injI, auto)
    lemma swap_surj[intro, simp]: "surj swap" by (rule surjI[where ?f = swap], auto)
    lemma swap_bij[intro, simp]: "bij swap" by (rule bijI, auto)

    definition push :: "('a \<times> 'b) \<times> 'c \<Rightarrow> 'a \<times> 'b \<times> 'c"
      where "push x \<equiv> (fst (fst x), snd (fst x), snd x)"
    definition pull :: "'a \<times> 'b \<times> 'c \<Rightarrow> ('a \<times> 'b) \<times> 'c"
      where "pull x \<equiv> ((fst x, fst (snd x)), snd (snd x))"

    lemma push_simps[simp]: "push ((x, y), z) = (x, y, z)" unfolding push_def by simp
    lemma pull_simps[simp]: "pull (x, y, z) = ((x, y), z)" unfolding pull_def by simp

    definition label :: "'vertex \<times> 'label \<times> 'vertex \<Rightarrow> 'label"
      where "label \<equiv> fst \<circ> snd"

    lemma label_select[simp]: "label (p, a, q) = a" unfolding label_def by simp

  subsection \<open>Theorems for @term{curry} and @term{split}\<close>

    lemma curry_split[simp]: "curry \<circ> case_prod = id" by auto
    lemma split_curry[simp]: "case_prod \<circ> curry = id" by auto

    lemma curry_le[simp]: "curry f \<le> curry g \<longleftrightarrow> f \<le> g" unfolding le_fun_def by force
    lemma split_le[simp]: "case_prod f \<le> case_prod g \<longleftrightarrow> f \<le> g" unfolding le_fun_def by force

    lemma mono_curry_left[simp]: "mono (curry \<circ> h) \<longleftrightarrow> mono h"
      unfolding mono_def by fastforce
    lemma mono_split_left[simp]: "mono (case_prod \<circ> h) \<longleftrightarrow> mono h"
      unfolding mono_def by fastforce
    lemma mono_curry_right[simp]: "mono (h \<circ> curry) \<longleftrightarrow> mono h"
      unfolding mono_def split_le[symmetric] by bestsimp
    lemma mono_split_right[simp]: "mono (h \<circ> case_prod) \<longleftrightarrow> mono h"
      unfolding mono_def curry_le[symmetric] by bestsimp

    lemma Collect_curry[simp]: "{x. P (curry x)} = case_prod ` {x. P x}" using image_Collect by fastforce
    lemma Collect_split[simp]: "{x. P (case_prod x)} = curry ` {x. P x}" using image_Collect by force

    lemma gfp_split_curry[simp]: "gfp (case_prod \<circ> f \<circ> curry) = case_prod (gfp f)"
    proof -
      have "gfp (case_prod \<circ> f \<circ> curry) = Sup {u. u \<le> case_prod (f (curry u))}" unfolding gfp_def by simp
      also have "\<dots> = Sup {u. curry u \<le> curry (case_prod (f (curry u)))}" unfolding curry_le by simp
      also have "\<dots> = Sup {u. curry u \<le> f (curry u)}" by simp
      also have "\<dots> = Sup (case_prod ` {u. u \<le> f u})" unfolding Collect_curry[of "\<lambda> u. u \<le> f u"] by simp
      also have "\<dots> = case_prod (Sup {u. u \<le> f u})" by (force simp add: image_comp)
      also have "\<dots> = case_prod (gfp f)" unfolding gfp_def by simp
      finally show ?thesis by this
    qed
    lemma gfp_curry_split[simp]: "gfp (curry \<circ> f \<circ> case_prod) = curry (gfp f)"
    proof -
      have "gfp (curry \<circ> f \<circ> case_prod) = Sup {u. u \<le> curry (f (case_prod u))}" unfolding gfp_def by simp
      also have "\<dots> = Sup {u. case_prod u \<le> case_prod (curry (f (case_prod u)))}" unfolding split_le by simp
      also have "\<dots> = Sup {u. case_prod u \<le> f (case_prod u)}" by simp
      also have "\<dots> = Sup (curry ` {u. u \<le> f u})" unfolding Collect_split[of "\<lambda> u. u \<le> f u"] by simp
      also have "\<dots> = curry (Sup {u. u \<le> f u})" by (force simp add: image_comp)
      also have "\<dots> = curry (gfp f)" unfolding gfp_def by simp
      finally show ?thesis by this
    qed

    lemma not_someI:
      assumes "\<And> x. P x \<Longrightarrow> False"
      shows "\<not> P (SOME x. P x)"
      using assms by blast
    lemma some_ccontr:
      assumes "(\<And> x. \<not> P x) \<Longrightarrow> False"
      shows "P (SOME x. P x)"
      using assms someI_ex ccontr by metis

end


(*  Title:      HOL/Nitpick_Examples/Hotel_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2010-2011

Nitpick example based on Tobias Nipkow's hotel key card formalization.
*)

section \<open>Nitpick Example Based on Tobias Nipkow's Hotel Key Card
          Formalization\<close>

theory Hotel_Nits
imports Main
begin

nitpick_params [verbose, max_potential = 0, sat_solver = MiniSat,
                max_threads = 1, timeout = 240]

typedecl guest
typedecl key
typedecl room

type_synonym keycard = "key \<times> key"

record state =
  owns :: "room \<Rightarrow> guest option"
  currk :: "room \<Rightarrow> key"
  issued :: "key set"
  cards :: "guest \<Rightarrow> keycard set"
  roomk :: "room \<Rightarrow> key"
  isin :: "room \<Rightarrow> guest set"
  safe :: "room \<Rightarrow> bool"

inductive_set reach :: "state set" where
init:
"inj initk \<Longrightarrow>
 \<lparr>owns = (\<lambda>r. None), currk = initk, issued = range initk, cards = (\<lambda>g. {}),
  roomk = initk, isin = (\<lambda>r. {}), safe = (\<lambda>r. True)\<rparr> \<in> reach" |
check_in:
"\<lbrakk>s \<in> reach; k \<notin> issued s\<rbrakk> \<Longrightarrow>
 s\<lparr>currk := (currk s)(r := k), issued := issued s \<union> {k},
   cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
   owns :=  (owns s)(r := Some g), safe := (safe s)(r := False)\<rparr> \<in> reach" |
enter_room:
"\<lbrakk>s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'}\<rbrakk> \<Longrightarrow>
 s\<lparr>isin := (isin s)(r := isin s r \<union> {g}),
   roomk := (roomk s)(r := k'),
   safe := (safe s)(r := owns s r = Some g \<and> isin s r = {} \<^cancel>\<open>\<and> k' = currk s r\<close>
                         \<or> safe s r)\<rparr> \<in> reach" |
exit_room:
"\<lbrakk>s \<in> reach; g \<in> isin s r\<rbrakk> \<Longrightarrow> s\<lparr>isin := (isin s)(r := isin s r - {g})\<rparr> \<in> reach"

theorem safe: "s \<in> reach \<Longrightarrow> safe s r \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"
nitpick [card room = 1, card guest = 2, card "guest option" = 3,
         card key = 4, card state = 6, show_consts, format = 2,
         expect = genuine]
(* nitpick [card room = 1, card guest = 2, expect = genuine] *) (* slow *)
oops

end


(*  Title:      HOL/Old_Number_Theory/BijectionRel.thy
    Author:     Thomas M. Rasmussen
    Copyright   2000  University of Cambridge
*)

section {* Bijections between sets *}

theory BijectionRel
imports Main
begin

text {*
  Inductive definitions of bijections between two different sets and
  between the same set.  Theorem for relating the two definitions.

  \bigskip
*}

inductive_set
  bijR :: "('a => 'b => bool) => ('a set * 'b set) set"
  for P :: "'a => 'b => bool"
where
  empty [simp]: "({}, {}) \<in> bijR P"
| insert: "P a b ==> a \<notin> A ==> b \<notin> B ==> (A, B) \<in> bijR P
    ==> (insert a A, insert b B) \<in> bijR P"

text {*
  Add extra condition to @{term insert}: @{term "\<forall>b \<in> B. \<not> P a b"}
  (and similar for @{term A}).
*}

definition
  bijP :: "('a => 'a => bool) => 'a set => bool" where
  "bijP P F = (\<forall>a b. a \<in> F \<and> P a b --> b \<in> F)"

definition
  uniqP :: "('a => 'a => bool) => bool" where
  "uniqP P = (\<forall>a b c d. P a b \<and> P c d --> (a = c) = (b = d))"

definition
  symP :: "('a => 'a => bool) => bool" where
  "symP P = (\<forall>a b. P a b = P b a)"

inductive_set
  bijER :: "('a => 'a => bool) => 'a set set"
  for P :: "'a => 'a => bool"
where
  empty [simp]: "{} \<in> bijER P"
| insert1: "P a a ==> a \<notin> A ==> A \<in> bijER P ==> insert a A \<in> bijER P"
| insert2: "P a b ==> a \<noteq> b ==> a \<notin> A ==> b \<notin> A ==> A \<in> bijER P
    ==> insert a (insert b A) \<in> bijER P"

text {* \medskip @{term bijR} *}

lemma fin_bijRl: "(A, B) \<in> bijR P ==> finite A"
  apply (erule bijR.induct)
  apply auto
  done

lemma fin_bijRr: "(A, B) \<in> bijR P ==> finite B"
  apply (erule bijR.induct)
  apply auto
  done

lemma aux_induct:
  assumes major: "finite F"
    and subs: "F \<subseteq> A"
    and cases: "P {}"
      "!!F a. F \<subseteq> A ==> a \<in> A ==> a \<notin> F ==> P F ==> P (insert a F)"
  shows "P F"
  using major subs
  apply (induct set: finite)
   apply (blast intro: cases)+
  done

lemma inj_func_bijR_aux1:
    "A \<subseteq> B ==> a \<notin> A ==> a \<in> B ==> inj_on f B ==> f a \<notin> f ` A"
  apply (unfold inj_on_def)
  apply auto
  done

lemma inj_func_bijR_aux2:
  "\<forall>a. a \<in> A --> P a (f a) ==> inj_on f A ==> finite A ==> F <= A
    ==> (F, f ` F) \<in> bijR P"
  apply (rule_tac F = F and A = A in aux_induct)
     apply (rule finite_subset)
      apply auto
  apply (rule bijR.insert)
     apply (rule_tac [3] inj_func_bijR_aux1)
        apply auto
  done

lemma inj_func_bijR:
  "\<forall>a. a \<in> A --> P a (f a) ==> inj_on f A ==> finite A
    ==> (A, f ` A) \<in> bijR P"
  apply (rule inj_func_bijR_aux2)
     apply auto
  done

text {* \medskip @{term bijER} *}

lemma fin_bijER: "A \<in> bijER P ==> finite A"
  apply (erule bijER.induct)
    apply auto
  done

lemma aux1:
  "a \<notin> A ==> a \<notin> B ==> F \<subseteq> insert a A ==> F \<subseteq> insert a B ==> a \<in> F
    ==> \<exists>C. F = insert a C \<and> a \<notin> C \<and> C <= A \<and> C <= B"
  apply (rule_tac x = "F - {a}" in exI)
  apply auto
  done

lemma aux2: "a \<noteq> b ==> a \<notin> A ==> b \<notin> B ==> a \<in> F ==> b \<in> F
    ==> F \<subseteq> insert a A ==> F \<subseteq> insert b B
    ==> \<exists>C. F = insert a (insert b C) \<and> a \<notin> C \<and> b \<notin> C \<and> C \<subseteq> A \<and> C \<subseteq> B"
  apply (rule_tac x = "F - {a, b}" in exI)
  apply auto
  done

lemma aux_uniq: "uniqP P ==> P a b ==> P c d ==> (a = c) = (b = d)"
  apply (unfold uniqP_def)
  apply auto
  done

lemma aux_sym: "symP P ==> P a b = P b a"
  apply (unfold symP_def)
  apply auto
  done

lemma aux_in1:
    "uniqP P ==> b \<notin> C ==> P b b ==> bijP P (insert b C) ==> bijP P C"
  apply (unfold bijP_def)
  apply auto
  apply (subgoal_tac "b \<noteq> a")
   prefer 2
   apply clarify
  apply (simp add: aux_uniq)
  apply auto
  done

lemma aux_in2:
  "symP P ==> uniqP P ==> a \<notin> C ==> b \<notin> C ==> a \<noteq> b ==> P a b
    ==> bijP P (insert a (insert b C)) ==> bijP P C"
  apply (unfold bijP_def)
  apply auto
  apply (subgoal_tac "aa \<noteq> a")
   prefer 2
   apply clarify
  apply (subgoal_tac "aa \<noteq> b")
   prefer 2
   apply clarify
  apply (simp add: aux_uniq)
  apply (subgoal_tac "ba \<noteq> a")
   apply auto
  apply (subgoal_tac "P a aa")
   prefer 2
   apply (simp add: aux_sym)
  apply (subgoal_tac "b = aa")
   apply (rule_tac [2] iffD1)
    apply (rule_tac [2] a = a and c = a and P = P in aux_uniq)
      apply auto
  done

lemma aux_foo: "\<forall>a b. Q a \<and> P a b --> R b ==> P a b ==> Q a ==> R b"
  apply auto
  done

lemma aux_bij: "bijP P F ==> symP P ==> P a b ==> (a \<in> F) = (b \<in> F)"
  apply (unfold bijP_def)
  apply (rule iffI)
  apply (erule_tac [!] aux_foo)
      apply simp_all
  apply (rule iffD2)
   apply (rule_tac P = P in aux_sym)
   apply simp_all
  done

lemma aux_bijRER:
  "(A, B) \<in> bijR P ==> uniqP P ==> symP P
    ==> \<forall>F. bijP P F \<and> F \<subseteq> A \<and> F \<subseteq> B --> F \<in> bijER P"
  apply (erule bijR.induct)
   apply simp
  apply (case_tac "a = b")
   apply clarify
   apply (case_tac "b \<in> F")
    prefer 2
    apply (simp add: subset_insert)
   apply (cut_tac F = F and a = b and A = A and B = B in aux1)
        prefer 6
        apply clarify
        apply (rule bijER.insert1)
          apply simp_all
   apply (subgoal_tac "bijP P C")
    apply simp
   apply (rule aux_in1)
      apply simp_all
  apply clarify
  apply (case_tac "a \<in> F")
   apply (case_tac [!] "b \<in> F")
     apply (cut_tac F = F and a = a and b = b and A = A and B = B
       in aux2)
            apply (simp_all add: subset_insert)
    apply clarify
    apply (rule bijER.insert2)
        apply simp_all
    apply (subgoal_tac "bijP P C")
     apply simp
    apply (rule aux_in2)
          apply simp_all
   apply (subgoal_tac "b \<in> F")
    apply (rule_tac [2] iffD1)
     apply (rule_tac [2] a = a and F = F and P = P in aux_bij)
       apply (simp_all (no_asm_simp))
   apply (subgoal_tac [2] "a \<in> F")
    apply (rule_tac [3] iffD2)
     apply (rule_tac [3] b = b and F = F and P = P in aux_bij)
       apply auto
  done

lemma bijR_bijER:
  "(A, A) \<in> bijR P ==>
    bijP P A ==> uniqP P ==> symP P ==> A \<in> bijER P"
  apply (cut_tac A = A and B = A and P = P in aux_bijRER)
     apply auto
  done

end


(*  Title:      HOL/Library/Multiset_Order.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
*)

section \<open>More Theorems about the Multiset Order\<close>

theory Multiset_Order
imports Multiset
begin

subsection \<open>Alternative characterizations\<close>

context preorder
begin

lemma order_mult: "class.order
  (\<lambda>M N. (M, N) \<in> mult {(x, y). x < y} \<or> M = N)
  (\<lambda>M N. (M, N) \<in> mult {(x, y). x < y})"
  (is "class.order ?le ?less")
proof -
  have irrefl: "\<And>M :: 'a multiset. \<not> ?less M M"
  proof
    fix M :: "'a multiset"
    have "trans {(x'::'a, x). x' < x}"
      by (rule transI) (blast intro: less_trans)
    moreover
    assume "(M, M) \<in> mult {(x, y). x < y}"
    ultimately have "\<exists>I J K. M = I + J \<and> M = I + K
      \<and> J \<noteq> {#} \<and> (\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> {(x, y). x < y})"
      by (rule mult_implies_one_step)
    then obtain I J K where "M = I + J" and "M = I + K"
      and "J \<noteq> {#}" and "(\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> {(x, y). x < y})" by blast
    then have aux1: "K \<noteq> {#}" and aux2: "\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset K. k < j" by auto
    have "finite (set_mset K)" by simp
    moreover note aux2
    ultimately have "set_mset K = {}"
      by (induct rule: finite_induct)
       (simp, metis (mono_tags) insert_absorb insert_iff insert_not_empty less_irrefl less_trans)
    with aux1 show False by simp
  qed
  have trans: "\<And>K M N :: 'a multiset. ?less K M \<Longrightarrow> ?less M N \<Longrightarrow> ?less K N"
    unfolding mult_def by (blast intro: trancl_trans)
  show "class.order ?le ?less"
    by standard (auto simp add: less_eq_multiset_def irrefl dest: trans)
qed

text \<open>The Dershowitz--Manna ordering:\<close>

definition less_multiset\<^sub>D\<^sub>M where
  "less_multiset\<^sub>D\<^sub>M M N \<longleftrightarrow>
   (\<exists>X Y. X \<noteq> {#} \<and> X \<le># N \<and> M = (N - X) + Y \<and> (\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)))"

text \<open>The Huet--Oppen ordering:\<close>

definition less_multiset\<^sub>H\<^sub>O where
  "less_multiset\<^sub>H\<^sub>O M N \<longleftrightarrow> M \<noteq> N \<and> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x. y < x \<and> count M x < count N x))"

lemma mult_imp_less_multiset\<^sub>H\<^sub>O:
  "(M, N) \<in> mult {(x, y). x < y} \<Longrightarrow> less_multiset\<^sub>H\<^sub>O M N"
proof (unfold mult_def, induct rule: trancl_induct)
  case (base P)
  then show ?case
    by (auto elim!: mult1_lessE simp add: count_eq_zero_iff less_multiset\<^sub>H\<^sub>O_def split: if_splits dest!: Suc_lessD)
next
  case (step N P)
  from step(3) have "M \<noteq> N" and
    **: "\<And>y. count N y < count M y \<Longrightarrow> (\<exists>x>y. count M x < count N x)"
    by (simp_all add: less_multiset\<^sub>H\<^sub>O_def)
  from step(2) obtain M0 a K where
    *: "P = add_mset a M0" "N = M0 + K" "a \<notin># K" "\<And>b. b \<in># K \<Longrightarrow> b < a"
    by (blast elim: mult1_lessE)
  from \<open>M \<noteq> N\<close> ** *(1,2,3) have "M \<noteq> P" by (force dest: *(4) elim!: less_asym split: if_splits )
  moreover
  { assume "count P a \<le> count M a"
    with \<open>a \<notin># K\<close> have "count N a < count M a" unfolding *(1,2)
      by (auto simp add: not_in_iff)
      with ** obtain z where z: "z > a" "count M z < count N z"
        by blast
      with * have "count N z \<le> count P z"
        by (auto elim: less_asym intro: count_inI)
      with z have "\<exists>z > a. count M z < count P z" by auto
  } note count_a = this
  { fix y
    assume count_y: "count P y < count M y"
    have "\<exists>x>y. count M x < count P x"
    proof (cases "y = a")
      case True
      with count_y count_a show ?thesis by auto
    next
      case False
      show ?thesis
      proof (cases "y \<in># K")
        case True
        with *(4) have "y < a" by simp
        then show ?thesis by (cases "count P a \<le> count M a") (auto dest: count_a intro: less_trans)
      next
        case False
        with \<open>y \<noteq> a\<close> have "count P y = count N y" unfolding *(1,2)
          by (simp add: not_in_iff)
        with count_y ** obtain z where z: "z > y" "count M z < count N z" by auto
        show ?thesis
        proof (cases "z \<in># K")
          case True
          with *(4) have "z < a" by simp
          with z(1) show ?thesis
            by (cases "count P a \<le> count M a") (auto dest!: count_a intro: less_trans)
        next
          case False
          with \<open>a \<notin># K\<close> have "count N z \<le> count P z" unfolding *
            by (auto simp add: not_in_iff)
          with z show ?thesis by auto
        qed
      qed
    qed
  }
  ultimately show ?case unfolding less_multiset\<^sub>H\<^sub>O_def by blast
qed

lemma less_multiset\<^sub>D\<^sub>M_imp_mult:
  "less_multiset\<^sub>D\<^sub>M M N \<Longrightarrow> (M, N) \<in> mult {(x, y). x < y}"
proof -
  assume "less_multiset\<^sub>D\<^sub>M M N"
  then obtain X Y where
    "X \<noteq> {#}" and "X \<le># N" and "M = N - X + Y" and "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)"
    unfolding less_multiset\<^sub>D\<^sub>M_def by blast
  then have "(N - X + Y, N - X + X) \<in> mult {(x, y). x < y}"
    by (intro one_step_implies_mult) (auto simp: Bex_def trans_def)
  with \<open>M = N - X + Y\<close> \<open>X \<le># N\<close> show "(M, N) \<in> mult {(x, y). x < y}"
    by (metis subset_mset.diff_add)
qed

lemma less_multiset\<^sub>H\<^sub>O_imp_less_multiset\<^sub>D\<^sub>M: "less_multiset\<^sub>H\<^sub>O M N \<Longrightarrow> less_multiset\<^sub>D\<^sub>M M N"
unfolding less_multiset\<^sub>D\<^sub>M_def
proof (intro iffI exI conjI)
  assume "less_multiset\<^sub>H\<^sub>O M N"
  then obtain z where z: "count M z < count N z"
    unfolding less_multiset\<^sub>H\<^sub>O_def by (auto simp: multiset_eq_iff nat_neq_iff)
  define X where "X = N - M"
  define Y where "Y = M - N"
  from z show "X \<noteq> {#}" unfolding X_def by (auto simp: multiset_eq_iff not_less_eq_eq Suc_le_eq)
  from z show "X \<le># N" unfolding X_def by auto
  show "M = (N - X) + Y" unfolding X_def Y_def multiset_eq_iff count_union count_diff by force
  show "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)"
  proof (intro allI impI)
    fix k
    assume "k \<in># Y"
    then have "count N k < count M k" unfolding Y_def
      by (auto simp add: in_diff_count)
    with \<open>less_multiset\<^sub>H\<^sub>O M N\<close> obtain a where "k < a" and "count M a < count N a"
      unfolding less_multiset\<^sub>H\<^sub>O_def by blast
    then show "\<exists>a. a \<in># X \<and> k < a" unfolding X_def
      by (auto simp add: in_diff_count)
  qed
qed

lemma mult_less_multiset\<^sub>D\<^sub>M: "(M, N) \<in> mult {(x, y). x < y} \<longleftrightarrow> less_multiset\<^sub>D\<^sub>M M N"
  by (metis less_multiset\<^sub>D\<^sub>M_imp_mult less_multiset\<^sub>H\<^sub>O_imp_less_multiset\<^sub>D\<^sub>M mult_imp_less_multiset\<^sub>H\<^sub>O)

lemma mult_less_multiset\<^sub>H\<^sub>O: "(M, N) \<in> mult {(x, y). x < y} \<longleftrightarrow> less_multiset\<^sub>H\<^sub>O M N"
  by (metis less_multiset\<^sub>D\<^sub>M_imp_mult less_multiset\<^sub>H\<^sub>O_imp_less_multiset\<^sub>D\<^sub>M mult_imp_less_multiset\<^sub>H\<^sub>O)

lemmas mult\<^sub>D\<^sub>M = mult_less_multiset\<^sub>D\<^sub>M[unfolded less_multiset\<^sub>D\<^sub>M_def]
lemmas mult\<^sub>H\<^sub>O = mult_less_multiset\<^sub>H\<^sub>O[unfolded less_multiset\<^sub>H\<^sub>O_def]

end

lemma less_multiset_less_multiset\<^sub>H\<^sub>O:
  "M < N \<longleftrightarrow> less_multiset\<^sub>H\<^sub>O M N"
  unfolding less_multiset_def mult\<^sub>H\<^sub>O less_multiset\<^sub>H\<^sub>O_def ..

lemmas less_multiset\<^sub>D\<^sub>M = mult\<^sub>D\<^sub>M[folded less_multiset_def]
lemmas less_multiset\<^sub>H\<^sub>O = mult\<^sub>H\<^sub>O[folded less_multiset_def]

lemma subset_eq_imp_le_multiset:
  shows "M \<le># N \<Longrightarrow> M \<le> N"
  unfolding less_eq_multiset_def less_multiset\<^sub>H\<^sub>O
  by (simp add: less_le_not_le subseteq_mset_def)

lemma le_multiset_right_total:
  shows "M < add_mset x M"
  unfolding less_eq_multiset_def less_multiset\<^sub>H\<^sub>O by simp

lemma less_eq_multiset_empty_left[simp]:
  shows "{#} \<le> M"
  by (simp add: subset_eq_imp_le_multiset)

lemma ex_gt_imp_less_multiset: "(\<exists>y. y \<in># N \<and> (\<forall>x. x \<in># M \<longrightarrow> x < y)) \<Longrightarrow> M < N"
  unfolding less_multiset\<^sub>H\<^sub>O
  by (metis count_eq_zero_iff count_greater_zero_iff less_le_not_le)

lemma less_eq_multiset_empty_right[simp]:
  "M \<noteq> {#} \<Longrightarrow> \<not> M \<le> {#}"
  by (metis less_eq_multiset_empty_left antisym)

lemma le_multiset_empty_left[simp]: "M \<noteq> {#} \<Longrightarrow> {#} < M"
  by (simp add: less_multiset\<^sub>H\<^sub>O)

lemma le_multiset_empty_right[simp]: "\<not> M < {#}"
  using subset_mset.le_zero_eq less_multiset\<^sub>D\<^sub>M by blast

lemma union_le_diff_plus: "P \<le># M \<Longrightarrow> N < P \<Longrightarrow> M - P + N < M"
  by (drule subset_mset.diff_add[symmetric]) (metis union_le_mono2)

instantiation multiset :: (preorder) ordered_ab_semigroup_monoid_add_imp_le
begin

lemma less_eq_multiset\<^sub>H\<^sub>O:
  "M \<le> N \<longleftrightarrow> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x. y < x \<and> count M x < count N x))"
  by (auto simp: less_eq_multiset_def less_multiset\<^sub>H\<^sub>O)

instance by standard (auto simp: less_eq_multiset\<^sub>H\<^sub>O)

lemma
  fixes M N :: "'a multiset"
  shows
    less_eq_multiset_plus_left: "N \<le> (M + N)" and
    less_eq_multiset_plus_right: "M \<le> (M + N)"
  by simp_all

lemma
  fixes M N :: "'a multiset"
  shows
    le_multiset_plus_left_nonempty: "M \<noteq> {#} \<Longrightarrow> N < M + N" and
    le_multiset_plus_right_nonempty: "N \<noteq> {#} \<Longrightarrow> M < M + N"
    by simp_all

end

subsection \<open>Simprocs\<close>

lemma mset_le_add_iff1:
  "j \<le> (i::nat) \<Longrightarrow> (repeat_mset i u + m \<le> repeat_mset j u + n) = (repeat_mset (i-j) u + m \<le> n)"
proof -
  assume "j \<le> i"
  then have "j + (i - j) = i"
    using le_add_diff_inverse by blast
  then show ?thesis
    by (metis (no_types) add_le_cancel_left left_add_mult_distrib_mset)
qed

lemma mset_le_add_iff2:
  "i \<le> (j::nat) \<Longrightarrow> (repeat_mset i u + m \<le> repeat_mset j u + n) = (m \<le> repeat_mset (j-i) u + n)"
proof -
  assume "i \<le> j"
  then have "i + (j - i) = j"
    using le_add_diff_inverse by blast
  then show ?thesis
    by (metis (no_types) add_le_cancel_left left_add_mult_distrib_mset)
qed

lemma mset_less_add_iff1:
  "j \<le> (i::nat) \<Longrightarrow> (repeat_mset i u + m < repeat_mset j u + n) = (repeat_mset (i-j) u + m < n)"
  by (simp add: less_le_not_le mset_le_add_iff1 mset_le_add_iff2)

lemma mset_less_add_iff2:
     "i \<le> (j::nat) \<Longrightarrow> (repeat_mset i u + m < repeat_mset j u + n) = (m < repeat_mset (j-i) u + n)"
  by (simp add: less_le_not_le mset_le_add_iff1 mset_le_add_iff2)

ML_file "multiset_order_simprocs.ML"

simproc_setup msetless_cancel_numerals
  ("(l::'a::preorder multiset) + m < n" | "(l::'a multiset) < m + n" |
   "add_mset a m < n" | "m < add_mset a n") =
  \<open>fn phi => Multiset_Order_Simprocs.less_cancel_msets\<close>

simproc_setup msetle_cancel_numerals
  ("(l::'a::preorder multiset) + m \<le> n" | "(l::'a multiset) \<le> m + n" |
   "add_mset a m \<le> n" | "m \<le> add_mset a n") =
  \<open>fn phi => Multiset_Order_Simprocs.le_cancel_msets\<close>

subsection \<open>Additional facts and instantiations\<close>

lemma ex_gt_count_imp_le_multiset:
  "(\<forall>y :: 'a :: order. y \<in># M + N \<longrightarrow> y \<le> x) \<Longrightarrow> count M x < count N x \<Longrightarrow> M < N"
  unfolding less_multiset\<^sub>H\<^sub>O
  by (metis count_greater_zero_iff le_imp_less_or_eq less_imp_not_less not_gr_zero union_iff)

lemma mset_lt_single_iff[iff]: "{#x#} < {#y#} \<longleftrightarrow> x < y"
  unfolding less_multiset\<^sub>H\<^sub>O by simp

lemma mset_le_single_iff[iff]: "{#x#} \<le> {#y#} \<longleftrightarrow> x \<le> y" for x y :: "'a::order"
  unfolding less_eq_multiset\<^sub>H\<^sub>O by force

instance multiset :: (linorder) linordered_cancel_ab_semigroup_add
  by standard (metis less_eq_multiset\<^sub>H\<^sub>O not_less_iff_gr_or_eq)

lemma less_eq_multiset_total:
  fixes M N :: "'a :: linorder multiset"
  shows "\<not> M \<le> N \<Longrightarrow> N \<le> M"
  by simp

instantiation multiset :: (wellorder) wellorder
begin

lemma wf_less_multiset: "wf {(M :: 'a multiset, N). M < N}"
  unfolding less_multiset_def by (auto intro: wf_mult wf)

instance by standard (metis less_multiset_def wf wf_def wf_mult)

end

instantiation multiset :: (preorder) order_bot
begin

definition bot_multiset :: "'a multiset" where "bot_multiset = {#}"

instance by standard (simp add: bot_multiset_def)

end

instance multiset :: (preorder) no_top
proof standard
  fix x :: "'a multiset"
  obtain a :: 'a where True by simp
  have "x < x + (x + {#a#})"
    by simp
  then show "\<exists>y. x < y"
    by blast
qed

instance multiset :: (preorder) ordered_cancel_comm_monoid_add
  by standard

end


(* Title: Examples/Vector_Spaces/VS_Groups.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Groups\<close>
theory VS_Groups
  imports VS_Prerequisites
begin

subsection\<open>Definitions and elementary properties\<close>

locale semigroup_add_ow =
  fixes S :: "'a set" and pls :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl \<open>\<oplus>\<^sub>o\<^sub>w\<close> 65)
  assumes add_assoc:
    "\<lbrakk> a \<in> S; b \<in> S; c \<in> S \<rbrakk> \<Longrightarrow> (a \<oplus>\<^sub>o\<^sub>w b) \<oplus>\<^sub>o\<^sub>w c = a \<oplus>\<^sub>o\<^sub>w (b \<oplus>\<^sub>o\<^sub>w c)"
    and add_closed: "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> a \<oplus>\<^sub>o\<^sub>w b \<in> S"
begin

lemma add_closed'[simp]: "\<forall>x\<in>S. \<forall>y\<in>S. x \<oplus>\<^sub>o\<^sub>w y \<in> S" by (auto simp: add_closed)

end

locale ab_semigroup_add_ow = semigroup_add_ow +
  assumes add_commute: "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> a \<oplus>\<^sub>o\<^sub>w b = b \<oplus>\<^sub>o\<^sub>w a"

locale comm_monoid_add_ow = ab_semigroup_add_ow +
  fixes z
  assumes add_zero: "a \<in> S \<Longrightarrow> z \<oplus>\<^sub>o\<^sub>w a = a"
    and zero_closed[simp]: "z \<in> S"
begin

lemma carrier_ne[simp]: "S \<noteq> {}" using zero_closed by blast

end

definition "sum_with pls z f S =
  (
    if \<exists>C. f ` S \<subseteq> C \<and> comm_monoid_add_ow C pls z
    then Finite_Set.fold (pls o f) z S
    else z
  )"

lemma sum_with_empty[simp]: "sum_with pls z f {} = z"
  by (auto simp: sum_with_def)

lemma sum_with_cases[case_names comm zero]:
  assumes "\<And>C. \<lbrakk> f ` S \<subseteq> C; comm_monoid_add_ow C pls z \<rbrakk> \<Longrightarrow>
      P (Finite_Set.fold (pls o f) z S)"
    and "(\<And>C. comm_monoid_add_ow C pls z \<Longrightarrow> (\<exists>s\<in>S. f s \<notin> C)) \<Longrightarrow> P z"
  shows "P (sum_with pls z f S)"
  using assms by (auto simp: sum_with_def)

context comm_monoid_add_ow
begin

lemma sum_with_infinite: "infinite A \<Longrightarrow> sum_with (\<oplus>\<^sub>o\<^sub>w) z g A = z"
  by (induction rule: sum_with_cases) auto

context
begin

abbreviation pls' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "pls' \<equiv> \<lambda>x y. (if x \<in> S then x else z) \<oplus>\<^sub>o\<^sub>w (if y \<in> S then y else z)"

lemma fold_pls'_closed: "Finite_Set.fold (pls' \<circ> g) z A \<in> S" if "g ` A \<subseteq> S"
proof cases
  assume A: "finite A"
  interpret comp_fun_commute "pls' o g"
    using that add_assoc add_commute add_closed zero_closed
    by unfold_locales auto
  from fold_graph_fold[OF A] have
    "fold_graph (pls' \<circ> g) z A (Finite_Set.fold (pls' \<circ> g) z A)" .
  from
    fold_graph_closed_lemma[OF this, of S "pls' \<circ> g"]
    add_assoc
    add_commute
    add_closed
    zero_closed
  show ?thesis
    by auto
qed (use add_assoc add_commute add_closed zero_closed in simp)

lemma fold_pls'_eq:
  assumes "g ` A \<subseteq> S"
  shows "Finite_Set.fold (pls' \<circ> g) z A = Finite_Set.fold (pls \<circ> g) z A"
  using add_assoc add_commute add_closed zero_closed assms
  by (intro fold_closed_eq[where B=S]) auto

lemma sum_with_closed:
  assumes "g ` A \<subseteq> S"
  shows "sum_with pls z g A \<in> S"
proof -
  interpret comp_fun_commute "pls' o g"
    using add_assoc add_commute add_closed zero_closed assms
    by unfold_locales auto
  have "\<exists>C. g ` A \<subseteq> C \<and> comm_monoid_add_ow C pls z"
    using assms comm_monoid_add_ow_axioms by auto
  then show ?thesis
    using fold_pls'_closed[OF assms]
    by (simp add: sum_with_def fold_pls'_eq assms)
qed

lemma sum_with_insert:
  assumes g_into: "g x \<in> S" "g ` A \<subseteq> S"
    and A: "finite A"
    and x: "x \<notin> A"
  shows "sum_with pls z g (insert x A) = (g x) \<oplus>\<^sub>o\<^sub>w (sum_with pls z g A)"
proof -
  interpret comp_fun_commute "pls' o g"
    using add_assoc add_commute add_closed zero_closed g_into by unfold_locales auto
  have
    "Finite_Set.fold (pls \<circ> g) z (insert x A) =
      Finite_Set.fold (pls' \<circ> g) z (insert x A)"
    using g_into by (subst fold_pls'_eq) auto
  also have "\<dots> = pls' (g x) (Finite_Set.fold (pls' \<circ> g) z A)"
    unfolding fold_insert[OF A x] by (auto simp: o_def)
  also have "\<dots> = (g x) \<oplus>\<^sub>o\<^sub>w (Finite_Set.fold (pls' \<circ> g) z A)"
  proof -
    from fold_graph_fold[OF A] have
      "fold_graph (pls' \<circ> g) z A (Finite_Set.fold (pls' \<circ> g) z A)" .
    from
      fold_graph_closed_lemma[OF this, of S "pls' \<circ> g"]
      add_assoc
      add_commute
      add_closed
      zero_closed
    have "Finite_Set.fold (pls' \<circ> g) z A \<in> S"
      by auto
    then show ?thesis using g_into by auto
  qed
  also have
    "Finite_Set.fold (pls' \<circ> g) z A = Finite_Set.fold (pls \<circ> g) z A"
    using g_into by (subst fold_pls'_eq) auto
  finally have
    "Finite_Set.fold (pls \<circ> g) z (insert x A) =
      pls (g x) (Finite_Set.fold (pls \<circ> g) z A)" .
  moreover have
    "\<exists>C. g ` insert x A \<subseteq> C \<and> comm_monoid_add_ow C pls z"
    "\<exists>C. g ` A \<subseteq> C \<and> comm_monoid_add_ow C pls z"
    using assms(1,2) comm_monoid_add_ow_axioms by auto
  ultimately show ?thesis by (simp add: sum_with_def)
qed

end

end

locale ab_group_add_ow = comm_monoid_add_ow +
  fixes mns um
  assumes ab_left_minus: "a \<in> S \<Longrightarrow> (um a) \<oplus>\<^sub>o\<^sub>w a = z"
    and ab_diff_conv_add_uminus:
      "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> mns a b = a \<oplus>\<^sub>o\<^sub>w (um b)"
    and uminus_closed: "a \<in> S \<Longrightarrow> um a \<in> S"

subsection\<open>Instances (by type class constraints)\<close>

lemma semigroup_add_ow_Ball_def:
  "semigroup_add_ow S pls \<longleftrightarrow>
  (\<forall>a\<in>S. \<forall>b\<in>S. \<forall>c\<in>S. pls (pls a b) c =
    pls a (pls b c)) \<and> (\<forall>a\<in>S. \<forall>b\<in>S. pls a b \<in> S)"
  by (auto simp: semigroup_add_ow_def)

lemma ab_semigroup_add_ow_Ball_def:
  "ab_semigroup_add_ow S pls \<longleftrightarrow>
    semigroup_add_ow S pls \<and> (\<forall>a\<in>S. \<forall>b\<in>S. pls a b = pls b a)"
  by  (auto simp: ab_semigroup_add_ow_def ab_semigroup_add_ow_axioms_def)

lemma comm_monoid_add_ow_Ball_def:
  "comm_monoid_add_ow S pls z \<longleftrightarrow>
    ab_semigroup_add_ow S pls \<and> (\<forall>a\<in>S. pls z a = a) \<and> z \<in> S"
  by (auto simp: comm_monoid_add_ow_def comm_monoid_add_ow_axioms_def)

lemma comm_monoid_add_ow[simp]:
  "comm_monoid_add_ow UNIV (+) (0::'a::comm_monoid_add)"
  by
    (
      auto simp:
        comm_monoid_add_ow_Ball_def
        ab_semigroup_add_ow_Ball_def
        semigroup_add_ow_Ball_def
        ac_simps
    )

lemma ab_group_add_ow_Ball_def:
  "ab_group_add_ow S pls z mns um \<longleftrightarrow>
    comm_monoid_add_ow S pls z \<and>
    (\<forall>a\<in>S. pls (um a) a = z) \<and>
    (\<forall>a\<in>S. \<forall>b\<in>S. mns a b = pls a (um b)) \<and>
    (\<forall>a\<in>S. um a \<in> S)"
  by (auto simp: ab_group_add_ow_def ab_group_add_ow_axioms_def)

lemma sum_with[ud_with]: "sum = sum_with (+) 0"
proof(intro HOL.ext)
  fix f :: "'a \<Rightarrow> 'b" and S :: "'a set"
  show "sum f S = sum_with (+) 0 f S"
  proof(induction rule: sum_with_cases)
    case (comm C) then show ?case unfolding sum.eq_fold by simp
  next
    case zero from zero[OF comm_monoid_add_ow] show ?case by simp
  qed
qed

lemmas [tts_implicit] = sum_with[symmetric]

subsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma semigroup_add_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> (A ===> A ===> A) ===> (=))
    semigroup_add_ow semigroup_add_ow"
  unfolding semigroup_add_ow_Ball_def
  by transfer_prover

lemma Domainp_applyI:
  includes lifting_syntax
  shows "(A ===> B) f g \<Longrightarrow> A x y \<Longrightarrow> Domainp B (f x)"
  by (auto simp: rel_fun_def)

lemma Domainp_apply2I:
  includes lifting_syntax
  shows "(A ===> B ===> C) f g \<Longrightarrow> A x y \<Longrightarrow> B x' y' \<Longrightarrow> Domainp C (f x x')"
  by (force simp: rel_fun_def)

lemma ab_semigroup_add_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A"
  shows
    "(rel_set A ===> (A ===> A ===> A) ===> (=))
      ab_semigroup_add_ow ab_semigroup_add_ow"
  unfolding ab_semigroup_add_ow_Ball_def by transfer_prover

lemma right_total_semigroup_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows "((A ===> A ===> A) ===> (=))
    (semigroup_add_ow (Collect (Domainp A))) class.semigroup_add"
proof -
  let ?P = "((A ===> A ===> A) ===> (=))"
  let ?semigroup_add_ow = "(\<lambda>f. semigroup_add_ow (Collect (Domainp A)) f)"
  let ?rf_UNIV =
    "(\<lambda>f::['b, 'b] \<Rightarrow> 'b. (\<forall>x y. x \<in> UNIV \<longrightarrow> y \<in> UNIV \<longrightarrow> f x y \<in> UNIV))"
  have "?P ?semigroup_add_ow (\<lambda>f. ?rf_UNIV f \<and> class.semigroup_add f)"
    unfolding semigroup_add_ow_def class.semigroup_add_def
    apply transfer_prover_start
    apply transfer_step+
    by auto
  thus ?thesis by simp
qed

lemma comm_monoid_add_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A"
  shows
    "(rel_set A ===> (A ===> A ===> A) ===> A ===> (=))
      comm_monoid_add_ow comm_monoid_add_ow"
  unfolding comm_monoid_add_ow_Ball_def by transfer_prover

lemma right_total_ab_semigroup_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows
    "((A ===> A ===> A) ===> (=))
      (ab_semigroup_add_ow (Collect (Domainp A))) class.ab_semigroup_add"
  unfolding
    class.ab_semigroup_add_def
    class.ab_semigroup_add_axioms_def
    ab_semigroup_add_ow_Ball_def
  by transfer_prover

lemma right_total_comm_monoid_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows "((A ===> A ===> A) ===> A ===> (=))
    (comm_monoid_add_ow (Collect (Domainp A))) class.comm_monoid_add"
proof(intro rel_funI)
  fix p p' z z'
  assume [transfer_rule]: "(A ===> A ===> A) p p'" "A z z'"
  show
    "comm_monoid_add_ow (Collect (Domainp A)) p z =
      class.comm_monoid_add p' z'"
    unfolding
      class.comm_monoid_add_def
      class.comm_monoid_add_axioms_def
      comm_monoid_add_ow_Ball_def
    apply transfer
    using \<open>A z z'\<close>
    by auto
qed

lemma ab_group_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows
    "((A ===> A ===> A) ===> A  ===> (A ===> A ===> A) ===> (A ===> A)===> (=))
      (ab_group_add_ow (Collect (Domainp A))) class.ab_group_add"
proof (intro rel_funI)
  fix p p' z z' m m' um um'
  assume [transfer_rule]:
    "(A ===> A ===> A) p p'" "A z z'" "(A ===> A ===> A) m m'"
    and um[transfer_rule]: "(A ===> A) um um'"
  show
    "ab_group_add_ow (Collect (Domainp A)) p z m um =
      class.ab_group_add p' z' m' um'"
    unfolding
      class.ab_group_add_def
      class.ab_group_add_axioms_def
      ab_group_add_ow_Ball_def
    by transfer (use um in \<open>auto simp: rel_fun_def\<close>)
qed

lemma ex_comm_monoid_add_around_imageE:
  assumes ex_comm: "\<exists>C. f ` S \<subseteq> C \<and> comm_monoid_add_ow C pls zero"
    and transfers:
    "(A ===> A ===> A) pls pls'"
    "A zero zero'"
    "Domainp (rel_set B) S"
    and in_dom: "\<And>x. x \<in> S \<Longrightarrow> Domainp A (f x)"
  obtains C where
    "comm_monoid_add_ow C pls zero" "f ` S \<subseteq> C" "Domainp (rel_set A) C"
proof -
  from ex_comm obtain C0 where C0: "f ` S \<subseteq> C0"
    and comm: "comm_monoid_add_ow C0 pls zero"
    by auto
  define C where "C = C0 \<inter> Collect (Domainp A)"
  have "comm_monoid_add_ow C pls zero"
    using comm Domainp_apply2I[OF \<open>(A ===> A ===> A) pls pls'\<close>] \<open>A zero zero'\<close>
    by
      (
        auto simp:
          comm_monoid_add_ow_Ball_def
          ab_semigroup_add_ow_Ball_def
          semigroup_add_ow_def
          C_def
      )
  moreover have "f ` S \<subseteq> C" using C0 by (auto simp: C_def in_dom)
  moreover have "Domainp (rel_set A) C" by (auto simp: C_def Domainp_set)
  ultimately show ?thesis ..
qed

lemma Domainp_sum_with:
  includes lifting_syntax
  assumes "\<And>x. x \<in> t \<Longrightarrow> Domainp A (r x)" "t \<subseteq> Collect (Domainp A)"
    and transfer_rules[transfer_rule]: "(A ===> A ===> A) p p'" "A z z'"
  shows DsI: "Domainp A (sum_with p z r t)"
proof cases
    assume ex: "\<exists>C. r ` t \<subseteq> C \<and> comm_monoid_add_ow C p z"
    have "Domainp (rel_set A) t" using assms by (auto simp: Domainp_set)
    from ex_comm_monoid_add_around_imageE[
        OF ex transfer_rules(1,2) this assms(1)
        ]
    obtain C where C:
      "comm_monoid_add_ow C p z" "r ` t \<subseteq> C" "Domainp (rel_set A) C"
      by auto
    interpret comm_monoid_add_ow C p z by fact
    from sum_with_closed[OF C(2)] C(3)
    show ?thesis by auto (meson C(3) Domainp_set)
qed (use \<open>A z _\<close> in \<open>auto simp: sum_with_def\<close>)

lemma sum_with_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique A" "bi_unique B"
  shows "((A ===> A ===> A) ===> A ===> (B ===> A) ===> rel_set B ===> A)
    sum_with sum_with"
proof(intro rel_funI)
  fix pls pls' zero zero' f g S T
  assume transfer_pls[transfer_rule]: "(A ===> A ===> A) pls pls'"
    and transfer_zero[transfer_rule]: "A zero zero'"
  assume transfer_g[transfer_rule]: "(B ===> A) f g"
    and transfer_T[transfer_rule]: "rel_set B S T"
  show "A (sum_with pls zero f S) (sum_with pls' zero' g T)"
  proof cases
    assume ex_comm: "\<exists>C. f ` S \<subseteq> C \<and> comm_monoid_add_ow C pls zero"
    have Domains: "Domainp (rel_set B) S" "(\<And>x. x \<in> S \<Longrightarrow> Domainp A (f x))"
      using transfer_T transfer_g by auto (meson Domainp_applyI rel_set_def)
    from ex_comm_monoid_add_around_imageE[
        OF ex_comm transfer_pls transfer_zero Domains
        ]
    obtain C where comm: "comm_monoid_add_ow C pls zero"
      and C: "f ` S \<subseteq> C"
      and "Domainp (rel_set A) C"
      by auto
    then obtain C' where [transfer_rule]: "rel_set A C C'" by auto
    interpret comm: comm_monoid_add_ow C pls zero by fact
    have C': "g ` T \<subseteq> C'" by transfer (rule C)
    have comm': "comm_monoid_add_ow C' pls' zero'" by transfer (rule comm)
    then interpret comm': comm_monoid_add_ow C' pls' zero' .
    from C' comm' have ex_comm':
      "\<exists>C. g ` T \<subseteq> C \<and> comm_monoid_add_ow C pls' zero'"
      by auto
    show ?thesis
      using transfer_T C C'
    proof (induction S arbitrary: T rule: infinite_finite_induct)
      case (infinite S)
      note [transfer_rule] = infinite.prems
      from infinite.hyps have "infinite T" by transfer
      then show ?case by (simp add: sum_with_def infinite.hyps \<open>A zero zero'\<close>)
    next
      case [transfer_rule]: empty
      have "T = {}" by transfer rule
      then show ?case by (simp add: sum_with_def \<open>A zero zero'\<close>)
    next
      case (insert x F)
      note [transfer_rule] = insert.prems(1)
      have [simp]: "finite T" by transfer (simp add: insert.hyps)
      obtain y where [transfer_rule]: "B x y" and y: "y \<in> T"
        by (meson insert.prems insertI1 rel_setD1)
      define T' where "T' = T - {y}"
      have T_def: "T = insert y T'" by (auto simp: T'_def y)
      define sF where "sF = sum_with pls zero f F"
      define sT where "sT = sum_with pls' zero' g T'"
      have [simp]: "y \<notin> T'" "finite T'" by (auto simp: y T'_def)
      have "rel_set B (insert x F - {x}) T'"
        unfolding T'_def by transfer_prover
      then have transfer_T'[transfer_rule]: "rel_set B F T'"
        using insert.hyps by simp
      from insert.prems have "f ` F \<subseteq> C" "g ` T' \<subseteq> C'" by (auto simp: T'_def)
      from insert.IH[OF transfer_T' this] have [transfer_rule]: "A sF sT"
        by (auto simp: sF_def sT_def o_def)
      have rew:
        "(sum_with pls zero f (insert x F)) =
          pls (f x) (sum_with pls zero f F)"
        apply (subst comm.sum_with_insert)
        subgoal using insert.prems by auto
        subgoal using insert.prems by auto
        subgoal by fact
        subgoal by fact
        subgoal by auto
        done
      have rew':
        "(sum_with pls' zero' g (insert y T')) =
          pls' (g y) (sum_with pls' zero' g T')"
        apply (subst comm'.sum_with_insert)
        subgoal
          apply transfer
          using insert.prems by auto
        subgoal
          apply transfer
          using insert.prems by auto
        subgoal by fact
        subgoal by fact
        subgoal by auto
        done
      have
        "A
          (sum_with pls zero f (insert x F))
          (sum_with pls' zero' g (insert y T'))"
        unfolding sT_def[symmetric] sF_def[symmetric] rew rew'
        by transfer_prover
      then show ?case by (simp add: T_def)
    qed
  next
    assume *: "\<nexists>C. f ` S \<subseteq> C \<and> comm_monoid_add_ow C pls zero"
    then have **: "\<nexists>C'. g ` T \<subseteq> C' \<and> comm_monoid_add_ow C' pls' zero'"
      by transfer simp
    show ?thesis by (simp add: sum_with_def * ** \<open>A zero zero'\<close>)
  qed
qed

end

subsection\<open>Relativization.\<close>

context ab_group_add_ow
begin

tts_context
  tts: (?'a to S)
  rewriting ctr_simps
  substituting comm_monoid_add_ow_axioms
  eliminating \<open>S \<noteq> {}\<close> through auto
  applying [OF add_closed' zero_closed]
begin

tts_lemma mono_neutral_cong_left:
  assumes "range h \<subseteq> S"
    and "range g \<subseteq> S"
    and "finite T"
    and "Sa \<subseteq> T"
    and "\<forall>x\<in>T - Sa. h x = z"
    and "\<And>x. x \<in> Sa \<Longrightarrow> g x = h x"
  shows "sum_with (\<oplus>\<^sub>o\<^sub>w) z g Sa = sum_with (\<oplus>\<^sub>o\<^sub>w) z h T"
    is sum.mono_neutral_cong_left.

end

end

text\<open>\newpage\<close>

end


section\<open>Negation Type\<close>
theory Negation_Type
imports Main
begin

text\<open>Store some @{typ 'a} and remember symbolically whether you mean just @{term a} or @{term "\<not> a"}.\<close>

text\<open>Only negated or non-negated literals\<close>
datatype 'a negation_type = Pos 'a | Neg 'a

fun getPos :: "'a negation_type list \<Rightarrow> 'a list" where
  "getPos [] = []" |
  "getPos ((Pos x)#xs) = x#(getPos xs)" |
  "getPos (_#xs) = getPos xs"

fun getNeg :: "'a negation_type list \<Rightarrow> 'a list" where
  "getNeg [] = []" |
  "getNeg ((Neg x)#xs) = x#(getNeg xs)" |
  "getNeg (_#xs) = getNeg xs"

lemma getPos_append: "getPos (as@bs) = getPos as @ getPos bs"
  by(induct as rule: getPos.induct) simp+

lemma getNeg_append: "getNeg (as@bs) = getNeg as @ getNeg bs"
  by(induct as rule: getNeg.induct) simp+

text\<open>If there is @{typ "'a negation_type"}, then apply a @{term map} only to @{typ 'a}.
I.e. keep @{term Neg} and @{term Pos}\<close>
fun NegPos_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a negation_type list \<Rightarrow> 'b negation_type list" where
  "NegPos_map _ [] = []" |
  "NegPos_map f ((Pos a)#as) = (Pos (f a))#NegPos_map f as" |
  "NegPos_map f ((Neg a)#as) = (Neg (f a))#NegPos_map f as"

text\<open>Example\<close>
lemma "NegPos_map (\<lambda>x::nat. x+1) [Pos 0, Neg 1] = [Pos 1, Neg 2]" by eval

lemma getPos_NegPos_map_simp: "(getPos (NegPos_map X (map Pos src))) = map X src"
  by(induction src) (simp_all)
lemma getNeg_NegPos_map_simp: "(getNeg (NegPos_map X (map Neg src))) = map X src"
  by(induction src) (simp_all)
lemma getNeg_Pos_empty: "(getNeg (NegPos_map X (map Pos src))) = []"
  by(induction src) (simp_all)
lemma getNeg_Neg_empty: "(getPos (NegPos_map X (map Neg src))) = []"
  by(induction src) (simp_all)
lemma getPos_NegPos_map_simp2: "(getPos (NegPos_map X src)) = map X (getPos src)"
  by(induction src rule: getPos.induct) (simp_all)
lemma getNeg_NegPos_map_simp2: "(getNeg (NegPos_map X src)) = map X (getNeg src)"
  by(induction src rule: getPos.induct) (simp_all)
lemma getPos_id: "getPos (map Pos xs) = xs"
  by(induction xs) (simp_all)

lemmas NegPos_map_simps = getPos_NegPos_map_simp getNeg_NegPos_map_simp getNeg_Pos_empty getNeg_Neg_empty getPos_NegPos_map_simp2
                          getNeg_NegPos_map_simp2 getPos_id getNeg_id getPos_empty2 getNeg_empty2

lemma NegPos_map_map_Neg: "NegPos_map C (map Neg as) = map Neg (map C as)"
  by(induction as) (simp_all)
lemma NegPos_map_map_Pos: "NegPos_map C (map Pos as) = map Pos (map C as)"
  by(induction as) (simp_all)

lemma NegPos_map_append: "NegPos_map C (as @ bs) = NegPos_map C as @ NegPos_map C bs"
  by(induction as rule: getNeg.induct) (simp_all)

lemma negation_type_forall_split: "(\<forall>is\<in>set Ms. case is of Pos i \<Rightarrow> P i | Neg i \<Rightarrow> Q i) \<longleftrightarrow> (\<forall>i\<in>set (getPos Ms). P i) \<and> (\<forall>i\<in>set (getNeg Ms). Q i)"
  apply(rule)
   apply(simp split: negation_type.split_asm)
   using NegPos_set(1) NegPos_set(2) apply force
  apply(simp split: negation_type.split)
  using NegPos_set(1) NegPos_set(2) by fastforce

fun invert :: "'a negation_type \<Rightarrow> 'a negation_type" where
  "invert (Pos x) = Neg x" |
  "invert (Neg x) = Pos x"

lemma invert_invert_id: "invert \<circ> invert = id"
  apply(clarsimp simp add: fun_eq_iff, rename_tac x, case_tac x)
   by simp+

end


(*  Title:      HOL/Library/Product_Vector.thy
    Author:     Brian Huffman
*)

section {* Cartesian Products as Vector Spaces *}

theory Product_Vector
imports Inner_Product Product_plus
begin

subsection {* Product is a real vector space *}

instantiation prod :: (real_vector, real_vector) real_vector
begin

definition scaleR_prod_def:
  "scaleR r A = (scaleR r (fst A), scaleR r (snd A))"

lemma fst_scaleR [simp]: "fst (scaleR r A) = scaleR r (fst A)"
  unfolding scaleR_prod_def by simp

lemma snd_scaleR [simp]: "snd (scaleR r A) = scaleR r (snd A)"
  unfolding scaleR_prod_def by simp

lemma scaleR_Pair [simp]: "scaleR r (a, b) = (scaleR r a, scaleR r b)"
  unfolding scaleR_prod_def by simp

instance proof
  fix a b :: real and x y :: "'a \<times> 'b"
  show "scaleR a (x + y) = scaleR a x + scaleR a y"
    by (simp add: prod_eq_iff scaleR_right_distrib)
  show "scaleR (a + b) x = scaleR a x + scaleR b x"
    by (simp add: prod_eq_iff scaleR_left_distrib)
  show "scaleR a (scaleR b x) = scaleR (a * b) x"
    by (simp add: prod_eq_iff)
  show "scaleR 1 x = x"
    by (simp add: prod_eq_iff)
qed

end

subsection {* Product is a topological space *}

instantiation prod :: (topological_space, topological_space) topological_space
begin

definition open_prod_def[code del]:
  "open (S :: ('a \<times> 'b) set) \<longleftrightarrow>
    (\<forall>x\<in>S. \<exists>A B. open A \<and> open B \<and> x \<in> A \<times> B \<and> A \<times> B \<subseteq> S)"

lemma open_prod_elim:
  assumes "open S" and "x \<in> S"
  obtains A B where "open A" and "open B" and "x \<in> A \<times> B" and "A \<times> B \<subseteq> S"
using assms unfolding open_prod_def by fast

lemma open_prod_intro:
  assumes "\<And>x. x \<in> S \<Longrightarrow> \<exists>A B. open A \<and> open B \<and> x \<in> A \<times> B \<and> A \<times> B \<subseteq> S"
  shows "open S"
using assms unfolding open_prod_def by fast

instance proof
  show "open (UNIV :: ('a \<times> 'b) set)"
    unfolding open_prod_def by auto
next
  fix S T :: "('a \<times> 'b) set"
  assume "open S" "open T"
  show "open (S \<inter> T)"
  proof (rule open_prod_intro)
    fix x assume x: "x \<in> S \<inter> T"
    from x have "x \<in> S" by simp
    obtain Sa Sb where A: "open Sa" "open Sb" "x \<in> Sa \<times> Sb" "Sa \<times> Sb \<subseteq> S"
      using `open S` and `x \<in> S` by (rule open_prod_elim)
    from x have "x \<in> T" by simp
    obtain Ta Tb where B: "open Ta" "open Tb" "x \<in> Ta \<times> Tb" "Ta \<times> Tb \<subseteq> T"
      using `open T` and `x \<in> T` by (rule open_prod_elim)
    let ?A = "Sa \<inter> Ta" and ?B = "Sb \<inter> Tb"
    have "open ?A \<and> open ?B \<and> x \<in> ?A \<times> ?B \<and> ?A \<times> ?B \<subseteq> S \<inter> T"
      using A B by (auto simp add: open_Int)
    thus "\<exists>A B. open A \<and> open B \<and> x \<in> A \<times> B \<and> A \<times> B \<subseteq> S \<inter> T"
      by fast
  qed
next
  fix K :: "('a \<times> 'b) set set"
  assume "\<forall>S\<in>K. open S" thus "open (\<Union>K)"
    unfolding open_prod_def by fast
qed

end

declare [[code abort: "open::('a::topological_space*'b::topological_space) set \<Rightarrow> bool"]]

lemma open_Times: "open S \<Longrightarrow> open T \<Longrightarrow> open (S \<times> T)"
unfolding open_prod_def by auto

lemma fst_vimage_eq_Times: "fst -` S = S \<times> UNIV"
by auto

lemma snd_vimage_eq_Times: "snd -` S = UNIV \<times> S"
by auto

lemma open_vimage_fst: "open S \<Longrightarrow> open (fst -` S)"
by (simp add: fst_vimage_eq_Times open_Times)

lemma open_vimage_snd: "open S \<Longrightarrow> open (snd -` S)"
by (simp add: snd_vimage_eq_Times open_Times)

lemma closed_vimage_fst: "closed S \<Longrightarrow> closed (fst -` S)"
unfolding closed_open vimage_Compl [symmetric]
by (rule open_vimage_fst)

lemma closed_vimage_snd: "closed S \<Longrightarrow> closed (snd -` S)"
unfolding closed_open vimage_Compl [symmetric]
by (rule open_vimage_snd)

lemma closed_Times: "closed S \<Longrightarrow> closed T \<Longrightarrow> closed (S \<times> T)"
proof -
  have "S \<times> T = (fst -` S) \<inter> (snd -` T)" by auto
  thus "closed S \<Longrightarrow> closed T \<Longrightarrow> closed (S \<times> T)"
    by (simp add: closed_vimage_fst closed_vimage_snd closed_Int)
qed

lemma subset_fst_imageI: "A \<times> B \<subseteq> S \<Longrightarrow> y \<in> B \<Longrightarrow> A \<subseteq> fst ` S"
  unfolding image_def subset_eq by force

lemma subset_snd_imageI: "A \<times> B \<subseteq> S \<Longrightarrow> x \<in> A \<Longrightarrow> B \<subseteq> snd ` S"
  unfolding image_def subset_eq by force

lemma open_image_fst: assumes "open S" shows "open (fst ` S)"
proof (rule openI)
  fix x assume "x \<in> fst ` S"
  then obtain y where "(x, y) \<in> S" by auto
  then obtain A B where "open A" "open B" "x \<in> A" "y \<in> B" "A \<times> B \<subseteq> S"
    using `open S` unfolding open_prod_def by auto
  from `A \<times> B \<subseteq> S` `y \<in> B` have "A \<subseteq> fst ` S" by (rule subset_fst_imageI)
  with `open A` `x \<in> A` have "open A \<and> x \<in> A \<and> A \<subseteq> fst ` S" by simp
  then show "\<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> fst ` S" by - (rule exI)
qed

lemma open_image_snd: assumes "open S" shows "open (snd ` S)"
proof (rule openI)
  fix y assume "y \<in> snd ` S"
  then obtain x where "(x, y) \<in> S" by auto
  then obtain A B where "open A" "open B" "x \<in> A" "y \<in> B" "A \<times> B \<subseteq> S"
    using `open S` unfolding open_prod_def by auto
  from `A \<times> B \<subseteq> S` `x \<in> A` have "B \<subseteq> snd ` S" by (rule subset_snd_imageI)
  with `open B` `y \<in> B` have "open B \<and> y \<in> B \<and> B \<subseteq> snd ` S" by simp
  then show "\<exists>T. open T \<and> y \<in> T \<and> T \<subseteq> snd ` S" by - (rule exI)
qed

subsubsection {* Continuity of operations *}

lemma tendsto_fst [tendsto_intros]:
  assumes "(f ---> a) F"
  shows "((\<lambda>x. fst (f x)) ---> fst a) F"
proof (rule topological_tendstoI)
  fix S assume "open S" and "fst a \<in> S"
  then have "open (fst -` S)" and "a \<in> fst -` S"
    by (simp_all add: open_vimage_fst)
  with assms have "eventually (\<lambda>x. f x \<in> fst -` S) F"
    by (rule topological_tendstoD)
  then show "eventually (\<lambda>x. fst (f x) \<in> S) F"
    by simp
qed

lemma tendsto_snd [tendsto_intros]:
  assumes "(f ---> a) F"
  shows "((\<lambda>x. snd (f x)) ---> snd a) F"
proof (rule topological_tendstoI)
  fix S assume "open S" and "snd a \<in> S"
  then have "open (snd -` S)" and "a \<in> snd -` S"
    by (simp_all add: open_vimage_snd)
  with assms have "eventually (\<lambda>x. f x \<in> snd -` S) F"
    by (rule topological_tendstoD)
  then show "eventually (\<lambda>x. snd (f x) \<in> S) F"
    by simp
qed

lemma tendsto_Pair [tendsto_intros]:
  assumes "(f ---> a) F" and "(g ---> b) F"
  shows "((\<lambda>x. (f x, g x)) ---> (a, b)) F"
proof (rule topological_tendstoI)
  fix S assume "open S" and "(a, b) \<in> S"
  then obtain A B where "open A" "open B" "a \<in> A" "b \<in> B" "A \<times> B \<subseteq> S"
    unfolding open_prod_def by fast
  have "eventually (\<lambda>x. f x \<in> A) F"
    using `(f ---> a) F` `open A` `a \<in> A`
    by (rule topological_tendstoD)
  moreover
  have "eventually (\<lambda>x. g x \<in> B) F"
    using `(g ---> b) F` `open B` `b \<in> B`
    by (rule topological_tendstoD)
  ultimately
  show "eventually (\<lambda>x. (f x, g x) \<in> S) F"
    by (rule eventually_elim2)
       (simp add: subsetD [OF `A \<times> B \<subseteq> S`])
qed

lemma continuous_fst[continuous_intros]: "continuous F f \<Longrightarrow> continuous F (\<lambda>x. fst (f x))"
  unfolding continuous_def by (rule tendsto_fst)

lemma continuous_snd[continuous_intros]: "continuous F f \<Longrightarrow> continuous F (\<lambda>x. snd (f x))"
  unfolding continuous_def by (rule tendsto_snd)

lemma continuous_Pair[continuous_intros]: "continuous F f \<Longrightarrow> continuous F g \<Longrightarrow> continuous F (\<lambda>x. (f x, g x))"
  unfolding continuous_def by (rule tendsto_Pair)

lemma continuous_on_fst[continuous_intros]: "continuous_on s f \<Longrightarrow> continuous_on s (\<lambda>x. fst (f x))"
  unfolding continuous_on_def by (auto intro: tendsto_fst)

lemma continuous_on_snd[continuous_intros]: "continuous_on s f \<Longrightarrow> continuous_on s (\<lambda>x. snd (f x))"
  unfolding continuous_on_def by (auto intro: tendsto_snd)

lemma continuous_on_Pair[continuous_intros]: "continuous_on s f \<Longrightarrow> continuous_on s g \<Longrightarrow> continuous_on s (\<lambda>x. (f x, g x))"
  unfolding continuous_on_def by (auto intro: tendsto_Pair)

lemma isCont_fst [simp]: "isCont f a \<Longrightarrow> isCont (\<lambda>x. fst (f x)) a"
  by (fact continuous_fst)

lemma isCont_snd [simp]: "isCont f a \<Longrightarrow> isCont (\<lambda>x. snd (f x)) a"
  by (fact continuous_snd)

lemma isCont_Pair [simp]: "\<lbrakk>isCont f a; isCont g a\<rbrakk> \<Longrightarrow> isCont (\<lambda>x. (f x, g x)) a"
  by (fact continuous_Pair)

subsubsection {* Separation axioms *}

lemma mem_Times_iff: "x \<in> A \<times> B \<longleftrightarrow> fst x \<in> A \<and> snd x \<in> B"
  by (induct x) simp (* TODO: move elsewhere *)

instance prod :: (t0_space, t0_space) t0_space
proof
  fix x y :: "'a \<times> 'b" assume "x \<noteq> y"
  hence "fst x \<noteq> fst y \<or> snd x \<noteq> snd y"
    by (simp add: prod_eq_iff)
  thus "\<exists>U. open U \<and> (x \<in> U) \<noteq> (y \<in> U)"
    by (fast dest: t0_space elim: open_vimage_fst open_vimage_snd)
qed

instance prod :: (t1_space, t1_space) t1_space
proof
  fix x y :: "'a \<times> 'b" assume "x \<noteq> y"
  hence "fst x \<noteq> fst y \<or> snd x \<noteq> snd y"
    by (simp add: prod_eq_iff)
  thus "\<exists>U. open U \<and> x \<in> U \<and> y \<notin> U"
    by (fast dest: t1_space elim: open_vimage_fst open_vimage_snd)
qed

instance prod :: (t2_space, t2_space) t2_space
proof
  fix x y :: "'a \<times> 'b" assume "x \<noteq> y"
  hence "fst x \<noteq> fst y \<or> snd x \<noteq> snd y"
    by (simp add: prod_eq_iff)
  thus "\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
    by (fast dest: hausdorff elim: open_vimage_fst open_vimage_snd)
qed

subsection {* Product is a metric space *}

instantiation prod :: (metric_space, metric_space) metric_space
begin

definition dist_prod_def[code del]:
  "dist x y = sqrt ((dist (fst x) (fst y))\<^sup>2 + (dist (snd x) (snd y))\<^sup>2)"

lemma dist_Pair_Pair: "dist (a, b) (c, d) = sqrt ((dist a c)\<^sup>2 + (dist b d)\<^sup>2)"
  unfolding dist_prod_def by simp

lemma dist_fst_le: "dist (fst x) (fst y) \<le> dist x y"
  unfolding dist_prod_def by (rule real_sqrt_sum_squares_ge1)

lemma dist_snd_le: "dist (snd x) (snd y) \<le> dist x y"
  unfolding dist_prod_def by (rule real_sqrt_sum_squares_ge2)

instance proof
  fix x y :: "'a \<times> 'b"
  show "dist x y = 0 \<longleftrightarrow> x = y"
    unfolding dist_prod_def prod_eq_iff by simp
next
  fix x y z :: "'a \<times> 'b"
  show "dist x y \<le> dist x z + dist y z"
    unfolding dist_prod_def
    by (intro order_trans [OF _ real_sqrt_sum_squares_triangle_ineq]
        real_sqrt_le_mono add_mono power_mono dist_triangle2 zero_le_dist)
next
  fix S :: "('a \<times> 'b) set"
  show "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"
  proof
    assume "open S" show "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S"
    proof
      fix x assume "x \<in> S"
      obtain A B where "open A" "open B" "x \<in> A \<times> B" "A \<times> B \<subseteq> S"
        using `open S` and `x \<in> S` by (rule open_prod_elim)
      obtain r where r: "0 < r" "\<forall>y. dist y (fst x) < r \<longrightarrow> y \<in> A"
        using `open A` and `x \<in> A \<times> B` unfolding open_dist by auto
      obtain s where s: "0 < s" "\<forall>y. dist y (snd x) < s \<longrightarrow> y \<in> B"
        using `open B` and `x \<in> A \<times> B` unfolding open_dist by auto
      let ?e = "min r s"
      have "0 < ?e \<and> (\<forall>y. dist y x < ?e \<longrightarrow> y \<in> S)"
      proof (intro allI impI conjI)
        show "0 < min r s" by (simp add: r(1) s(1))
      next
        fix y assume "dist y x < min r s"
        hence "dist y x < r" and "dist y x < s"
          by simp_all
        hence "dist (fst y) (fst x) < r" and "dist (snd y) (snd x) < s"
          by (auto intro: le_less_trans dist_fst_le dist_snd_le)
        hence "fst y \<in> A" and "snd y \<in> B"
          by (simp_all add: r(2) s(2))
        hence "y \<in> A \<times> B" by (induct y, simp)
        with `A \<times> B \<subseteq> S` show "y \<in> S" ..
      qed
      thus "\<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S" ..
    qed
  next
    assume *: "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S" show "open S"
    proof (rule open_prod_intro)
      fix x assume "x \<in> S"
      then obtain e where "0 < e" and S: "\<forall>y. dist y x < e \<longrightarrow> y \<in> S"
        using * by fast
      def r \<equiv> "e / sqrt 2" and s \<equiv> "e / sqrt 2"
      from `0 < e` have "0 < r" and "0 < s"
        unfolding r_def s_def by simp_all
      from `0 < e` have "e = sqrt (r\<^sup>2 + s\<^sup>2)"
        unfolding r_def s_def by (simp add: power_divide)
      def A \<equiv> "{y. dist (fst x) y < r}" and B \<equiv> "{y. dist (snd x) y < s}"
      have "open A" and "open B"
        unfolding A_def B_def by (simp_all add: open_ball)
      moreover have "x \<in> A \<times> B"
        unfolding A_def B_def mem_Times_iff
        using `0 < r` and `0 < s` by simp
      moreover have "A \<times> B \<subseteq> S"
      proof (clarify)
        fix a b assume "a \<in> A" and "b \<in> B"
        hence "dist a (fst x) < r" and "dist b (snd x) < s"
          unfolding A_def B_def by (simp_all add: dist_commute)
        hence "dist (a, b) x < e"
          unfolding dist_prod_def `e = sqrt (r\<^sup>2 + s\<^sup>2)`
          by (simp add: add_strict_mono power_strict_mono)
        thus "(a, b) \<in> S"
          by (simp add: S)
      qed
      ultimately show "\<exists>A B. open A \<and> open B \<and> x \<in> A \<times> B \<and> A \<times> B \<subseteq> S" by fast
    qed
  qed
qed

end

declare [[code abort: "dist::('a::metric_space*'b::metric_space)\<Rightarrow>('a*'b) \<Rightarrow> real"]]

lemma Cauchy_fst: "Cauchy X \<Longrightarrow> Cauchy (\<lambda>n. fst (X n))"
  unfolding Cauchy_def by (fast elim: le_less_trans [OF dist_fst_le])

lemma Cauchy_snd: "Cauchy X \<Longrightarrow> Cauchy (\<lambda>n. snd (X n))"
  unfolding Cauchy_def by (fast elim: le_less_trans [OF dist_snd_le])

lemma Cauchy_Pair:
  assumes "Cauchy X" and "Cauchy Y"
  shows "Cauchy (\<lambda>n. (X n, Y n))"
proof (rule metric_CauchyI)
  fix r :: real assume "0 < r"
  hence "0 < r / sqrt 2" (is "0 < ?s") by simp
  obtain M where M: "\<forall>m\<ge>M. \<forall>n\<ge>M. dist (X m) (X n) < ?s"
    using metric_CauchyD [OF `Cauchy X` `0 < ?s`] ..
  obtain N where N: "\<forall>m\<ge>N. \<forall>n\<ge>N. dist (Y m) (Y n) < ?s"
    using metric_CauchyD [OF `Cauchy Y` `0 < ?s`] ..
  have "\<forall>m\<ge>max M N. \<forall>n\<ge>max M N. dist (X m, Y m) (X n, Y n) < r"
    using M N by (simp add: real_sqrt_sum_squares_less dist_Pair_Pair)
  then show "\<exists>n0. \<forall>m\<ge>n0. \<forall>n\<ge>n0. dist (X m, Y m) (X n, Y n) < r" ..
qed

subsection {* Product is a complete metric space *}

instance prod :: (complete_space, complete_space) complete_space
proof
  fix X :: "nat \<Rightarrow> 'a \<times> 'b" assume "Cauchy X"
  have 1: "(\<lambda>n. fst (X n)) ----> lim (\<lambda>n. fst (X n))"
    using Cauchy_fst [OF `Cauchy X`]
    by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
  have 2: "(\<lambda>n. snd (X n)) ----> lim (\<lambda>n. snd (X n))"
    using Cauchy_snd [OF `Cauchy X`]
    by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
  have "X ----> (lim (\<lambda>n. fst (X n)), lim (\<lambda>n. snd (X n)))"
    using tendsto_Pair [OF 1 2] by simp
  then show "convergent X"
    by (rule convergentI)
qed

subsection {* Product is a normed vector space *}

instantiation prod :: (real_normed_vector, real_normed_vector) real_normed_vector
begin

definition norm_prod_def[code del]:
  "norm x = sqrt ((norm (fst x))\<^sup>2 + (norm (snd x))\<^sup>2)"

definition sgn_prod_def:
  "sgn (x::'a \<times> 'b) = scaleR (inverse (norm x)) x"

lemma norm_Pair: "norm (a, b) = sqrt ((norm a)\<^sup>2 + (norm b)\<^sup>2)"
  unfolding norm_prod_def by simp

instance proof
  fix r :: real and x y :: "'a \<times> 'b"
  show "norm x = 0 \<longleftrightarrow> x = 0"
    unfolding norm_prod_def
    by (simp add: prod_eq_iff)
  show "norm (x + y) \<le> norm x + norm y"
    unfolding norm_prod_def
    apply (rule order_trans [OF _ real_sqrt_sum_squares_triangle_ineq])
    apply (simp add: add_mono power_mono norm_triangle_ineq)
    done
  show "norm (scaleR r x) = \<bar>r\<bar> * norm x"
    unfolding norm_prod_def
    apply (simp add: power_mult_distrib)
    apply (simp add: distrib_left [symmetric])
    apply (simp add: real_sqrt_mult_distrib)
    done
  show "sgn x = scaleR (inverse (norm x)) x"
    by (rule sgn_prod_def)
  show "dist x y = norm (x - y)"
    unfolding dist_prod_def norm_prod_def
    by (simp add: dist_norm)
qed

end

declare [[code abort: "norm::('a::real_normed_vector*'b::real_normed_vector) \<Rightarrow> real"]]

instance prod :: (banach, banach) banach ..

subsubsection {* Pair operations are linear *}

lemma bounded_linear_fst: "bounded_linear fst"
  using fst_add fst_scaleR
  by (rule bounded_linear_intro [where K=1], simp add: norm_prod_def)

lemma bounded_linear_snd: "bounded_linear snd"
  using snd_add snd_scaleR
  by (rule bounded_linear_intro [where K=1], simp add: norm_prod_def)

text {* TODO: move to NthRoot *}
lemma sqrt_add_le_add_sqrt:
  assumes x: "0 \<le> x" and y: "0 \<le> y"
  shows "sqrt (x + y) \<le> sqrt x + sqrt y"
apply (rule power2_le_imp_le)
apply (simp add: power2_sum x y)
apply (simp add: x y)
done

lemma bounded_linear_Pair:
  assumes f: "bounded_linear f"
  assumes g: "bounded_linear g"
  shows "bounded_linear (\<lambda>x. (f x, g x))"
proof
  interpret f: bounded_linear f by fact
  interpret g: bounded_linear g by fact
  fix x y and r :: real
  show "(f (x + y), g (x + y)) = (f x, g x) + (f y, g y)"
    by (simp add: f.add g.add)
  show "(f (r *\<^sub>R x), g (r *\<^sub>R x)) = r *\<^sub>R (f x, g x)"
    by (simp add: f.scaleR g.scaleR)
  obtain Kf where "0 < Kf" and norm_f: "\<And>x. norm (f x) \<le> norm x * Kf"
    using f.pos_bounded by fast
  obtain Kg where "0 < Kg" and norm_g: "\<And>x. norm (g x) \<le> norm x * Kg"
    using g.pos_bounded by fast
  have "\<forall>x. norm (f x, g x) \<le> norm x * (Kf + Kg)"
    apply (rule allI)
    apply (simp add: norm_Pair)
    apply (rule order_trans [OF sqrt_add_le_add_sqrt], simp, simp)
    apply (simp add: distrib_left)
    apply (rule add_mono [OF norm_f norm_g])
    done
  then show "\<exists>K. \<forall>x. norm (f x, g x) \<le> norm x * K" ..
qed

subsubsection {* Frechet derivatives involving pairs *}

lemma has_derivative_Pair [derivative_intros]:
  assumes f: "(f has_derivative f') (at x within s)" and g: "(g has_derivative g') (at x within s)"
  shows "((\<lambda>x. (f x, g x)) has_derivative (\<lambda>h. (f' h, g' h))) (at x within s)"
proof (rule has_derivativeI_sandwich[of 1])
  show "bounded_linear (\<lambda>h. (f' h, g' h))"
    using f g by (intro bounded_linear_Pair has_derivative_bounded_linear)
  let ?Rf = "\<lambda>y. f y - f x - f' (y - x)"
  let ?Rg = "\<lambda>y. g y - g x - g' (y - x)"
  let ?R = "\<lambda>y. ((f y, g y) - (f x, g x) - (f' (y - x), g' (y - x)))"

  show "((\<lambda>y. norm (?Rf y) / norm (y - x) + norm (?Rg y) / norm (y - x)) ---> 0) (at x within s)"
    using f g by (intro tendsto_add_zero) (auto simp: has_derivative_iff_norm)

  fix y :: 'a assume "y \<noteq> x"
  show "norm (?R y) / norm (y - x) \<le> norm (?Rf y) / norm (y - x) + norm (?Rg y) / norm (y - x)"
    unfolding add_divide_distrib [symmetric]
    by (simp add: norm_Pair divide_right_mono order_trans [OF sqrt_add_le_add_sqrt])
qed simp

lemmas has_derivative_fst [derivative_intros] = bounded_linear.has_derivative [OF bounded_linear_fst]
lemmas has_derivative_snd [derivative_intros] = bounded_linear.has_derivative [OF bounded_linear_snd]

lemma has_derivative_split [derivative_intros]:
  "((\<lambda>p. f (fst p) (snd p)) has_derivative f') F \<Longrightarrow> ((\<lambda>(a, b). f a b) has_derivative f') F"
  unfolding split_beta' .

subsection {* Product is an inner product space *}

instantiation prod :: (real_inner, real_inner) real_inner
begin

definition inner_prod_def:
  "inner x y = inner (fst x) (fst y) + inner (snd x) (snd y)"

lemma inner_Pair [simp]: "inner (a, b) (c, d) = inner a c + inner b d"
  unfolding inner_prod_def by simp

instance proof
  fix r :: real
  fix x y z :: "'a::real_inner \<times> 'b::real_inner"
  show "inner x y = inner y x"
    unfolding inner_prod_def
    by (simp add: inner_commute)
  show "inner (x + y) z = inner x z + inner y z"
    unfolding inner_prod_def
    by (simp add: inner_add_left)
  show "inner (scaleR r x) y = r * inner x y"
    unfolding inner_prod_def
    by (simp add: distrib_left)
  show "0 \<le> inner x x"
    unfolding inner_prod_def
    by (intro add_nonneg_nonneg inner_ge_zero)
  show "inner x x = 0 \<longleftrightarrow> x = 0"
    unfolding inner_prod_def prod_eq_iff
    by (simp add: add_nonneg_eq_0_iff)
  show "norm x = sqrt (inner x x)"
    unfolding norm_prod_def inner_prod_def
    by (simp add: power2_norm_eq_inner)
qed

end

end


subsection \<open>Variable Assignments\<close>

text \<open>The following theory defines manipulations of variable assignments and proves elementary facts about
      these. Such preliminary results will later be necesary to e.g. prove that conjunction is
      diophantine.\<close>

theory Assignments
  imports Parametric_Polynomials
begin

definition shift :: "nat list \<Rightarrow> nat \<Rightarrow> assignment" where
  "shift l a \<equiv> \<lambda>i. l ! (i + a)"

definition push :: "assignment \<Rightarrow> nat \<Rightarrow> assignment" where
  "push a n i = (if i = 0 then n else a (i-1))"

definition push_list :: "assignment \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat" where
  "push_list a ns i = (if i < length ns then (ns!i) else a (i - length ns))"

lemma push0: "push a n 0 = n"
  by (auto simp: push_def)

lemma push_list_empty: "push_list a [] = a"
  unfolding push_list_def by auto

lemma push_list_singleton: "push_list a [n] = push a n"
  unfolding push_list_def push_def by auto

lemma push_list_eval: "i < length ns \<Longrightarrow> push_list a ns i = ns!i"
  unfolding push_list_def by auto

lemma push_list1: "push (push_list a ns) n = push_list a (n # ns)"
  unfolding push_def push_list_def by fastforce

lemma push_list2_aux: "(push_list (push a n) ns) i = push_list a (ns @ [n]) i"
  unfolding push_def push_list_def by (auto simp: nth_append)

lemma push_list2: "(push_list (push a n) ns) = push_list a (ns @ [n])"
  unfolding push_list2_aux by auto

fun pull_param :: "ppolynomial \<Rightarrow> ppolynomial \<Rightarrow> ppolynomial" where
  "pull_param (ppolynomial.Param 0) repl    = repl" |
  "pull_param (ppolynomial.Param (Suc n)) _ = (ppolynomial.Param n)" |
  "pull_param (D1 \<^bold>+ D2) repl  = (pull_param D1 repl) \<^bold>+ (pull_param D2 repl)" |
  "pull_param (D1 \<^bold>- D2) repl  = (pull_param D1 repl) \<^bold>- (pull_param D2 repl)" |
  "pull_param (D1 \<^bold>* D2) repl  = (pull_param D1 repl) \<^bold>* (pull_param D2 repl)" |
  "pull_param P repl = P"

(* FROM PREVIOUS FILE *)

fun var_set :: "ppolynomial \<Rightarrow> nat set" where
  "var_set (ppolynomial.Const c)   = {}" |
  "var_set (ppolynomial.Param x)   = {}" |
  "var_set (ppolynomial.Var x)     = {x}" |
  "var_set (D1 \<^bold>+ D2) = var_set D1 \<union> var_set D2" |
  "var_set (D1 \<^bold>- D2) = var_set D1 \<union> var_set D2" |
  "var_set (D1 \<^bold>* D2) = var_set D1 \<union> var_set D2"

definition disjoint_var :: "ppolynomial \<Rightarrow> ppolynomial \<Rightarrow> bool" where
  "disjoint_var P Q = (var_set P \<inter> var_set Q = {})"

named_theorems disjoint_vars

lemma disjoint_var_sym: "disjoint_var P Q = disjoint_var Q P"
  unfolding disjoint_var_def by auto

lemma disjoint_var_sum[disjoint_vars]: "disjoint_var (P1 \<^bold>+ P2) Q = (disjoint_var P1 Q \<and> disjoint_var P2 Q)"
  unfolding disjoint_var_def by auto

lemma disjoint_var_diff[disjoint_vars]: "disjoint_var (P1 \<^bold>- P2) Q = (disjoint_var P1 Q \<and> disjoint_var P2 Q)"
  unfolding disjoint_var_def by auto

lemma disjoint_var_prod[disjoint_vars]: "disjoint_var (P1 \<^bold>* P2) Q = (disjoint_var P1 Q \<and> disjoint_var P2 Q)"
   unfolding disjoint_var_def by auto

lemma aux_var_set:
  assumes "\<forall>i \<in> var_set P. x i = y i"
  shows "ppeval P a x = ppeval P a y"
  using assms by (induction P, auto)

text \<open>First prove that disjoint variable sets allow the unification into one variable assignment\<close>
definition zip_assignments :: "ppolynomial \<Rightarrow> ppolynomial \<Rightarrow> assignment \<Rightarrow> assignment \<Rightarrow> assignment"
  where "zip_assignments P Q v w i = (if i \<in> var_set P then v i else w i)"

lemma help_eval_zip_assignments1:
  shows "ppeval P1 a (\<lambda>i. if i \<in> var_set P1 \<union> var_set P2 then v i else w i)
       = ppeval P1 a (\<lambda>i. if i \<in> var_set P1 then v i else w i)"
  using aux_var_set by auto

lemma help_eval_zip_assignments2:
  shows "ppeval P2 a (\<lambda>i. if i \<in> var_set P1 \<union> var_set P2 then v i else w i)
       = ppeval P2 a (\<lambda>i. if i \<in> var_set P2 then v i else w i)"
  using aux_var_set by auto

lemma eval_zip_assignments1:
  fixes v w
  assumes "disjoint_var P Q"
  defines "x \<equiv> zip_assignments P Q v w"
  shows "ppeval P a v = ppeval P a x"
  using assms
  apply (induction P arbitrary: x)
  unfolding x_def zip_assignments_def
  using help_eval_zip_assignments1 help_eval_zip_assignments2
  by (auto simp add: disjoint_vars)

lemma eval_zip_assignments2:
  fixes v w
  assumes "disjoint_var P Q"
  defines "x \<equiv> zip_assignments P Q v w"
  shows "ppeval Q a w = ppeval Q a x"
  using assms
  apply (induction Q arbitrary: P x)
  unfolding x_def zip_assignments_def
  using disjoint_var_sym disjoint_vars
  by (auto simp: disjoint_var_def) (smt (z3) inf_commute)+

lemma zip_assignments_correct:
  assumes "ppeval P1 a v = ppeval P2 a v" and "ppeval Q1 a w = ppeval Q2 a w"
      and "disjoint_var (P1 \<^bold>+ P2) (Q1 \<^bold>+ Q2)"
  defines "x \<equiv> zip_assignments (P1 \<^bold>+ P2) (Q1 \<^bold>+ Q2) v w"
  shows "ppeval P1 a x = ppeval P2 a x" and "ppeval Q1 a x = ppeval Q2 a x"
proof -
  from assms(3) have "disjoint_var P1 (Q1 \<^bold>+ Q2)"
    by (auto simp: disjoint_var_sum)
  moreover have "ppeval P1 a x = ppeval P1 a (zip_assignments P1 (Q1 \<^bold>+ Q2) v w)"
    unfolding x_def zip_assignments_def using help_eval_zip_assignments1 by auto
  ultimately have p1: "ppeval P1 a x = ppeval P1 a v"
    using eval_zip_assignments1[of "P1"] by auto

  from assms(3) have "disjoint_var P2 (Q1 \<^bold>+ Q2)"
    by (auto simp: disjoint_var_sum)
  moreover have "ppeval P2 a x = ppeval P2 a (zip_assignments P2 (Q1 \<^bold>+ Q2) v w)"
    unfolding x_def zip_assignments_def using help_eval_zip_assignments2 by auto
  ultimately have p2: "ppeval P2 a x = ppeval P2 a v"
    using eval_zip_assignments1[of "P2"] by auto

  from p1 p2 show "ppeval P1 a x = ppeval P2 a x"
    using assms(1) by auto
next
  have "disjoint_var (P1 \<^bold>+ P2) Q1"
    using assms(3) disjoint_var_sum disjoint_var_sym by auto
  moreover have "ppeval Q1 a x = ppeval Q1 a (zip_assignments (P1 \<^bold>+ P2) Q1 v w)"
    unfolding x_def zip_assignments_def using help_eval_zip_assignments1 by auto
  ultimately have q1: "ppeval Q1 a x = ppeval Q1 a w"
    using eval_zip_assignments2[of _ "Q1"] by auto

  from assms(3) have "disjoint_var (P1 \<^bold>+ P2) Q2"
    using assms(3) disjoint_var_sum disjoint_var_sym by auto
  moreover have "ppeval Q2 a x = ppeval Q2 a (zip_assignments (P1 \<^bold>+ P2) Q2 v w)"
    unfolding x_def zip_assignments_def using help_eval_zip_assignments2 by auto
  ultimately have q2: "ppeval Q2 a x = ppeval Q2 a w"
    using eval_zip_assignments2[of _ "Q2"] by auto

  from q1 q2 show "ppeval Q1 a x = ppeval Q2 a x"
    using assms(2) by auto
qed

lemma disjoint_var_unifies:
  assumes "\<exists>v1. ppeval P1 a v1 = ppeval P2 a v1" and "\<exists>v2. ppeval Q1 a v2 = ppeval Q2 a v2"
      and "disjoint_var (P1 \<^bold>+ P2) (Q1 \<^bold>+ Q2)"
    shows "\<exists>v. ppeval P1 a v = ppeval P2 a v \<and> ppeval Q1 a v = ppeval Q2 a v"
  using assms zip_assignments_correct by (auto) metis

(* Next prove that one can always find a polynomial with disjoint variables given some other polys*)
text \<open>A function to manipulate variables in ppolynomials\<close>
fun push_var :: "ppolynomial \<Rightarrow> nat \<Rightarrow> ppolynomial" where
  "push_var (ppolynomial.Var x)     n = ppolynomial.Var (x + n)" |
  "push_var (D1 \<^bold>+ D2) n = push_var D1 n \<^bold>+ push_var D2 n" |
  "push_var (D1 \<^bold>- D2) n = push_var D1 n \<^bold>- push_var D2 n" |
  "push_var (D1 \<^bold>* D2) n = push_var D1 n \<^bold>* push_var D2 n" |
  "push_var D n = D"

lemma push_var_bound: "x \<in> var_set (push_var P (Suc n)) \<Longrightarrow> x > n"
  by (induction P, auto)

definition pull_assignment :: "assignment \<Rightarrow> nat \<Rightarrow> assignment" where
  "pull_assignment v n = (\<lambda>x. v (x+n))"

lemma push_var_pull_assignment:
  shows "ppeval (push_var P n) a v = ppeval P a (pull_assignment v n)"
  by (induction P, auto simp: pull_assignment_def)

lemma max_set: "finite A \<Longrightarrow> \<forall>x\<in>A. x \<le> Max A"
  using Max_ge by blast

(* FROM PREVIOUS FILE SIMPLEDIOPHANTINE_NAT *)

fun push_param :: "polynomial \<Rightarrow> nat \<Rightarrow> polynomial" where
  "push_param (Const c)   n = Const c" |
  "push_param (Param x)   n = Param (x + n)" |
  "push_param (Sum D1 D2) n = Sum (push_param D1 n) (push_param D2 n)" |
  "push_param (NatDiff D1 D2) n = NatDiff (push_param D1 n) (push_param D2 n)" |
  "push_param (Prod D1 D2) n = Prod (push_param D1 n) (push_param D2 n)"

definition push_param_list :: "polynomial list \<Rightarrow> nat \<Rightarrow> polynomial list" where
  "push_param_list s k \<equiv> map (\<lambda>x. push_param x k) s"

lemma push_param0: "push_param P 0 = P"
  by (induction P, auto)

lemma push_push_aux: "peval (push_param P (Suc m)) (push a n) = peval (push_param P m) a"
  by (induction P, auto simp: push_def)

lemma push_push:
  shows "length ns = n \<Longrightarrow> peval (push_param P n) (push_list a ns) = peval P a"
proof (induction ns arbitrary: n)
  case Nil
  then show ?case by (auto simp: push_list_empty push_param0)
next
  case (Cons n ns)
  thus ?case
    using push_push_aux[where ?a = "push_list a ns"]
    by (auto simp add: length_Cons push_list1)
qed

lemma push_push_simp:
  shows "peval (push_param P (length ns)) (push_list a ns) = peval P a"
proof (induction ns)
  case Nil
  then show ?case by (auto simp: push_list_empty push_param0)
next
  case (Cons n ns)
  thus ?case
    using push_push_aux[where ?a = "push_list a ns"]
    by (auto simp add: length_Cons push_list1)
qed

lemma push_push1: "peval (push_param P 1) (push a k) = peval P a"
  using push_push[where ?ns = "[k]"] by (auto simp: push_list_singleton)

lemma push_push_map: "length ns = n \<Longrightarrow>
  list_eval (map (\<lambda>x. push_param x n) ls) (push_list a ns) = list_eval ls a"
  unfolding list_eval_def apply (induction ls, simp)
  apply (induction ns, auto)
  apply (metis length_map list.size(3) nth_equalityI push_push)
  by (metis length_Cons length_map map_nth push_push)

lemma push_push_map_i: "length ns = n \<Longrightarrow> i < length ls \<Longrightarrow>
  peval (map (\<lambda>x. push_param x n) ls ! i) (push_list a ns) = list_eval ls a i"
  unfolding list_eval_def by (auto simp: push_push_map push_push)

lemma push_push_map1: "i < length ls \<Longrightarrow>
  peval (map (\<lambda>x. push_param x 1) ls ! i) (push a n) = list_eval ls a i"
  unfolding list_eval_def using push_push1 by (auto)

end