section \<open>Monomial Modules\<close>

theory Monomial_Module
  imports Groebner_Bases.Reduced_GB
begin

text \<open>Properties of modules generated by sets of monomials, and (reduced) Gr\"obner bases thereof.\<close>

subsection \<open>Sets of Monomials\<close>

definition is_monomial_set :: "('a \<Rightarrow>\<^sub>0 'b::zero) set \<Rightarrow> bool"
  where "is_monomial_set A \<longleftrightarrow> (\<forall>p\<in>A. is_monomial p)"

lemma is_monomial_setI: "(\<And>p. p \<in> A \<Longrightarrow> is_monomial p) \<Longrightarrow> is_monomial_set A"
  by (simp add: is_monomial_set_def)

lemma is_monomial_setD: "is_monomial_set A \<Longrightarrow> p \<in> A \<Longrightarrow> is_monomial p"
  by (simp add: is_monomial_set_def)

lemma is_monomial_set_subset: "is_monomial_set B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> is_monomial_set A"
  by (auto simp: is_monomial_set_def)

lemma is_monomial_set_Un: "is_monomial_set (A \<union> B) \<longleftrightarrow> (is_monomial_set A \<and> is_monomial_set B)"
  by (auto simp: is_monomial_set_def)

subsection \<open>Modules\<close>

context term_powerprod
begin

lemma monomial_pmdl:
  assumes "is_monomial_set B" and "p \<in> pmdl B"
  shows "monomial (lookup p v) v \<in> pmdl B"
  using assms(2)
proof (induct p rule: pmdl_induct)
  case base: module_0
  show ?case by (simp add: pmdl.span_zero)
next
  case step: (module_plus p b c t)
  have eq: "monomial (lookup (p + monom_mult c t b) v) v =
            monomial (lookup p v) v + monomial (lookup (monom_mult c t b) v) v"
    by (simp only: single_add lookup_add)
  from assms(1) step.hyps(3) have "is_monomial b" by (rule is_monomial_setD)
  then obtain d u where b: "b = monomial d u" by (rule is_monomial_monomial)
  have "monomial (lookup (monom_mult c t b) v) v \<in> pmdl B"
  proof (simp add: b monom_mult_monomial lookup_single when_def pmdl.span_zero, intro impI)
    assume "t \<oplus> u = v"
    hence "monomial (c * d) v = monom_mult c t b" by (simp add: b monom_mult_monomial)
    also from step.hyps(3) have "\<dots> \<in> pmdl B" by (rule monom_mult_in_pmdl)
    finally show "monomial (c * d) v \<in> pmdl B" .
  qed
  with step.hyps(2) show ?case unfolding eq by (rule pmdl.span_add)
qed

lemma monomial_pmdl_field:
  assumes "is_monomial_set B" and "p \<in> pmdl B" and "v \<in> keys (p::_ \<Rightarrow>\<^sub>0 'b::field)"
  shows "monomial c v \<in> pmdl B"
proof -
  from assms(1, 2) have "monomial (lookup p v) v \<in> pmdl B" by (rule monomial_pmdl)
  hence "monom_mult (c / lookup p v) 0 (monomial (lookup p v) v) \<in> pmdl B"
    by (rule pmdl_closed_monom_mult)
  with assms(3) show ?thesis by (simp add: monom_mult_monomial splus_zero in_keys_iff)
qed

end (* term_powerprod *)

context ordered_term
begin

lemma keys_monomial_pmdl:
  assumes "is_monomial_set F" and "p \<in> pmdl F" and "t \<in> keys p"
  obtains f where "f \<in> F" and "f \<noteq> 0" and "lt f adds\<^sub>t t"
  using assms(2) assms(3)
proof (induct arbitrary: thesis rule: pmdl_induct)
  case module_0
  from this(2) show ?case by simp
next
  case step: (module_plus p f0 c s)
  from assms(1) step(3) have "is_monomial f0" unfolding is_monomial_set_def ..
  hence "keys f0 = {lt f0}" and "f0 \<noteq> 0" by (rule keys_monomial, rule monomial_not_0)
  from Poly_Mapping.keys_add step(6) have "t \<in> keys p \<union> keys (monom_mult c s f0)" ..
  thus ?case
  proof
    assume "t \<in> keys p"
    from step(2)[OF _ this] obtain f where "f \<in> F" and "f \<noteq> 0" and "lt f adds\<^sub>t t" by blast
    thus ?thesis by (rule step(5))
  next
    assume "t \<in> keys (monom_mult c s f0)"
    with keys_monom_mult_subset have "t \<in> (\<oplus>) s ` keys f0" ..
    hence "t = s \<oplus> lt f0" by (simp add: \<open>keys f0 = {lt f0}\<close>)
    hence "lt f0 adds\<^sub>t t" by (simp add: term_simps)
    with \<open>f0 \<in> F\<close> \<open>f0 \<noteq> 0\<close> show ?thesis by (rule step(5))
  qed
qed

lemma image_lt_monomial_lt: "lt ` monomial (1::'b::zero_neq_one) ` lt ` F = lt ` F"
  by (auto simp: lt_monomial intro!: image_eqI)

subsection \<open>Reduction\<close>

lemma red_setE2:
  assumes "red B p q"
  obtains b where "b \<in> B" and "b \<noteq> 0" and "red {b} p q"
proof -
  from assms obtain b t where "b \<in> B" and "red_single p q b t" by (rule red_setE)
  from this(2) have "b \<noteq> 0" by (simp add: red_single_def)
  have "red {b} p q" by (rule red_setI, simp, fact)
  show ?thesis by (rule, fact+)
qed

lemma red_monomial_keys:
  assumes "is_monomial r" and "red {r} p q"
  shows "card (keys p) = Suc (card (keys q))"
proof -
  from assms(2) obtain s where rs: "red_single p q r s" unfolding red_singleton ..
  hence cp0: "lookup p (s \<oplus> lt r) \<noteq> 0" and q_def0: "q = p - monom_mult (lookup p (s \<oplus> lt r) / lc r) s r"
    unfolding red_single_def by simp_all
  from assms(1) obtain c t where "c \<noteq> 0" and r_def: "r = monomial c t" by (rule is_monomial_monomial)
  have ltr: "lt r = t" unfolding r_def by (rule lt_monomial, fact)
  have lcr: "lc r = c" unfolding r_def by (rule lc_monomial)
  define u where "u = s \<oplus> t"
  from q_def0 have "q = p - monom_mult (lookup p u / c) s r" unfolding u_def ltr lcr .
  also have "... = p - monomial ((lookup p u / c) * c) u" unfolding u_def r_def monom_mult_monomial ..
  finally have q_def: "q = p - monomial (lookup p u) u" using \<open>c \<noteq> 0\<close> by simp
  from cp0 have "lookup p u \<noteq> 0" unfolding u_def ltr .
  hence "u \<in> keys p" by (simp add: in_keys_iff)

  have "keys q = keys p - {u}" unfolding q_def
  proof (rule, rule)
    fix x
    assume "x \<in> keys (p - monomial (lookup p u) u)"
    hence "lookup (p - monomial (lookup p u) u) x \<noteq> 0" by (simp add: in_keys_iff)
    hence a: "lookup p x - lookup (monomial (lookup p u) u) x \<noteq> 0" unfolding lookup_minus .
    hence "x \<noteq> u" unfolding lookup_single by auto
    with a have "lookup p x \<noteq> 0" unfolding lookup_single by auto
    show "x \<in> keys p - {u}"
    proof
      from \<open>lookup p x \<noteq> 0\<close> show "x \<in> keys p" by (simp add: in_keys_iff)
    next
      from \<open>x \<noteq> u\<close> show "x \<notin> {u}" by simp
    qed
  next
    show "keys p - {u} \<subseteq> keys (p - monomial (lookup p u) u)"
    proof
      fix x
      assume "x \<in> keys p - {u}"
      hence "x \<in> keys p" and "x \<noteq> u" by auto
      from \<open>x \<in> keys p\<close> have "lookup p x \<noteq> 0" by (simp add: in_keys_iff)
      with \<open>x \<noteq> u\<close> have "lookup (p - monomial (lookup p u) u) x \<noteq> 0" by (simp add: lookup_minus lookup_single)
      thus "x \<in> keys (p - monomial (lookup p u) u)" by (simp add: in_keys_iff)
    qed
  qed

  have "Suc (card (keys q)) = card (keys p)" unfolding \<open>keys q = keys p - {u}\<close>
    by (rule card_Suc_Diff1, rule finite_keys, fact)
  thus ?thesis by simp
qed

lemma red_monomial_monomial_setD:
  assumes "is_monomial p" and "is_monomial_set B" and "red B p q"
  shows "q = 0"
proof -
  from assms(3) obtain b where "b \<in> B" and "b \<noteq> 0" and *: "red {b} p q" by (rule red_setE2)
  from assms(2) this(1) have "is_monomial b" by (rule is_monomial_setD)
  hence "card (keys p) = Suc (card (keys q))" using * by (rule red_monomial_keys)
  with assms(1) show ?thesis by (simp add: is_monomial_def)
qed

corollary is_red_monomial_monomial_setD:
  assumes "is_monomial p" and "is_monomial_set B" and "is_red B p"
  shows "red B p 0"
proof -
  from assms(3) obtain q where "red B p q" by (rule is_redE)
  moreover from assms(1, 2) this have "q = 0" by (rule red_monomial_monomial_setD)
  ultimately show ?thesis by simp
qed

corollary is_red_monomial_monomial_set_in_pmdl:
  "is_monomial p \<Longrightarrow> is_monomial_set B \<Longrightarrow> is_red B p \<Longrightarrow> p \<in> pmdl B"
  by (intro red_rtranclp_0_in_pmdl r_into_rtranclp is_red_monomial_monomial_setD)

corollary red_rtrancl_monomial_monomial_set_cases:
  assumes "is_monomial p" and "is_monomial_set B" and "(red B)\<^sup>*\<^sup>* p q"
  obtains "q = p" | "q = 0"
  using assms(3)
proof (induct q arbitrary: thesis rule: rtranclp_induct)
  case base
  from refl show ?case by (rule base)
next
  case (step y z)
  show ?case
  proof (rule step.hyps)
    assume "y = p"
    with step.hyps(2) have "red B p z" by simp
    with assms(1, 2) have "z = 0" by (rule red_monomial_monomial_setD)
    thus ?thesis by (rule step.prems)
  next
    assume "y = 0"
    from step.hyps(2) have "is_red B 0" unfolding \<open>y = 0\<close> by (rule is_redI)
    with irred_0 show ?thesis ..
  qed
qed

lemma is_red_monomial_lt:
  assumes "0 \<notin> B"
  shows "is_red (monomial (1::'b::field) ` lt ` B) = is_red B"
proof
  fix p
  let ?B = "monomial (1::'b) ` lt ` B"
  show "is_red ?B p \<longleftrightarrow> is_red B p"
  proof
    assume "is_red ?B p"
    then obtain f v where "f \<in> ?B" and "v \<in> keys p" and adds: "lt f adds\<^sub>t v" by (rule is_red_addsE)
    from this(1) have "lt f \<in> lt ` ?B" by (rule imageI)
    also have "\<dots> = lt ` B" by (fact image_lt_monomial_lt)
    finally obtain b where "b \<in> B" and eq: "lt f = lt b" ..
    note this(1)
    moreover from this assms have "b \<noteq> 0" by blast
    moreover note \<open>v \<in> keys p\<close>
    moreover from adds have "lt b adds\<^sub>t v" by (simp only: eq)
    ultimately show "is_red B p" by (rule is_red_addsI)
  next
    assume "is_red B p"
    then obtain b v where "b \<in> B" and "v \<in> keys p" and adds: "lt b adds\<^sub>t v" by (rule is_red_addsE)
    from this(1) have "lt b \<in> lt ` B" by (rule imageI)
    also from image_lt_monomial_lt have "\<dots> = lt ` ?B" by (rule sym)
    finally obtain f where "f \<in> ?B" and eq: "lt b = lt f" ..
    note this(1)
    moreover from this have "f \<noteq> 0" by (auto simp: monomial_0_iff)
    moreover note \<open>v \<in> keys p\<close>
    moreover from adds have "lt f adds\<^sub>t v" by (simp only: eq)
    ultimately show "is_red ?B p" by (rule is_red_addsI)
  qed
qed

end (* ordered_term *)

subsection \<open>Gr\"obner Bases\<close>

context gd_term
begin

lemma monomial_set_is_GB:
  assumes "is_monomial_set G"
  shows "is_Groebner_basis G"
  unfolding GB_alt_1
proof
  fix f
  assume "f \<in> pmdl G"
  thus "(red G)\<^sup>*\<^sup>* f 0"
  proof (induct f rule: poly_mapping_plus_induct)
    case 1
    show ?case ..
  next
    case (2 f c t)
    let ?f = "monomial c t + f"
    from 2(1) have "t \<in> keys (monomial c t)" by simp
    from this 2(2) have "t \<in> keys ?f" by (rule in_keys_plusI1)
    with assms \<open>?f \<in> pmdl G\<close> obtain g where "g \<in> G" and "g \<noteq> 0" and "lt g adds\<^sub>t t"
      by (rule keys_monomial_pmdl)
    from this(1) have "red G ?f f"
    proof (rule red_setI)
      from \<open>lt g adds\<^sub>t t\<close> have "component_of_term (lt g) = component_of_term t" and "lp g adds pp_of_term t"
        by (simp_all add: adds_term_def)
      from this have eq: "(pp_of_term t - lp g) \<oplus> lt g = t"
        by (simp add: adds_minus splus_def term_of_pair_pair)
      moreover from 2(2) have "lookup ?f t = c" by (simp add: lookup_add in_keys_iff)
      ultimately show "red_single (monomial c t + f) f g (pp_of_term t - lp g)"
      proof (simp add: red_single_def \<open>g \<noteq> 0\<close> \<open>t \<in> keys ?f\<close> 2(1))
        from \<open>g \<noteq> 0\<close> have "lc g \<noteq> 0" by (rule lc_not_0)
        hence "monomial c t = monom_mult (c / lc g) (pp_of_term t - lp g) (monomial (lc g) (lt g))"
          by (simp add: monom_mult_monomial eq)
        moreover from assms \<open>g \<in> G\<close> have "is_monomial g" unfolding is_monomial_set_def ..
        ultimately show "monomial c t = monom_mult (c / lc g) (pp_of_term t - lp g) g"
          by (simp only: monomial_eq_itself)
      qed
    qed
    have "f \<in> pmdl G" by (rule pmdl_closed_red, fact subset_refl, fact+)
    hence "(red G)\<^sup>*\<^sup>* f 0" by (rule 2(3))
    with \<open>red G ?f f\<close> show ?case by simp
  qed
qed

context
  fixes d
  assumes dgrad: "dickson_grading (d::'a \<Rightarrow> nat)"
begin

context
  fixes F m
  assumes fin_comps: "finite (component_of_term ` Keys F)"
    and F_sub: "F \<subseteq> dgrad_p_set d m"
    and F_monom: "is_monomial_set (F::(_ \<Rightarrow>\<^sub>0 'b::field) set)"
begin

text \<open>The proof of the following lemma could be simplified, analogous to homogeneous ideals.\<close>

lemma reduced_GB_subset_monic_dgrad_p_set: "reduced_GB F \<subseteq> monic ` F"
proof -
  from subset_refl obtain F' where "F' \<subseteq> F - {0}" and "lt ` (F - {0}) = lt ` F'" and "inj_on lt F'"
    by (rule subset_imageE_inj)
  define G where "G = {f \<in> F'. \<forall>f'\<in>F'. lt f' adds\<^sub>t lt f \<longrightarrow> f' = f}"
  have "G \<subseteq> F'" by (simp add: G_def)
  hence "G \<subseteq> F - {0}" using \<open>F' \<subseteq> F - {0}\<close> by (rule subset_trans)
  also have "\<dots> \<subseteq> F" by blast
  finally have "G \<subseteq> F" .
  have 1: thesis if "f \<in> F" and "f \<noteq> 0" and "\<And>g. g \<in> G \<Longrightarrow> lt g adds\<^sub>t lt f \<Longrightarrow> thesis" for thesis f
  proof -
    let ?K = "component_of_term ` Keys F"
    let ?A = "{t. pp_of_term t \<in> dgrad_set d m \<and> component_of_term t \<in> ?K}"
    let ?Q = "{f' \<in> F'. lt f' adds\<^sub>t lt f}"
    from dgrad fin_comps have "almost_full_on (adds\<^sub>t) ?A" by (rule Dickson_term)
    moreover have "transp_on (adds\<^sub>t) ?A" by (auto intro: transp_onI dest: adds_term_trans)
    ultimately have "wfp_on (strict (adds\<^sub>t)) ?A" by (rule af_trans_imp_wf)
    moreover have "lt f \<in> lt ` ?Q"
    proof -
      from that(1, 2) have "f \<in> F - {0}" by simp
      hence "lt f \<in> lt ` (F - {0})" by (rule imageI)
      also have "\<dots> = lt ` F'" by fact
      finally have "lt f \<in> lt ` F'" .
      with adds_term_refl show ?thesis by fastforce
    qed
    moreover have "lt ` ?Q \<subseteq> ?A"
    proof
      fix s
      assume "s \<in> lt ` ?Q"
      then obtain q where "q \<in> ?Q" and s: "s = lt q" ..
      from this(1) have "q \<in> F'" by simp
      hence "q \<in> F - {0}" using \<open>F' \<subseteq> F - {0}\<close> ..
      hence "q \<in> F" and "q \<noteq> 0" by simp_all
      from this(1) F_sub have "q \<in> dgrad_p_set d m" ..
      from \<open>q \<noteq> 0\<close> have "lt q \<in> keys q" by (rule lt_in_keys)
      hence "pp_of_term (lt q) \<in> pp_of_term ` keys q" by (rule imageI)
      also from \<open>q \<in> dgrad_p_set d m\<close> have "\<dots> \<subseteq> dgrad_set d m" by (simp add: dgrad_p_set_def)
      finally have 1: "pp_of_term s \<in> dgrad_set d m" by (simp only: s)
      from \<open>lt q \<in> keys q\<close> \<open>q \<in> F\<close> have "lt q \<in> Keys F" by (rule in_KeysI)
      hence "component_of_term s \<in> ?K" unfolding s by (rule imageI)
      with 1 show "s \<in> ?A" by simp
    qed
    ultimately obtain t where "t \<in> lt ` ?Q" and t_min: "\<And>s. strict (adds\<^sub>t) s t \<Longrightarrow> s \<notin> lt ` ?Q"
      by (rule wfp_onE_min) blast
    from this(1) obtain g where "g \<in> ?Q" and t: "t = lt g" ..
    from this(1) have "g \<in> F'" and adds: "lt g adds\<^sub>t lt f" by simp_all
    show ?thesis
    proof (rule that)
      {
        fix f'
        assume "f' \<in> F'"
        assume "lt f' adds\<^sub>t lt g"
        hence "lt f' adds\<^sub>t lt f" using adds by (rule adds_term_trans)
        with \<open>f' \<in> F'\<close> have "f' \<in> ?Q" by simp
        hence "lt f' \<in> lt ` ?Q" by (rule imageI)
        with t_min have "\<not> strict (adds\<^sub>t) (lt f') (lt g)" unfolding t by blast
        with \<open>lt f' adds\<^sub>t lt g\<close> have "lt g adds\<^sub>t lt f'" by blast
        with \<open>lt f' adds\<^sub>t lt g\<close> have "lt f' = lt g" by (rule adds_term_antisym)
        with \<open>inj_on lt F'\<close> have "f' = g" using \<open>f' \<in> F'\<close> \<open>g \<in> F'\<close> by (rule inj_onD)
      }
      with \<open>g \<in> F'\<close> show "g \<in> G" by (simp add: G_def)
    qed fact
  qed
  have 2: "is_red G q" if "q \<in> pmdl F" and "q \<noteq> 0" for q
  proof -
    from that(2) have "keys q \<noteq> {}" by simp
    then obtain t where "t \<in> keys q" by blast
    with F_monom that(1) obtain f where "f \<in> F" and "f \<noteq> 0" and *: "lt f adds\<^sub>t t"
      by (rule keys_monomial_pmdl)
    from this(1, 2) obtain g where "g \<in> G" and "lt g adds\<^sub>t lt f" by (rule 1)
    from this(2) have **: "lt g adds\<^sub>t t" using * by (rule adds_term_trans)
    from \<open>g \<in> G\<close> \<open>G \<subseteq> F - {0}\<close> have "g \<in> F - {0}" ..
    hence "g \<noteq> 0" by simp
    with \<open>g \<in> G\<close> show ?thesis using \<open>t \<in> keys q\<close> ** by (rule is_red_addsI)
  qed
  from \<open>G \<subseteq> F - {0}\<close> have "G \<subseteq> F" by blast
  hence "pmdl G \<subseteq> pmdl F" by (rule pmdl.span_mono)
  note dgrad fin_comps F_sub
  moreover have "is_reduced_GB (monic ` G)" unfolding is_reduced_GB_def GB_image_monic
  proof (intro conjI image_monic_is_auto_reduced image_monic_is_monic_set)
    from dgrad show "is_Groebner_basis G"
    proof (rule isGB_I_is_red)
      from \<open>G \<subseteq> F\<close> F_sub show "G \<subseteq> dgrad_p_set d m" by (rule subset_trans)
    next
      fix f
      assume "f \<in> pmdl G"
      hence "f \<in> pmdl F" using \<open>pmdl G \<subseteq> pmdl F\<close> ..
      moreover assume "f \<noteq> 0"
      ultimately show "is_red G f" by (rule 2)
    qed
  next
    show "is_auto_reduced G" unfolding is_auto_reduced_def
    proof (intro ballI notI)
      fix g
      assume "g \<in> G"
      hence "g \<in> F" using \<open>G \<subseteq> F\<close> ..
      with F_monom have "is_monomial g" by (rule is_monomial_setD)
      hence keys_g: "keys g = {lt g}" by (rule keys_monomial)
      assume "is_red (G - {g}) g"
      then obtain g' t where "g' \<in> G - {g}" and "t \<in> keys g" and adds: "lt g' adds\<^sub>t t" by (rule is_red_addsE)
      from this(1) have "g' \<in> F'" and "g' \<noteq> g" by (simp_all add: G_def)
      from \<open>t \<in> keys g\<close> have "t = lt g" by (simp add: keys_g)
      with \<open>g \<in> G\<close> \<open>g' \<in> F'\<close> adds have "g' = g" by (simp add: G_def)
      with \<open>g' \<noteq> g\<close> show False ..
    qed
  next
    show "0 \<notin> monic ` G"
    proof
      assume "0 \<in> monic ` G"
      then obtain g where "0 = monic g" and "g \<in> G" ..
      moreover from this(2) \<open>G \<subseteq> F - {0}\<close> have "g \<noteq> 0" by blast
      ultimately show False by (simp add: monic_0_iff)
    qed
  qed
  moreover have "pmdl (monic ` G) = pmdl F" unfolding pmdl_image_monic
  proof
    show "pmdl F \<subseteq> pmdl G"
    proof (rule pmdl.span_subset_spanI, rule)
      fix f
      assume "f \<in> F"
      hence "f \<in> pmdl F" by (rule pmdl.span_base)
      note dgrad
      moreover from \<open>G \<subseteq> F\<close> F_sub have "G \<subseteq> dgrad_p_set d m" by (rule subset_trans)
      moreover note \<open>pmdl G \<subseteq> pmdl F\<close> 2 \<open>f \<in> pmdl F\<close>
      moreover from \<open>f \<in> F\<close> F_sub have "f \<in> dgrad_p_set d m" ..
      ultimately have "(red G)\<^sup>*\<^sup>* f 0" by (rule is_red_implies_0_red_dgrad_p_set)
      thus "f \<in> pmdl G" by (rule red_rtranclp_0_in_pmdl)
    qed
  qed fact
  ultimately have "reduced_GB F = monic ` G" by (rule reduced_GB_unique_dgrad_p_set)
  also from \<open>G \<subseteq> F\<close> have "\<dots> \<subseteq> monic ` F" by (rule image_mono)
  finally show ?thesis .
qed

corollary reduced_GB_is_monomial_set_dgrad_p_set: "is_monomial_set (reduced_GB F)"
proof (rule is_monomial_setI)
  fix g
  assume "g \<in> reduced_GB F"
  also have "\<dots> \<subseteq> monic ` F" by (fact reduced_GB_subset_monic_dgrad_p_set)
  finally obtain f where "f \<in> F" and g: "g = monic f" ..
  from F_monom this(1) have "is_monomial f" by (rule is_monomial_setD)
  hence "card (keys f) = 1" by (simp only: is_monomial_def)
  hence "f \<noteq> 0" by auto
  hence "lc f \<noteq> 0" by (rule lc_not_0)
  hence "1 / lc f \<noteq> 0" by simp
  hence "keys g = (\<oplus>) 0 ` keys f" by (simp add: keys_monom_mult monic_def g)
  also from refl have "\<dots> = (\<lambda>x. x) ` keys f" by (rule image_cong) (simp only: splus_zero)
  finally show "is_monomial g" using \<open>card (keys f) = 1\<close> by (simp only: is_monomial_def image_ident)
qed

end

lemma is_red_reduced_GB_monomial_dgrad_set:
  assumes "finite (component_of_term ` S)" and "pp_of_term ` S \<subseteq> dgrad_set d m"
  shows "is_red (reduced_GB (monomial 1 ` S)) = is_red (monomial (1::'b::field) ` S)"
proof
  fix p
  let ?F = "monomial (1::'b) ` S"
  from assms(1) have 1: "finite (component_of_term ` Keys ?F)" by (simp add: Keys_def)
  moreover from assms(2) have 2: "?F \<subseteq> dgrad_p_set d m" by (auto simp: dgrad_p_set_def)
  moreover have "is_monomial_set ?F" by (auto intro!: is_monomial_setI monomial_is_monomial)
  ultimately have "reduced_GB ?F \<subseteq> monic ` ?F" by (rule reduced_GB_subset_monic_dgrad_p_set)
  also have "\<dots> = ?F" by (auto simp: monic_def intro!: image_eqI)
  finally have 3: "reduced_GB ?F \<subseteq> ?F" .
  show "is_red (reduced_GB ?F) p \<longleftrightarrow> is_red ?F p"
  proof
    assume "is_red (reduced_GB ?F) p"
    thus "is_red ?F p" using 3 by (rule is_red_subset)
  next
    assume "is_red ?F p"
    then obtain f v where "f \<in> ?F" and "v \<in> keys p" and "f \<noteq> 0" and adds1: "lt f adds\<^sub>t v"
      by (rule is_red_addsE)
    from this(1) have "f \<in> pmdl ?F" by (rule pmdl.span_base)
    from dgrad 1 2 have "is_Groebner_basis (reduced_GB ?F)" by (rule reduced_GB_is_GB_dgrad_p_set)
    moreover from \<open>f \<in> pmdl ?F\<close> dgrad 1 2 have "f \<in> pmdl (reduced_GB ?F)"
      by (simp only: reduced_GB_pmdl_dgrad_p_set)
    ultimately obtain g where "g \<in> reduced_GB ?F" and "g \<noteq> 0" and "lt g adds\<^sub>t lt f"
      using \<open>f \<noteq> 0\<close> by (rule GB_adds_lt)
    from this(3) adds1 have "lt g adds\<^sub>t v" by (rule adds_term_trans)
    with \<open>g \<in> reduced_GB ?F\<close> \<open>g \<noteq> 0\<close> \<open>v \<in> keys p\<close> show "is_red (reduced_GB ?F) p"
      by (rule is_red_addsI)
  qed
qed

corollary is_red_reduced_GB_monomial_lt_GB_dgrad_p_set:
  assumes "finite (component_of_term ` Keys G)" and "G \<subseteq> dgrad_p_set d m" and "0 \<notin> G"
  shows "is_red (reduced_GB (monomial (1::'b::field) ` lt ` G)) = is_red G"
proof -
  let ?S = "lt ` G"
  let ?G = "monomial (1::'b) ` ?S"
  from assms(3) have "?S \<subseteq> Keys G" by (auto intro: lt_in_keys in_KeysI)
  hence "component_of_term ` ?S \<subseteq> component_of_term ` Keys G"
    and *: "pp_of_term ` ?S \<subseteq> pp_of_term ` Keys G" by (rule image_mono)+
  from this(1) have "finite (component_of_term ` ?S)" using assms(1) by (rule finite_subset)
  moreover from * have "pp_of_term ` ?S \<subseteq> dgrad_set d m"
  proof (rule subset_trans)
    from assms(2) show "pp_of_term ` Keys G \<subseteq> dgrad_set d m" by (auto simp: dgrad_p_set_def Keys_def)
  qed
  ultimately have "is_red (reduced_GB ?G) = is_red ?G" by (rule is_red_reduced_GB_monomial_dgrad_set)
  also from assms(3) have "\<dots> = is_red G" by (rule is_red_monomial_lt)
  finally show ?thesis .
qed

lemma reduced_GB_monomial_lt_reduced_GB_dgrad_p_set:
  assumes "finite (component_of_term ` Keys F)" and "F \<subseteq> dgrad_p_set d m"
  shows "reduced_GB (monomial 1 ` lt ` reduced_GB F) = monomial (1::'b::field) ` lt ` reduced_GB F"
proof (rule reduced_GB_unique)
  let ?G = "reduced_GB F"
  let ?F = "monomial (1::'b) ` lt ` ?G"

  from dgrad assms have "0 \<notin> ?G" and ar: "is_auto_reduced ?G" and "finite ?G"
    by (rule reduced_GB_nonzero_dgrad_p_set, rule reduced_GB_is_auto_reduced_dgrad_p_set,
        rule finite_reduced_GB_dgrad_p_set)
  from this(3) show "finite ?F" by (intro finite_imageI)

  show "is_reduced_GB ?F" unfolding is_reduced_GB_def
  proof (intro conjI monomial_set_is_GB)
    show "is_monomial_set ?F" by (auto intro!: is_monomial_setI monomial_is_monomial)
  next
    show "is_monic_set ?F" by (simp add: is_monic_set_def)
  next
    show "0 \<notin> ?F" by (auto simp: monomial_0_iff)
  next
    show "is_auto_reduced ?F" unfolding is_auto_reduced_def
    proof (intro ballI notI)
      fix f
      assume "f \<in> ?F"
      then obtain g where "g \<in> ?G" and f: "f = monomial 1 (lt g)" by blast
      assume "is_red (?F - {f}) f"
      then obtain f' v where "f' \<in> ?F - {f}" and "v \<in> keys f" and "f' \<noteq> 0" and adds1: "lt f' adds\<^sub>t v"
        by (rule is_red_addsE)
      from this(1) have "f' \<in> ?F" and "f' \<noteq> f" by simp_all
      from this(1) obtain g' where "g' \<in> ?G" and f': "f' = monomial 1 (lt g')" by blast
      from \<open>v \<in> keys f\<close> have v: "v = lt g" by (simp add: f)
      from ar \<open>g \<in> ?G\<close> have "\<not> is_red (?G - {g}) g" by (rule is_auto_reducedD)
      moreover have "is_red (?G - {g}) g"
      proof (rule is_red_addsI)
        from \<open>g' \<in> ?G\<close> \<open>f' \<noteq> f\<close> show "g' \<in> ?G - {g}" by (auto simp: f f')
      next
        from \<open>g' \<in> ?G\<close> \<open>0 \<notin> ?G\<close> show "g' \<noteq> 0" by blast
      next
        from \<open>g \<in> ?G\<close> \<open>0 \<notin> ?G\<close> have "g \<noteq> 0" by blast
        thus "lt g \<in> keys g" by (rule lt_in_keys)
      next
        from adds1 show adds2: "lt g' adds\<^sub>t lt g" by (simp add: v f' lt_monomial)
      qed
      ultimately show False ..
    qed
  qed
qed (fact refl)

end

end (* gd_term *)

end (* theory *)


(*  Title:      IPv4.thy
    Authors:    Cornelius Diekmann, Julius Michaelis
*)
theory IPv4
imports IP_Address
        NumberWang_IPv4
        (* include "HOL-Library.Code_Target_Nat" if you need to work with actual numbers.*)
begin

lemma take_bit_word_beyond_length_eq:
  \<open>take_bit n w = w\<close> if \<open>LENGTH('a) \<le> n\<close> for w :: \<open>'a::len word\<close>
  using that by transfer simp

section \<open>IPv4 Adresses\<close>
  text\<open>An IPv4 address is basically a 32 bit unsigned integer.\<close>
  type_synonym ipv4addr = "32 word"

  text\<open>Conversion between natural numbers and IPv4 adresses\<close>
  definition nat_of_ipv4addr :: "ipv4addr \<Rightarrow> nat" where
    "nat_of_ipv4addr a = unat a"
  definition ipv4addr_of_nat :: "nat \<Rightarrow> ipv4addr" where
    "ipv4addr_of_nat n =  of_nat n"

  text\<open>The maximum IPv4 addres\<close>
  definition max_ipv4_addr :: "ipv4addr" where
    "max_ipv4_addr \<equiv> ipv4addr_of_nat ((2^32) - 1)"

  lemma max_ipv4_addr_number: "max_ipv4_addr = 4294967295"
    unfolding max_ipv4_addr_def ipv4addr_of_nat_def by(simp)
  lemma "max_ipv4_addr = 0b11111111111111111111111111111111"
    by(fact max_ipv4_addr_number)
  lemma max_ipv4_addr_max_word: "max_ipv4_addr = - 1"
    by(simp add: max_ipv4_addr_number)
  lemma max_ipv4_addr_max[simp]: "\<forall>a. a \<le> max_ipv4_addr"
    by(simp add: max_ipv4_addr_max_word)
  lemma UNIV_ipv4addrset: "UNIV = {0 .. max_ipv4_addr}" (*not in the simp set, for a reason*)
    by(simp add: max_ipv4_addr_max_word) fastforce

  text\<open>identity functions\<close>
  lemma nat_of_ipv4addr_ipv4addr_of_nat_mod: "nat_of_ipv4addr (ipv4addr_of_nat n) = n mod 2^32"
    by (simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def unat_of_nat take_bit_eq_mod)
  lemma nat_of_ipv4addr_ipv4addr_of_nat:
    "\<lbrakk> n \<le> nat_of_ipv4addr max_ipv4_addr \<rbrakk> \<Longrightarrow> nat_of_ipv4addr (ipv4addr_of_nat n) = n"
    by (simp add: nat_of_ipv4addr_ipv4addr_of_nat_mod max_ipv4_addr_def)
  lemma ipv4addr_of_nat_nat_of_ipv4addr: "ipv4addr_of_nat (nat_of_ipv4addr addr) = addr"
    by(simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def)

subsection\<open>Representing IPv4 Adresses (Syntax)\<close>
  fun ipv4addr_of_dotdecimal :: "nat \<times> nat \<times> nat \<times> nat \<Rightarrow> ipv4addr" where
    "ipv4addr_of_dotdecimal (a,b,c,d) = ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a )"

  fun dotdecimal_of_ipv4addr :: "ipv4addr \<Rightarrow> nat \<times> nat \<times> nat \<times> nat" where
    "dotdecimal_of_ipv4addr a = (nat_of_ipv4addr ((a >> 24) AND 0xFF),
                                    nat_of_ipv4addr ((a >> 16) AND 0xFF),
                                    nat_of_ipv4addr ((a >> 8) AND 0xFF),
                                    nat_of_ipv4addr (a AND 0xff))"

  declare ipv4addr_of_dotdecimal.simps[simp del]
  declare dotdecimal_of_ipv4addr.simps[simp del]

  text\<open>Examples:\<close>
  lemma "ipv4addr_of_dotdecimal (192, 168, 0, 1) = 3232235521"
    by(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)
    (*could be solved by eval, but needs "HOL-Library.Code_Target_Nat"*)
  lemma "dotdecimal_of_ipv4addr 3232235521 = (192, 168, 0, 1)"
    by(simp add: dotdecimal_of_ipv4addr.simps nat_of_ipv4addr_def)

  text\<open>a different notation for @{term ipv4addr_of_dotdecimal}\<close>
  lemma ipv4addr_of_dotdecimal_bit:
    "ipv4addr_of_dotdecimal (a,b,c,d) =
      (ipv4addr_of_nat a << 24) + (ipv4addr_of_nat b << 16) +
       (ipv4addr_of_nat c << 8) + ipv4addr_of_nat d"
  proof -
    have a: "(ipv4addr_of_nat a) << 24 = ipv4addr_of_nat (a * 16777216)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    have b: "(ipv4addr_of_nat b) << 16 = ipv4addr_of_nat (b * 65536)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    have c: "(ipv4addr_of_nat c) << 8 = ipv4addr_of_nat (c * 256)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    have ipv4addr_of_nat_suc: "\<And>x. ipv4addr_of_nat (Suc x) = word_succ (ipv4addr_of_nat (x))"
      by(simp add: ipv4addr_of_nat_def, metis Abs_fnat_hom_Suc of_nat_Suc)
    { fix x y
      have "ipv4addr_of_nat x + ipv4addr_of_nat y = ipv4addr_of_nat (x+y)"
        apply(induction x arbitrary: y)
         apply(simp add: ipv4addr_of_nat_def; fail)
        by(simp add: ipv4addr_of_nat_suc word_succ_p1)
    } from this a b c
    show ?thesis
      apply(simp add: ipv4addr_of_dotdecimal.simps)
      apply(rule arg_cong[where f=ipv4addr_of_nat])
      apply(thin_tac _)+
      by presburger
  qed

  lemma size_ipv4addr: "size (x::ipv4addr) = 32" by(simp add:word_size)

  lemma dotdecimal_of_ipv4addr_ipv4addr_of_dotdecimal:
  "\<lbrakk> a < 256; b < 256; c < 256; d < 256 \<rbrakk> \<Longrightarrow>
    dotdecimal_of_ipv4addr (ipv4addr_of_dotdecimal (a,b,c,d)) = (a,b,c,d)"
  proof -
    assume  "a < 256" and "b < 256" and "c < 256" and "d < 256"
    note assms= \<open>a < 256\<close> \<open>b < 256\<close> \<open>c < 256\<close> \<open>d < 256\<close>
    hence a:  "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 24) AND mask 8) = a"
      apply (simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def)
      apply transfer
      apply (simp add: drop_bit_take_bit nat_take_bit_eq flip: take_bit_eq_mask)
      apply (simp add: drop_bit_eq_div take_bit_eq_mod)
      done
    have ipv4addr_of_nat_AND_mask8: "(ipv4addr_of_nat a) AND mask 8 = (ipv4addr_of_nat (a mod 256))"
      for a
      apply (simp add: ipv4addr_of_nat_def)
      apply transfer
      apply (simp flip: take_bit_eq_mask)
      apply (simp add: take_bit_eq_mod of_nat_mod)
      done
    from assms have b:
      "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 16) AND mask 8) = b"
      apply (simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def)
      apply transfer
      apply (simp add: drop_bit_take_bit flip: take_bit_eq_mask)
      using div65536
      apply (simp add: drop_bit_eq_div take_bit_eq_mod)
      done
    from assms have c:
      "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 8) AND mask 8) = c"
      apply (simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def)
      apply transfer
      apply (simp add: drop_bit_take_bit flip: take_bit_eq_mask)
      using div256
      apply (simp add: drop_bit_eq_div take_bit_eq_mod)
      done
    from \<open>d < 256\<close> have d: "nat_of_ipv4addr (ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) AND mask 8) = d"
      apply (simp add: ipv4addr_of_nat_AND_mask8 ipv4addr_of_nat_def nat_of_ipv4addr_def)
      apply transfer
      apply (simp flip: take_bit_eq_mask)
      apply (simp add: take_bit_eq_mod nat_mod_distrib nat_add_distrib nat_mult_distrib mod256)
      done
    from a b c d show ?thesis
      apply (simp add: ipv4addr_of_dotdecimal.simps dotdecimal_of_ipv4addr.simps)
      apply (simp add: mask_eq push_bit_of_1)
      done
  qed

  lemma ipv4addr_of_dotdecimal_dotdecimal_of_ipv4addr:
    "(ipv4addr_of_dotdecimal (dotdecimal_of_ipv4addr ip)) = ip"
  proof -
    have ip_and_mask8_bl_drop24: "(ip::ipv4addr) AND mask 8 = of_bl (drop 24 (to_bl ip))"
      by(simp add: of_drop_to_bl size_ipv4addr)
    have List_rev_drop_geqn: "length x \<ge> n \<Longrightarrow> (take n (rev x)) = rev (drop (length x - n) x)"
      for x :: "'a list" and n by(simp add: List.rev_drop)
    have and_mask_bl_take: "length x \<ge> n \<Longrightarrow> ((of_bl x) AND mask n) = (of_bl (rev (take n (rev (x)))))"
      for x n by(simp add: List_rev_drop_geqn of_bl_drop)
    have ipv4addr_and_255: "x AND 255 = x AND mask 8" for x :: ipv4addr
      by (simp add: mask_eq push_bit_of_1)
    have bit_equality:
      "((ip >> 24) AND 0xFF << 24) + ((ip >> 16) AND 0xFF << 16) + ((ip >> 8) AND 0xFF << 8) + (ip AND 0xFF) =
       of_bl (take 8 (to_bl ip) @ take 8 (drop 8 (to_bl ip)) @ take 8 (drop 16 (to_bl ip)) @ drop 24 (to_bl ip))"
      apply(simp add: ipv4addr_and_255)
      apply(simp add: shiftr_slice)
      apply(simp add: slice_take' size_ipv4addr and_mask_bl_take flip: push_bit_and)
      apply(simp add: List_rev_drop_geqn)
      apply(simp add: drop_take)
      apply(simp add: shiftl_of_bl)
      apply(simp add: of_bl_append)
      apply(simp add: ip_and_mask8_bl_drop24)
      done
    have blip_split: "\<And> blip. length blip = 32 \<Longrightarrow>
      blip = (take 8 blip) @ (take 8 (drop 8 blip)) @ (take 8 (drop 16 blip)) @ (take 8 (drop 24 blip))"
      by(rename_tac blip,case_tac blip,simp_all)+ (*I'm so sorry for this ...*)
    have "ipv4addr_of_dotdecimal (dotdecimal_of_ipv4addr ip) = of_bl (to_bl ip)"
      apply (subst blip_split)
       apply simp
      apply (simp add: ipv4addr_of_dotdecimal_bit dotdecimal_of_ipv4addr.simps)
      apply (simp add: ipv4addr_of_nat_nat_of_ipv4addr)
      apply (simp flip: bit_equality)
      done
    thus ?thesis using word_bl.Rep_inverse[symmetric] by simp
  qed

  lemma ipv4addr_of_dotdecimal_eqE:
    "\<lbrakk> ipv4addr_of_dotdecimal (a,b,c,d) = ipv4addr_of_dotdecimal (e,f,g,h);
       a < 256; b < 256; c < 256; d < 256; e < 256; f < 256; g < 256; h < 256 \<rbrakk> \<Longrightarrow>
         a = e \<and> b = f \<and> c = g \<and> d = h"
     by (metis Pair_inject dotdecimal_of_ipv4addr_ipv4addr_of_dotdecimal)

subsection\<open>IP Ranges: Examples\<close>
  lemma "(UNIV :: ipv4addr set) = {0 .. max_ipv4_addr}" by(simp add: UNIV_ipv4addrset)
  lemma "(42::ipv4addr) \<in> UNIV" by(simp)

  (*Warning, not executable!*)

  lemma "ipset_from_netmask (ipv4addr_of_dotdecimal (192,168,0,42)) (ipv4addr_of_dotdecimal (255,255,0,0)) =
          {ipv4addr_of_dotdecimal (192,168,0,0) .. ipv4addr_of_dotdecimal (192,168,255,255)}"
   by(simp add: ipset_from_netmask_def ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)

  lemma "ipset_from_netmask (ipv4addr_of_dotdecimal (192,168,0,42)) (ipv4addr_of_dotdecimal (0,0,0,0)) = UNIV"
    by(simp add: UNIV_ipv4addrset ipset_from_netmask_def ipv4addr_of_dotdecimal.simps
                 ipv4addr_of_nat_def max_ipv4_addr_max_word)

  text\<open>192.168.0.0/24\<close>

  lemma fixes addr :: ipv4addr
    shows "ipset_from_cidr addr pflength =
            ipset_from_netmask addr ((mask pflength) << (32 - pflength))"
    by(simp add: ipset_from_cidr_def)

  lemma "ipset_from_cidr (ipv4addr_of_dotdecimal (192,168,0,42)) 16 =
          {ipv4addr_of_dotdecimal (192,168,0,0) .. ipv4addr_of_dotdecimal (192,168,255,255)}"
   by(simp add: ipset_from_cidr_alt mask_eq ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def push_bit_of_1)

  lemma "ip \<in> (ipset_from_cidr (ipv4addr_of_dotdecimal (0, 0, 0, 0)) 0)"
    by(simp add: ipset_from_cidr_0)

  lemma ipv4set_from_cidr_32: fixes addr :: ipv4addr
    shows "ipset_from_cidr addr 32 = {addr}"
    by (simp add: ipset_from_cidr_alt take_bit_word_beyond_length_eq flip: take_bit_eq_mask)

  lemma  fixes pre :: ipv4addr
    shows "ipset_from_cidr pre len = {(pre AND ((mask len) << (32 - len))) .. pre OR (mask (32 - len))}"
    by (simp add: ipset_from_cidr_alt ipset_from_cidr_def)

  text\<open>making element check executable\<close>
  lemma addr_in_ipv4set_from_netmask_code[code_unfold]:
    fixes addr :: ipv4addr
    shows "addr \<in> (ipset_from_netmask base netmask) \<longleftrightarrow>
            (base AND netmask) \<le> addr \<and> addr \<le> (base AND netmask) OR (NOT netmask)"
    by (simp add: addr_in_ipset_from_netmask_code)
  lemma addr_in_ipv4set_from_cidr_code[code_unfold]:
    fixes addr :: ipv4addr
    shows "addr \<in> (ipset_from_cidr pre len) \<longleftrightarrow>
              (pre AND ((mask len) << (32 - len))) \<le> addr \<and> addr \<le> pre OR (mask (32 - len))"
    by(simp add: addr_in_ipset_from_cidr_code)

  (*small numbers because we didn't load Code_Target_Nat. Should work by eval*)
lemma "ipv4addr_of_dotdecimal (192,168,42,8) \<in> (ipset_from_cidr (ipv4addr_of_dotdecimal (192,168,0,0)) 16)"
  by (simp add: ipv4addr_of_nat_def ipset_from_cidr_def ipv4addr_of_dotdecimal.simps
    ipset_from_netmask_def mask_eq_exp_minus_1 word_le_def take_bit_minus_one_eq_mask)

  definition ipv4range_UNIV :: "32 wordinterval" where "ipv4range_UNIV \<equiv> wordinterval_UNIV"

  lemma ipv4range_UNIV_set_eq: "wordinterval_to_set ipv4range_UNIV = UNIV"
    by(simp only: ipv4range_UNIV_def wordinterval_UNIV_set_eq)

  thm iffD1[OF wordinterval_eq_set_eq]
  (*TODO: probably the following is a good idea?*)
  (*
  declare iffD1[OF wordinterval_eq_set_eq, cong]
  *)

  text\<open>This \<open>LENGTH('a)\<close> is 32 for IPv4 addresses.\<close>
  lemma ipv4cidr_to_interval_simps[code_unfold]: "ipcidr_to_interval ((pre::ipv4addr), len) = (
      let netmask = (mask len) << (32 - len);
          network_prefix = (pre AND netmask)
      in (network_prefix, network_prefix OR (NOT netmask)))"
  by(simp add: ipcidr_to_interval_def Let_def ipcidr_to_interval_start.simps ipcidr_to_interval_end.simps)

end


(*
Auction Theory Toolbox (http://formare.github.io/auctions/)

Authors:
* Marco B. Caminati http://caminati.co.nr
* Manfred Kerber <mnfrd.krbr@gmail.com>
* Christoph Lange <math.semantic.web@gmail.com>
* Colin Rowat <c.rowat@bham.ac.uk>

Dually licenced under
* Creative Commons Attribution (CC-BY) 3.0
* ISC License (1-clause BSD License)
See LICENSE file for details
(Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
*)

section \<open>VCG auction: definitions and theorems\<close>

theory CombinatorialAuction

imports
UniformTieBreaking

begin

subsection \<open>Definition of a VCG auction scheme, through the pair @{term "(vcga, vcgp)"}\<close>

(* b is a bid vector and participants is the set of all participants present in b *)
abbreviation "participants b == Domain (Domain b)"

(* goods is the list of goods auctioned *)
abbreviation "goods == sorted_list_of_set o Union o Range o Domain"

(* The seller is represented as integer 0, the other particants as integers 1, ..., n *)
abbreviation "seller == (0::integer)"

(* allAllocations' and allAllocations'' are variants of allAllocations. All three formulations are equivent. *)
abbreviation "allAllocations' N \<Omega> ==
  injectionsUniverse \<inter> {a. Domain a \<subseteq> N & Range a \<in> all_partitions \<Omega>}"

abbreviation "allAllocations'' N \<Omega> == allocationsUniverse \<inter> {a. Domain a \<subseteq> N & \<Union>(Range a) = \<Omega>}"

lemma allAllocationsEquivalence:
  "allAllocations N \<Omega> = allAllocations' N \<Omega> & allAllocations N \<Omega> = allAllocations'' N \<Omega>"
  using allocationInjectionsUnivervseProperty allAllocationsIntersection by metis

lemma allAllocationsVarCharacterization:
  "(a \<in> allAllocations'' N \<Omega>) = (a \<in> allocationsUniverse& Domain a \<subseteq> N & \<Union>(Range a) = \<Omega>)"
  by force

(* remove the seller from the set of all allocations *)
abbreviation "soldAllocations N \<Omega> == (Outside' {seller}) ` (allAllocations (N \<union> {seller}) \<Omega>)"

(* soldAllocations' and soldAllocations'' are variants of soldAllocations reflecting the different
   formulations of allAllocations. soldAllocations''' is yet another variant. These variants are
   used since for different proofs different variants are easier to use. *)
abbreviation "soldAllocations' N \<Omega> == (Outside' {seller}) ` (allAllocations' (N \<union> {seller}) \<Omega>)"
abbreviation "soldAllocations'' N \<Omega> == (Outside' {seller}) ` (allAllocations'' (N \<union> {seller}) \<Omega>)"
abbreviation "soldAllocations''' N \<Omega> ==
  allocationsUniverse \<inter> {aa. Domain aa\<subseteq>N-{seller} & \<Union>(Range aa)\<subseteq>\<Omega>}"
lemma soldAllocationsEquivalence:
  "soldAllocations N \<Omega> = soldAllocations' N \<Omega> &
   soldAllocations' N \<Omega> = soldAllocations'' N \<Omega>"
  using allAllocationsEquivalence by metis

corollary soldAllocationsEquivalenceVariant:
  "soldAllocations = soldAllocations'  &
   soldAllocations' = soldAllocations'' &
   soldAllocations = soldAllocations''"
  using soldAllocationsEquivalence by metis

lemma allocationSellerMonotonicity:
  "soldAllocations (N-{seller}) \<Omega> \<subseteq> soldAllocations N \<Omega>"
  using Outside_def by simp

lemma allocationsUniverseCharacterization:
  "(a \<in> allocationsUniverse) = (a \<in> allAllocations'' (Domain a) (\<Union>(Range a)))"
  by blast

lemma allocationMonotonicity:
  assumes "N1 \<subseteq> N2"
  shows "allAllocations'' N1 \<Omega> \<subseteq> allAllocations'' N2 \<Omega>"
  using assms by auto

lemma allocationWithOneParticipant:
  assumes "a \<in> allAllocations'' N \<Omega>"
  shows "Domain (a -- x) \<subseteq> N-{x}"
  using assms Outside_def by fastforce

lemma soldAllocationIsAllocation:
  assumes "a \<in> soldAllocations N \<Omega>"
  shows "a \<in> allocationsUniverse"
proof -
obtain aa where "a  =aa -- seller & aa \<in> allAllocations (N\<union>{seller}) \<Omega>"
  using assms by blast
then have "a \<subseteq> aa & aa \<in> allocationsUniverse"
  unfolding Outside_def using allAllocationsIntersectionSubset by blast
then show ?thesis using subsetAllocation by blast
qed

lemma soldAllocationIsAllocationVariant:
  assumes "a \<in> soldAllocations N \<Omega>"
  shows "a \<in> allAllocations'' (Domain a) (\<Union>(Range a))"
proof -
  show ?thesis using assms soldAllocationIsAllocation
  by auto blast+
qed

lemma onlyGoodsAreSold:
  assumes "a \<in> soldAllocations'' N \<Omega>"
  shows "\<Union> (Range a) \<subseteq> \<Omega>"
  using assms Outside_def by blast

lemma soldAllocationIsRestricted:
  "a \<in> soldAllocations'' N \<Omega> =
   (\<exists>aa. aa -- (seller) = a  \<and>  aa \<in> allAllocations'' (N \<union> {seller}) \<Omega>)"
  by blast

(* Note that +* enlarges the function by one additional pair *)
lemma restrictionConservation:
  "(R +* ({x}\<times>Y)) -- x = R -- x"
  unfolding Outside_def paste_def by blast

lemma allocatedToBuyerMeansSold:
  assumes "a \<in> allocationsUniverse" "Domain a \<subseteq> N-{seller}" "\<Union> (Range a) \<subseteq> \<Omega>"
  shows "a \<in> soldAllocations'' N \<Omega>"
proof -
  let ?i = "seller"
  let ?Y = "{\<Omega>-\<Union> (Range a)}-{{}}"
  let ?b = "{?i}\<times>?Y"
  let ?aa = "a\<union>?b"
  let ?aa' = "a +* ?b"
  have
  1: "a \<in> allocationsUniverse" using assms(1) by fast
  have "?b \<subseteq> {(?i,\<Omega>-\<Union>(Range a))} - {(?i, {})}" by fastforce
  then have
  2: "?b \<in> allocationsUniverse"
    using allocationUniverseProperty subsetAllocation by (metis(no_types))
  have
  3: "\<Union> (Range a) \<inter> \<Union> (Range ?b) = {}" by blast
  have
  4: "Domain a \<inter> Domain ?b ={}" using assms by fast
  have "?aa \<in> allocationsUniverse" using 1 2 3 4 by (rule allocationUnion)
  then have "?aa \<in> allAllocations'' (Domain ?aa) (\<Union> (Range ?aa))"
    unfolding allocationsUniverseCharacterization by metis
  then have "?aa \<in> allAllocations'' (N\<union>{?i}) (\<Union> (Range ?aa))"
    using allocationMonotonicity assms paste_def by auto
  moreover have "Range ?aa = Range a \<union> ?Y" by blast
  then moreover have "\<Union> (Range ?aa) = \<Omega>"
    using Un_Diff_cancel Un_Diff_cancel2 Union_Un_distrib Union_empty Union_insert
    by (metis (lifting, no_types) assms(3) cSup_singleton subset_Un_eq)
  moreover have "?aa' = ?aa" using 4 by (rule paste_disj_domains)
  ultimately have "?aa' \<in> allAllocations'' (N\<union>{?i}) \<Omega>" by simp
  moreover have "Domain ?b \<subseteq> {?i}" by fast
  have "?aa' -- ?i = a -- ?i" by (rule restrictionConservation)
  moreover have "... = a" using Outside_def assms(2) by auto
  ultimately show ?thesis using soldAllocationIsRestricted by auto
qed

lemma allocationCharacterization:
  "a \<in> allAllocations N \<Omega>  =
   (a \<in> injectionsUniverse & Domain a \<subseteq> N & Range a \<in> all_partitions \<Omega>)"
  by (metis (full_types) posssibleAllocationsRelCharacterization)

(* The lemmas lm01, lm02, lm03, and lm04 are used in order to prove
   lemma soldAllocationVariantEquivalence   *)
lemma lm01:
  assumes "a \<in> soldAllocations'' N \<Omega>"
  shows "Domain a \<subseteq> N-{seller} & a \<in> allocationsUniverse"
proof -
  let ?i = "seller"
  obtain aa where
  0: "a = aa -- ?i & aa \<in> allAllocations'' (N \<union> {?i}) \<Omega>"
    using assms(1) soldAllocationIsRestricted by blast
  then have "Domain aa \<subseteq> N \<union> {?i}" using allocationCharacterization by blast
  then have "Domain a \<subseteq> N - {?i}" using 0 Outside_def by blast
  moreover have "a \<in> soldAllocations N \<Omega>" using assms soldAllocationsEquivalenceVariant by metis
  then moreover have "a \<in> allocationsUniverse" using soldAllocationIsAllocation by blast
  ultimately show ?thesis by blast
qed

corollary lm02:
  assumes "a \<in> soldAllocations'' N \<Omega>"
  shows "a \<in> allocationsUniverse & Domain a \<subseteq> N-{seller} & \<Union> (Range a) \<subseteq> \<Omega>"
proof -
  have "a \<in> allocationsUniverse" using assms lm01 [of a] by blast
  moreover have "Domain a \<subseteq> N-{seller}" using assms lm01 by blast
  moreover have "\<Union> (Range a) \<subseteq> \<Omega>" using assms onlyGoodsAreSold by blast
  ultimately show ?thesis by blast
qed

corollary lm03:
  "(a \<in> soldAllocations'' N \<Omega>) =
   (a \<in> allocationsUniverse & a \<in> {aa. Domain aa \<subseteq> N-{seller} & \<Union> (Range aa) \<subseteq> \<Omega>})"
  (is "?L = ?R")
proof -
  have "(a\<in>soldAllocations'' N \<Omega>) =
        (a\<in>allocationsUniverse& Domain a \<subseteq> N-{seller} & \<Union> (Range a) \<subseteq> \<Omega>)"
  using lm02 allocatedToBuyerMeansSold by (metis (mono_tags))
  then have "?L = (a\<in>allocationsUniverse& Domain a \<subseteq> N-{seller} & \<Union> (Range a) \<subseteq> \<Omega>)" by fast
  moreover have "... = ?R" using mem_Collect_eq by (metis (lifting, no_types))
  ultimately show ?thesis by auto
qed

corollary lm04:
  "a \<in> soldAllocations'' N \<Omega> =
   (a\<in> (allocationsUniverse \<inter> {aa. Domain aa \<subseteq> N-{seller} & \<Union> (Range aa) \<subseteq> \<Omega>}))"
  using lm03 by (metis (mono_tags) Int_iff)

corollary soldAllocationVariantEquivalence:
  "soldAllocations'' N \<Omega> = soldAllocations''' N \<Omega>"
  (is "?L=?R")
proof -
  {
   fix a
   have "a \<in> ?L = (a \<in> ?R)" by (rule lm04)
  }
  thus ?thesis by blast
qed

(* We use lm05 in order to show a variant for soldAllocations without ''' *)
lemma lm05:
  assumes "a \<in> soldAllocations''' N \<Omega>"
  shows "a -- n \<in> soldAllocations''' (N-{n}) \<Omega>"
proof -
  let ?bb = seller
  let ?d = Domain
  let ?r = Range
  let ?X1 = "{aa. ?d aa \<subseteq> N-{n}-{?bb} & \<Union>(?r aa)\<subseteq>\<Omega>}"
  let ?X2 = "{aa. ?d aa \<subseteq> N-{?bb} & \<Union>(?r aa) \<subseteq> \<Omega>}"
  have "a\<in>?X2" using assms(1) by fast
  then have
  0: "?d a \<subseteq> N-{?bb} & \<Union>(?r a) \<subseteq> \<Omega>" by blast
  then have "?d (a--n) \<subseteq> N-{?bb}-{n}"
    using outside_reduces_domain by (metis Diff_mono subset_refl)
  moreover have "... = N-{n}-{?bb}" by fastforce
  ultimately have "?d (a--n) \<subseteq> N-{n}-{?bb}" by blast
  moreover have "\<Union> (?r (a--n)) \<subseteq> \<Omega>"
    unfolding Outside_def using 0 by blast
  ultimately have "a -- n \<in> ?X1" by fast
  moreover have "a--n \<in> allocationsUniverse"
    using assms(1) Int_iff allocationsUniverseOutside by (metis(lifting,mono_tags))
  ultimately show ?thesis by blast
qed

lemma allAllocationsEquivalenceExtended:
  "soldAllocations =  soldAllocations' &
   soldAllocations' = soldAllocations'' &
   soldAllocations'' = soldAllocations'''"
  using soldAllocationVariantEquivalence soldAllocationsEquivalenceVariant by metis

(* The following corollary shows that an allocation is invariant to subtracting a single bidder.
   This is used a fundamental step to prove the non-negativity of price in VCG. *)
corollary soldAllocationRestriction:
  assumes "a \<in> soldAllocations N \<Omega>"
  shows "a -- n \<in> soldAllocations (N-{n}) \<Omega>"
proof -
  let ?A' = soldAllocations'''
  have "a \<in> ?A' N \<Omega>" using assms allAllocationsEquivalenceExtended by metis
  then have "a -- n \<in> ?A' (N-{n}) \<Omega>" by (rule lm05)
  thus ?thesis using allAllocationsEquivalenceExtended by metis
qed

corollary allocationGoodsMonotonicity:
  assumes "\<Omega>1 \<subseteq> \<Omega>2"
  shows "soldAllocations''' N \<Omega>1 \<subseteq> soldAllocations''' N \<Omega>2"
  using assms by blast

corollary allocationGoodsMonotonicityVariant:
  assumes "\<Omega>1 \<subseteq> \<Omega>2"
  shows "soldAllocations'' N \<Omega>1 \<subseteq> soldAllocations'' N \<Omega>2"
proof -
  have "soldAllocations'' N \<Omega>1 = soldAllocations''' N \<Omega>1"
    by (rule soldAllocationVariantEquivalence)
  moreover have "... \<subseteq> soldAllocations''' N \<Omega>2"
    using assms(1) by (rule allocationGoodsMonotonicity)
  moreover have "... = soldAllocations'' N \<Omega>2" using soldAllocationVariantEquivalence by metis
  ultimately show ?thesis by auto
qed

(* maximalStrictAllocationsAlg are the allocations maximizing the revenue. They also include the
   unallocated goods assigned to the seller (bidder 0).*)
abbreviation "maximalStrictAllocations N \<Omega> b == argmax (sum b) (allAllocations ({seller}\<union>N) \<Omega>)"

(* randomBids builds up a bid vector from a random number so that bidding with this bid vector
   resolves any ties. Details are defined in UniformTieBreaking.thy *)
abbreviation "randomBids N \<Omega> b random == resolvingBid (N\<union>{seller}) \<Omega> b random"

(* vcgas gives the one-element set with the winning allocation after tie breaking.
   (argmax\<circ>sum) b ... determines the set of all maximal allocations.
   (argmax\<circ>sum) (randomBids ...) restricts that by tie-breaking to a singleton.
   Outside' {seller} removes the seller from the only allocation in the singleton.   *)
abbreviation "vcgas N \<Omega> b r  ==
  Outside' {seller} `((argmax\<circ>sum) (randomBids N \<Omega> b r)
                                      ((argmax\<circ>sum) b (allAllocations (N \<union> {seller}) (set \<Omega>))))"

(* Takes the element out of the one elemnt set (vcgas ...) *)
abbreviation "vcga N \<Omega> b r == the_elem (vcgas N \<Omega> b r)"

(* alternative definition of vcga *)
abbreviation "vcga' N \<Omega> b r ==
  (the_elem (argmax (sum (randomBids N \<Omega> b r))
                    (maximalStrictAllocations N (set \<Omega>) b)))
  -- seller"

(* The following three auxiliary lemmas, lm06, lm07, and lm08 are used to prove lemma
   vcgaEquivalence as well as in the theorem that cardinality of vcgas is one.*)
lemma lm06:
  assumes "card ((argmax\<circ>sum) (randomBids N \<Omega> b r)
                                 ((argmax\<circ>sum) b (allAllocations (N\<union>{seller}) (set \<Omega>)))) = 1"
  shows "vcga N \<Omega> b r =
         (the_elem ((argmax\<circ>sum) (randomBids N \<Omega> b r)
                                    ((argmax\<circ>sum) b (allAllocations ({seller}\<union>N) (set \<Omega>)))))
          -- seller"
  using assms cardOneTheElem by auto

corollary lm07:
  assumes "card ((argmax\<circ>sum) (randomBids N \<Omega> b r)
                                 ((argmax\<circ>sum) b (allAllocations (N\<union>{seller}) (set \<Omega>)))) = 1"
  shows "vcga N \<Omega> b r = vcga' N \<Omega> b r"
  (is "?l = ?r")
proof -
  have "?l = (the_elem ((argmax\<circ>sum) (randomBids N \<Omega> b r)
                                        ((argmax\<circ>sum) b (allAllocations ({seller}\<union>N) (set \<Omega>)))))
              -- seller"
    using assms by (rule lm06)
  moreover have "... = ?r" by force
  ultimately show ?thesis by blast
qed

lemma lm08:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "card ((argmax\<circ>sum) (randomBids N \<Omega> bids random)
                               ((argmax\<circ>sum) bids (allAllocations (N\<union>{seller}) (set \<Omega>)))) = 1"
  (is "card ?l=_")
proof -
  let ?N = "N\<union>{seller}"
  let ?b' = "randomBids N \<Omega> bids random"
  let ?s = sum
  let ?a = argmax
  let ?f = "?a \<circ> ?s"
  have
  1: "?N\<noteq>{}" by auto
  have
  2: "finite ?N" using assms(3) by simp
  have "?a (?s ?b') (?a (?s bids) (allAllocations ?N (set \<Omega>))) =
        {chosenAllocation ?N \<Omega> bids random}" (is "?L=?R")
  using 1 assms(1) assms(2) 2 by (rule winningAllocationUniqueness)
  moreover have "?L= ?f ?b' (?f bids (allAllocations ?N (set \<Omega>)))" by auto
  ultimately have "?l = {chosenAllocation ?N \<Omega> bids random}" by simp
  moreover have "card ...=1" by simp ultimately show ?thesis by simp
qed

lemma vcgaEquivalence:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "vcga N \<Omega> b r = vcga' N \<Omega> b r"
  using assms lm07 lm08 by blast

(* After showing that the cardinality of vcgas is 1, we know that the_elem to determine vcga
   will return a definite value. *)
theorem vcgaDefiniteness:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "card (vcgas N \<Omega> b r) = 1"
proof -
  have "card ((argmax\<circ>sum) (randomBids N \<Omega> b r)
                              ((argmax\<circ>sum) b (allAllocations (N\<union>{seller}) (set \<Omega>)))) =
        1"
  (is "card ?X = _") using assms lm08 by blast
  moreover have "(Outside'{seller}) ` ?X = vcgas N \<Omega> b r" by blast
  ultimately show ?thesis using cardOneImageCardOne by blast
qed

(* The following lemma is a variant of the vcgaDefiniteness theorem. *)
lemma vcgaDefinitenessVariant:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows  "card (argmax (sum (randomBids N \<Omega> b r))
                       (maximalStrictAllocations N (set \<Omega>) b)) =
          1"
  (is "card ?L=_")
proof -
  let ?n = "{seller}"
  have
  1: "(?n \<union> N)\<noteq>{}" by simp
  have
  2: "finite (?n\<union>N)" using assms(3) by fast
  have "terminatingAuctionRel (?n\<union>N) \<Omega> b r = {chosenAllocation (?n\<union>N) \<Omega> b r}"
    using 1 assms(1) assms(2) 2 by (rule winningAllocationUniqueness)
  moreover have "?L = terminatingAuctionRel (?n\<union>N) \<Omega> b r" by auto
  ultimately show ?thesis by auto
qed

theorem winningAllocationIsMaximal:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "the_elem (argmax (sum (randomBids N \<Omega> b r))
                          (maximalStrictAllocations N (set \<Omega>) b)) \<in>
         (maximalStrictAllocations N (set \<Omega>) b)"
  (is "the_elem ?X \<in> ?R")
proof -
  have "card ?X=1" using assms by (rule vcgaDefinitenessVariant)
  moreover have "?X \<subseteq> ?R" by auto
  ultimately show ?thesis using cardinalityOneTheElem by blast
qed

corollary winningAllocationIsMaximalWithoutSeller:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "vcga' N \<Omega> b r \<in> (Outside' {seller})`(maximalStrictAllocations N (set \<Omega>) b)"
  using assms winningAllocationIsMaximal by blast

lemma maximalAllactionWithoutSeller:
  "(Outside' {seller})`(maximalStrictAllocations N \<Omega> b) \<subseteq> soldAllocations N \<Omega>"
  using Outside_def by force

lemma onlyGoodsAreAllocatedAuxiliary:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "vcga' N \<Omega> b r \<in> soldAllocations N (set \<Omega>)"
  (is "?a \<in> ?A")
proof -
  have "?a \<in> (Outside' {seller})`(maximalStrictAllocations N (set \<Omega>) b)"
    using assms by (rule winningAllocationIsMaximalWithoutSeller)
  thus ?thesis using maximalAllactionWithoutSeller  by fastforce
qed

theorem onlyGoodsAreAllocated:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "vcga N \<Omega> b r \<in> soldAllocations N (set \<Omega>)"
  (is "_\<in>?r")
proof -
  have "vcga' N \<Omega> b r \<in> ?r" using assms by (rule onlyGoodsAreAllocatedAuxiliary)
  then show ?thesis using assms vcgaEquivalence by blast
qed

(* Let b be a bid vector such that the seller's bid for each possible set of goods is 0 then
   the revenue does not depend on the presence of the seller. *)
corollary neutralSeller:
  assumes "\<forall>X. X \<in> Range a \<longrightarrow>b (seller, X)=0" "finite a"
  shows "sum b a = sum b (a--seller)"
proof -
  let ?n = seller
  have "finite (a||{?n})" using assms restrict_def by (metis finite_Int)
  moreover have "\<forall>z \<in> a||{?n}. b z=0" using assms restrict_def by fastforce
  ultimately have "sum b (a||{?n}) = 0" using assms by (metis sum.neutral)
  thus ?thesis using sumOutside assms(2) by (metis add.comm_neutral)
qed

corollary neutralSellerVariant:
  assumes "\<forall>a\<in>A. finite a & (\<forall> X. X\<in>Range a \<longrightarrow> b (seller, X)=0)"
  shows "{sum b a| a. a\<in>A} = {sum b (a -- seller)| a. a\<in>A}"
  using assms neutralSeller by (metis (lifting, no_types))

lemma vcgaIsMaximalAux1:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "\<exists>a. ((a \<in> (maximalStrictAllocations N (set \<Omega>) b))  \<and>  (vcga' N \<Omega> b r = a -- seller)  &
                (a \<in> argmax (sum b) (allAllocations ({seller}\<union>N) (set \<Omega>))))"
  using assms winningAllocationIsMaximalWithoutSeller by fast

lemma vcgaIsMaximalAux2:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  "\<forall>a \<in> allAllocations ({seller}\<union>N) (set \<Omega>). \<forall> X \<in> Range a. b (seller, X)=0"
  (is "\<forall>a\<in>?X. _")
  shows "sum b (vcga' N \<Omega> b r) = Max{sum b a| a. a \<in> soldAllocations N (set \<Omega>)}"
proof -
  let ?n = seller
  let ?s = sum
  let ?a = "vcga' N \<Omega> b r"
  obtain a where
  0: "a \<in> maximalStrictAllocations N (set \<Omega>) b &
      ?a = a--?n &
      (a \<in> argmax (sum b) (allAllocations({seller}\<union>N)(set \<Omega>)))"
  (is "_ & ?a=_ & a\<in>?Z")
    using assms(1,2,3) vcgaIsMaximalAux1 by blast
  have
  1: "\<forall>a \<in> ?X. finite a & (\<forall> X. X\<in>Range a \<longrightarrow> b (?n, X)=0)"
    using assms(4) List.finite_set allocationFinite by metis
  have
  2: "a \<in> ?X" using 0 by auto have "a \<in> ?Z" using 0 by fast
  then have "a \<in> ?X\<inter>{x. ?s b x = Max (?s b ` ?X)}" using injectionsUnionCommute by simp
  then have "a \<in> {x. ?s b x = Max (?s b ` ?X)}" using injectionsUnionCommute by simp
  moreover have "?s b ` ?X = {?s b a| a. a\<in>?X}" by blast
  ultimately have "?s b a = Max {?s b a| a. a\<in>?X}" by auto
  moreover have "{?s b a| a. a\<in>?X} = {?s b (a--?n)| a. a\<in>?X}"
    using 1 by (rule neutralSellerVariant)
  moreover have "... = {?s b a| a. a \<in> Outside' {?n}`?X}" by blast
  moreover have "... = {?s b a| a. a \<in> soldAllocations N (set \<Omega>)}" by simp
  ultimately have "Max {?s b a| a. a \<in> soldAllocations N (set \<Omega>)} = ?s b a" by simp
  moreover have "... = ?s b (a--?n)" using 1 2 neutralSeller by (metis (lifting, no_types))
  ultimately show "?s b ?a=Max{?s b a| a. a \<in> soldAllocations N (set \<Omega>)}" using 0 by simp
qed

text \<open>Adequacy theorem: The allocation satisfies the standard pen-and-paper specification
of a VCG auction. See, for example, \cite[\S~1.2]{cramton}.\<close>
theorem vcgaIsMaximal:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N" "\<forall> X. b (seller, X) = 0"
  shows "sum b (vcga' N \<Omega> b r) = Max{sum b a| a. a \<in> soldAllocations N (set \<Omega>)}"
  using assms vcgaIsMaximalAux2 by blast

corollary vcgaIsAllocationAllocatingGoodsOnly:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "vcga' N \<Omega> b r \<in> allocationsUniverse & \<Union> (Range (vcga' N \<Omega> b r)) \<subseteq> set \<Omega>"
proof -
  let ?a = "vcga' N \<Omega> b r"
  let ?n = seller
  obtain a where
  0: "?a = a -- seller & a \<in> maximalStrictAllocations N (set \<Omega>) b"
    using assms winningAllocationIsMaximalWithoutSeller by blast
  then moreover have
  1: "a \<in> allAllocations ({?n}\<union>N) (set \<Omega>)" by auto
  moreover have "maximalStrictAllocations N (set \<Omega>) b \<subseteq> allocationsUniverse"
     by (metis (lifting, mono_tags) winningAllocationPossible
                                    allAllocationsUniverse subset_trans)
  ultimately moreover have "?a = a -- seller  &  a \<in> allocationsUniverse" by blast
  then have "?a \<in> allocationsUniverse" using allocationsUniverseOutside by auto
  moreover have "\<Union> (Range a) = set \<Omega>" using allAllocationsIntersectionSetEquals 1 by metis
  then moreover have "\<Union> (Range ?a) \<subseteq> set \<Omega>" using Outside_def 0 by fast
  ultimately show ?thesis using allocationsUniverseOutside Outside_def by blast
qed

(* The price a participant n has to pay is the revenue achieved if n had not participated minus
   the value of the goods allocated not to n. *)
abbreviation "vcgp N \<Omega> b r n ==
   Max (sum b ` (soldAllocations (N-{n}) (set \<Omega>)))
    -  (sum b (vcga N \<Omega> b r -- n))"

(* Since vcga is well-defined the following theorem is trivial. *)
theorem vcgpDefiniteness:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "\<exists>! y. vcgp N \<Omega> b r n = y"
  using assms vcgaDefiniteness by simp

lemma soldAllocationsFinite:
  assumes "finite N" "finite \<Omega>"
  shows "finite (soldAllocations N \<Omega>)"
  using assms allAllocationsFinite finite.emptyI finite.insertI finite_UnI finite_imageI
  by metis

text\<open>The price paid by any participant is non-negative.\<close>
theorem NonnegPrices:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "vcgp N \<Omega> b r n >= (0::price)"
proof -
  let ?a = "vcga N \<Omega> b r"
  let ?A = soldAllocations
  let ?f = "sum b"
  have "?a \<in> ?A N (set \<Omega>)" using assms by (rule onlyGoodsAreAllocated)
  then have "?a -- n \<in> ?A (N-{n}) (set \<Omega>)" by (rule soldAllocationRestriction)
  moreover have "finite (?A (N-{n}) (set \<Omega>))"
    using assms(3) soldAllocationsFinite finite_set finite_Diff by blast
  ultimately have "Max (?f`(?A (N-{n}) (set \<Omega>))) \<ge> ?f (?a -- n)"
  (is "?L >= ?R") by (rule maxLemma)
  then show "?L - ?R >=0" by linarith
qed

lemma allocationDisjointAuxiliary:
  assumes "a \<in> allocationsUniverse" and "n1 \<in> Domain a" and "n2 \<in> Domain a" and "n1 \<noteq> n2"
  shows "a,,n1 \<inter> a,,n2 = {}"
proof -
  have "Range a \<in> partitionsUniverse" using assms nonOverlapping by blast
  moreover have "a \<in> injectionsUniverse & a \<in> partitionValuedUniverse"
    using assms by (metis (lifting, no_types) IntD1 IntD2)
  ultimately moreover have "a,,n1 \<in> Range a"
    using assms by (metis (mono_tags) eval_runiq_in_Range mem_Collect_eq)
  ultimately moreover have "a,,n1 \<noteq> a,,n2"
    using assms converse.intros eval_runiq_rel mem_Collect_eq runiq_basic
    by (metis (lifting, no_types))
  ultimately show ?thesis
    using is_non_overlapping_def
    by (metis (lifting, no_types) assms(3) eval_runiq_in_Range mem_Collect_eq)
qed

lemma allocationDisjoint:
  assumes "a \<in> allocationsUniverse" and "n1 \<in> Domain a" and "n2 \<in> Domain a" and "n1 \<noteq> n2"
  shows "a,,,n1 \<inter> a,,,n2 = {}"
  using assms allocationDisjointAuxiliary imageEquivalence by fastforce

text\<open>No good is assigned twice.\<close>
(* We assume implicitely that n1, n2 are participants, \<Omega> a goods list and N the participant set
   with "n1 \<in> Domain (vcga' N \<Omega> b r)" "n2 \<in> Domain (vcga' N \<Omega> b r)". However,
   formally these assumptions are not needed for the theorem. *)
theorem PairwiseDisjointAllocations:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"  "n1 \<noteq> n2"
  shows "(vcga' N \<Omega> b r),,,n1 \<inter> (vcga' N \<Omega> b r),,,n2 = {}"
proof -
  have "vcga' N \<Omega> b r \<in> allocationsUniverse"
    using vcgaIsAllocationAllocatingGoodsOnly assms by blast
  then show ?thesis using allocationDisjoint assms by fast
qed

text \<open>Nothing outside the set of goods is allocated.\<close>
theorem OnlyGoodsAllocated:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N" "g \<in> (vcga N \<Omega> b r),,,n"
  shows "g \<in> set \<Omega>"
proof -
  let ?a = "vcga' N \<Omega> b r"
  have "?a \<in> allocationsUniverse" using assms(1,2,3) vcgaIsAllocationAllocatingGoodsOnly by blast
  then have 1: "runiq ?a" using assms(1,2,3) by blast
  have 2: "n \<in> Domain ?a" using assms vcgaEquivalence by fast
  with 1 have "?a,,n \<in> Range ?a" using eval_runiq_in_Range by fast
  with 1 2 have "?a,,,n \<in> Range ?a" using imageEquivalence by fastforce
  then have "g \<in> \<Union> (Range ?a)" using assms vcgaEquivalence by blast
  moreover have "\<Union> (Range ?a) \<subseteq> set \<Omega>" using assms(1,2,3) vcgaIsAllocationAllocatingGoodsOnly by fast
  ultimately show ?thesis by blast
qed

subsection \<open>Computable versions of the VCG formalization\<close>

(*  The computable versions are used to extract code.
   Furthermore we prove the equivalence with their classical counterparts. This computes the set of all maximal allocations including the seller. *)
abbreviation "maximalStrictAllocationsAlg N \<Omega> b ==
  argmax (sum b) (set (allAllocationsAlg ({seller}\<union>N) \<Omega>))"

(* This computes the maximal allocation after tie breaking. *)
definition "chosenAllocationAlg N \<Omega> b (r::integer) ==
  (randomEl (takeAll (%x. x\<in> (argmax \<circ> sum) b (set (allAllocationsAlg N \<Omega>)))
                    (allAllocationsAlg N \<Omega>))
            r)"

(* This is the computable version of maxbid in UniformTieBreaking.thy. It takes an allocation,
   the bidders and the goods and computes a bid such for each good a bidder bids 1 if they get
   that good in allocation a, else they bid 0.*)
definition "maxbidAlg a N \<Omega> == (bidMaximizedBy a N \<Omega>) Elsee 0"

(* This is the completed version of summedBidVectorRel by returning 0 if
   summedBidVectorRel is not defined. *)
definition "summedBidVectorAlg bids N \<Omega> == (summedBidVectorRel bids N \<Omega>) Elsee 0"

(* Computable version of tiebids. If computes a bid vector that when the VCG algorithm runs
   on it yields the singleton {a}. *)
definition "tiebidsAlg a N \<Omega> == summedBidVectorAlg (maxbidAlg a N \<Omega>) N \<Omega>"

(* Computable version of resolvingBid, that is, is computes the bid vector in random values
   that returns the chosen winning allocation *)
definition "resolvingBidAlg N \<Omega> bids random ==
  tiebidsAlg (chosenAllocationAlg N \<Omega> bids random) N (set \<Omega>)"

(* The same as above, but adding the seller who receives all unallocated goods. *)
definition "randomBidsAlg N \<Omega> b random == resolvingBidAlg (N\<union>{seller}) \<Omega> b random"

(* Computable allocation without those participants who do not receive anything. *)
definition "vcgaAlgWithoutLosers N \<Omega> b r ==
  (the_elem (argmax (sum (randomBidsAlg N \<Omega> b r))
                    (maximalStrictAllocationsAlg N \<Omega> b)))
  -- seller"

(* Adding losers to an arbitrary allocation *)
abbreviation "addLosers participantset allocation == (participantset \<times> {{}}) +* allocation"

(* Computable version of vcga. It computes the winning allocation incl. losers. *)
definition "vcgaAlg N \<Omega> b r = addLosers N (vcgaAlgWithoutLosers N \<Omega> b r)"

(* Computable version of soldAllocations *)
abbreviation "soldAllocationsAlg N \<Omega> ==
  (Outside' {seller}) ` set (allAllocationsAlg (N \<union> {seller}) \<Omega>)"

(* Computable version of vcgp, which computes the prices each participant has to pay. Note that
   losers do not pay anything, hence vcgaAlgWithoutLosers is here equivalent to vcgaAlg.
   The price a participant n has to pay is the revenue achieved if n had not participated minus
   the value of the goods allocated not to n.*)
definition "vcgpAlg N \<Omega> b r n (winningAllocation::allocation) =
  Max (sum b ` (soldAllocationsAlg (N-{n}) \<Omega>)) -
  (sum b (winningAllocation -- n))"

lemma functionCompletion:
  assumes "x \<in> Domain f"
  shows "toFunction f x = (f Elsee 0) x"
  unfolding toFunctionWithFallbackAlg_def by (metis assms toFunction_def)

(* This technical lemma shows the equivalence of Elsee and toFunction inside a sum expression
   under certain assumptions. It is used for the proof of the bridging theorem that
   the two versions of the definition of maximalStrictAllocations are equivalent.*)
lemma lm09:
  assumes "fst pair \<in> N" "snd pair \<in> Pow \<Omega> - {{}}"
  shows "sum (%g. (toFunction (bidMaximizedBy a N \<Omega>))  (fst pair, g))
                (finestpart (snd pair)) =
         sum (%g. ((bidMaximizedBy a N \<Omega>) Elsee 0) (fst pair, g))
                (finestpart (snd pair))"
proof -
  let ?f1 = "%g.(toFunction (bidMaximizedBy a N \<Omega>))(fst pair, g)"
  let ?f2 = "%g.((bidMaximizedBy a N \<Omega>) Elsee 0)(fst pair, g)"
  {
    fix g assume "g \<in> finestpart (snd pair)"
    then have
    0: "g \<in> finestpart \<Omega>" using assms finestpartSubset  by (metis Diff_iff Pow_iff in_mono)
    have "?f1 g = ?f2 g"
    proof -
      have "\<And>x\<^sub>1 x\<^sub>2. (x\<^sub>1, g) \<in> x\<^sub>2 \<times> finestpart \<Omega> \<or> x\<^sub>1 \<notin> x\<^sub>2" by (metis 0 mem_Sigma_iff)
      then have "(pseudoAllocation a <| (N \<times> finestpart \<Omega>)) (fst pair, g) =
                 maxbidAlg a N \<Omega> (fst pair, g)"
        unfolding toFunctionWithFallbackAlg_def maxbidAlg_def
        by (metis (no_types) domainCharacteristicFunction UnCI assms(1) toFunction_def)
    thus ?thesis unfolding maxbidAlg_def by blast
    qed
  }
  thus ?thesis using sum.cong by simp
qed

(* lm10, lm11, lm12, l13 are variants of lm09 *)
corollary lm10:
  assumes "pair \<in> N \<times> (Pow \<Omega> - {{}})"
  shows  "summedBid (toFunction (bidMaximizedBy a N \<Omega>)) pair =
          summedBid ((bidMaximizedBy a N \<Omega>) Elsee 0) pair"
proof -
  have "fst pair \<in> N" using assms by force
  moreover have "snd pair \<in> Pow \<Omega> - {{}}" using assms(1) by force
  ultimately show ?thesis using lm09 by blast
qed

corollary lm11:
  "\<forall> pair \<in> N \<times> (Pow \<Omega> - {{}}).
   summedBid (toFunction (bidMaximizedBy a N \<Omega>)) pair =
   summedBid ((bidMaximizedBy a N \<Omega>) Elsee 0) pair"
  using lm10 by blast

corollary lm12:
  "(summedBid (toFunction (bidMaximizedBy a N \<Omega>))) ` (N \<times> (Pow \<Omega> - {{}}))=
   (summedBid ((bidMaximizedBy a N \<Omega>) Elsee 0)) ` (N \<times> (Pow \<Omega> - {{}}))"
  (is "?f1 ` ?Z = ?f2 ` ?Z")
proof -
  have "\<forall> z \<in> ?Z. ?f1 z = ?f2 z" by (rule lm11)
  thus ?thesis by (rule functionEquivalenceOnSets)
qed

corollary lm13:
  "summedBidVectorRel (toFunction (bidMaximizedBy a N \<Omega>)) N \<Omega> =
   summedBidVectorRel ((bidMaximizedBy a N \<Omega>) Elsee 0) N \<Omega>"
  using lm12 by metis

corollary maxbidEquivalence:
  "summedBidVectorRel (maxbid a N \<Omega>) N \<Omega> =
   summedBidVectorRel (maxbidAlg a N \<Omega>) N \<Omega>"
  unfolding maxbidAlg_def using lm13 by metis

lemma summedBidVectorEquivalence:
  assumes "x \<in> (N \<times> (Pow \<Omega> - {{}}))"
  shows "summedBidVector (maxbid a N \<Omega>) N \<Omega> x = summedBidVectorAlg (maxbidAlg a N \<Omega>) N \<Omega> x"
  (is "?f1 ?g1 N \<Omega> x = ?f2 ?g2 N \<Omega> x")
proof -
  let ?h1 = "maxbid a N \<Omega>"
  let ?h2 = "maxbidAlg a N \<Omega>"
  have "summedBidVectorRel ?h1 N \<Omega> = summedBidVectorRel ?h2 N \<Omega>"
    using maxbidEquivalence by metis
  moreover have "summedBidVectorAlg ?h2 N \<Omega> = (summedBidVectorRel ?h2 N \<Omega>) Elsee 0"
    unfolding summedBidVectorAlg_def by fast
  ultimately have " summedBidVectorAlg ?h2 N \<Omega>=summedBidVectorRel ?h1 N \<Omega> Elsee 0" by simp
  moreover have "... x = (toFunction (summedBidVectorRel ?h1 N \<Omega>)) x"
    using assms functionCompletion summedBidVectorCharacterization by (metis (mono_tags))
  ultimately have "summedBidVectorAlg ?h2 N \<Omega> x = (toFunction (summedBidVectorRel ?h1 N \<Omega>)) x"
    by (metis (lifting, no_types))
  thus ?thesis by simp
qed

(* TPTP ? *)
corollary chosenAllocationEquivalence:
  assumes "card N > 0" and "distinct \<Omega>"
  shows  "chosenAllocation N \<Omega> b r = chosenAllocationAlg N \<Omega> b r"
  using assms allAllocationsBridgingLemma
  by (metis (no_types) chosenAllocationAlg_def comp_apply)

corollary tiebidsBridgingLemma:
  assumes "x \<in> (N \<times> (Pow \<Omega> - {{}}))"
  shows "tiebids a N \<Omega> x = tiebidsAlg a N \<Omega> x"
  (is "?L=_")
proof -
  have "?L = summedBidVector (maxbid a N \<Omega>) N \<Omega> x" by fast
  moreover have "...= summedBidVectorAlg (maxbidAlg a N \<Omega>) N \<Omega> x"
    using assms by (rule summedBidVectorEquivalence)
  ultimately show ?thesis unfolding tiebidsAlg_def by fast
qed

definition "tiebids'=tiebids"
corollary tiebidsBridgingLemma':
  assumes "x \<in> (N \<times> (Pow \<Omega> - {{}}))"
  shows "tiebids' a N \<Omega> x = tiebidsAlg a N \<Omega> x"
using assms tiebidsBridgingLemma tiebids'_def by metis

abbreviation "resolvingBid' N G bids random ==
  tiebids' (chosenAllocation N G bids random) N (set G)"

lemma resolvingBidEquivalence:
  assumes "x \<in> (N \<times> (Pow (set \<Omega>) - {{}}))"  "card N > 0" "distinct \<Omega>"
  shows "resolvingBid' N \<Omega> b r x = resolvingBidAlg N \<Omega> b r x"
  using assms chosenAllocationEquivalence tiebidsBridgingLemma' resolvingBidAlg_def by metis

lemma sumResolvingBidEquivalence:
  assumes "card N > 0" "distinct \<Omega>" "a \<subseteq> (N \<times> (Pow (set \<Omega>) - {{}}))"
  shows "sum (resolvingBid' N \<Omega> b r) a = sum (resolvingBidAlg N \<Omega> b r) a"
  (is "?L=?R")
proof -
    have "\<forall>x\<in>a. resolvingBid' N \<Omega> b r x = resolvingBidAlg N \<Omega> b r x"
      using assms resolvingBidEquivalence by blast
    thus ?thesis using sum.cong by force
qed

lemma resolvingBidBridgingLemma:
  assumes "card N > 0" "distinct \<Omega>" "a \<subseteq> (N \<times> (Pow (set \<Omega>) - {{}}))"
  shows "sum (resolvingBid N \<Omega> b r) a = sum (resolvingBidAlg N \<Omega> b r) a"
  (is "?L=?R")
proof -
  have "?L=sum (resolvingBid' N \<Omega> b r) a" unfolding tiebids'_def by fast
  moreover have "...=?R"
  using assms by (rule sumResolvingBidEquivalence)
  ultimately show ?thesis by simp
qed

lemma allAllocationsInPowerset:
  "allAllocations N \<Omega> \<subseteq> Pow (N \<times> (Pow \<Omega> - {{}}))"
  by (metis PowI allocationPowerset subsetI)

corollary resolvingBidBridgingLemmaVariant1:
  assumes "card N > 0" "distinct \<Omega>" "a \<in> allAllocations N (set \<Omega>)"
  shows "sum (resolvingBid N \<Omega> b r) a = sum (resolvingBidAlg N \<Omega> b r) a"
proof -
  have "a \<subseteq> N \<times> (Pow (set \<Omega>) - {{}})" using assms(3) allAllocationsInPowerset by blast
  thus ?thesis using assms(1,2) resolvingBidBridgingLemma by blast
qed

corollary resolvingBidBridgingLemmaVariant2:
  assumes "finite N" "distinct \<Omega>" "a \<in> maximalStrictAllocations N (set \<Omega>) b"
  shows "sum (randomBids N \<Omega> b r) a = sum (randomBidsAlg N \<Omega> b r) a"
proof -
  have "card (N\<union>{seller}) > 0" using assms(1) sup_eq_bot_iff insert_not_empty
    by (metis card_gt_0_iff finite.emptyI finite.insertI finite_UnI)
  moreover have "distinct \<Omega>" using assms(2) by simp
  moreover have "a \<in> allAllocations (N\<union>{seller}) (set \<Omega>)" using assms(3) by fastforce
  ultimately show ?thesis unfolding randomBidsAlg_def by (rule resolvingBidBridgingLemmaVariant1)
qed

corollary tiebreakingGivesSingleton:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "card (argmax (sum (randomBidsAlg N \<Omega> b r))
                      (maximalStrictAllocations N (set \<Omega>) b)) =
         1"
proof -
  have "\<forall> a \<in> maximalStrictAllocations N (set \<Omega>) b.
        sum (randomBids N \<Omega> b r) a = sum (randomBidsAlg N \<Omega> b r) a"
    using assms(3,1) resolvingBidBridgingLemmaVariant2 by blast
  then have "argmax (sum (randomBidsAlg N \<Omega> b r)) (maximalStrictAllocations N (set \<Omega>) b) =
             argmax (sum (randomBids N \<Omega> b r)) (maximalStrictAllocations N (set \<Omega>) b)"
    using argmaxEquivalence by blast
  moreover have "card ... = 1" using assms by (rule vcgaDefinitenessVariant)
  ultimately show ?thesis by simp
qed

theorem maximalAllocationBridgingTheorem:
  assumes "finite N" "distinct \<Omega>"
  shows "maximalStrictAllocations N (set \<Omega>) b = maximalStrictAllocationsAlg N \<Omega> b"
proof -
  let ?N = "{seller} \<union> N"
  have "card ?N>0" using assms(1)
    by (metis (full_types) card_gt_0_iff finite_insert insert_is_Un insert_not_empty)
  thus ?thesis using assms(2) allAllocationsBridgingLemma by metis
qed

theorem vcgaAlgDefinedness:
  assumes "distinct \<Omega>" "set \<Omega> \<noteq> {}" "finite N"
  shows "card (argmax (sum (randomBidsAlg N \<Omega> b r)) (maximalStrictAllocationsAlg N \<Omega> b)) = 1"
proof -
  have "card (argmax (sum (randomBidsAlg N \<Omega> b r)) (maximalStrictAllocations N (set \<Omega>) b)) = 1"
    using assms by (rule tiebreakingGivesSingleton)
  moreover have "maximalStrictAllocations N (set \<Omega>) b = maximalStrictAllocationsAlg N \<Omega> b"
    using assms(3,1) by (rule maximalAllocationBridgingTheorem)
  ultimately show ?thesis by metis
qed

end


(*  Title:      ZF/AC.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>The Axiom of Choice\<close>

theory AC imports ZF begin

text\<open>This definition comes from Halmos (1960), page 59.\<close>
axiomatization where
  AC: "\<lbrakk>a \<in> A;  \<And>x. x \<in> A \<Longrightarrow> (\<exists>y. y \<in> B(x))\<rbrakk> \<Longrightarrow> \<exists>z. z \<in> Pi(A,B)"

(*The same as AC, but no premise @{term"a \<in> A"}*)
lemma AC_Pi: "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> (\<exists>y. y \<in> B(x))\<rbrakk> \<Longrightarrow> \<exists>z. z \<in> Pi(A,B)"
apply (case_tac "A=0")
apply (simp add: Pi_empty1)
(*The non-trivial case*)
apply (blast intro: AC)
done

(*Using dtac, this has the advantage of DELETING the universal quantifier*)
lemma AC_ball_Pi: "\<forall>x \<in> A. \<exists>y. y \<in> B(x) \<Longrightarrow> \<exists>y. y \<in> Pi(A,B)"
apply (rule AC_Pi)
apply (erule bspec, assumption)
done

lemma AC_Pi_Pow: "\<exists>f. f \<in> (\<Prod>X \<in> Pow(C)-{0}. X)"
apply (rule_tac B1 = "\<lambda>x. x" in AC_Pi [THEN exE])
apply (erule_tac [2] exI, blast)
done

lemma AC_func:
     "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> (\<exists>y. y \<in> x)\<rbrakk> \<Longrightarrow> \<exists>f \<in> A->\<Union>(A). \<forall>x \<in> A. f`x \<in> x"
apply (rule_tac B1 = "\<lambda>x. x" in AC_Pi [THEN exE])
prefer 2 apply (blast dest: apply_type intro: Pi_type, blast)
done

lemma non_empty_family: "\<lbrakk>0 \<notin> A;  x \<in> A\<rbrakk> \<Longrightarrow> \<exists>y. y \<in> x"
by (subgoal_tac "x \<noteq> 0", blast+)

lemma AC_func0: "0 \<notin> A \<Longrightarrow> \<exists>f \<in> A->\<Union>(A). \<forall>x \<in> A. f`x \<in> x"
apply (rule AC_func)
apply (simp_all add: non_empty_family)
done

lemma AC_func_Pow: "\<exists>f \<in> (Pow(C)-{0}) -> C. \<forall>x \<in> Pow(C)-{0}. f`x \<in> x"
apply (rule AC_func0 [THEN bexE])
apply (rule_tac [2] bexI)
prefer 2 apply assumption
apply (erule_tac [2] fun_weaken_type, blast+)
done

lemma AC_Pi0: "0 \<notin> A \<Longrightarrow> \<exists>f. f \<in> (\<Prod>x \<in> A. x)"
apply (rule AC_Pi)
apply (simp_all add: non_empty_family)
done

end


theory SelfInv imports Main begin

definition self_inv :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "self_inv f \<equiv> \<forall>x. f (f x) = x"

lemma self_inv_self_inv_iff[rule_format]: "self_inv f \<Longrightarrow> f (f x) = x"
  apply(unfold self_inv_def)
  apply(force)
  done

lemma self_inv_comp: "self_inv f \<Longrightarrow> f \<circ> f = id"
  apply(unfold self_inv_def)
  apply(auto)
  done

lemma self_inv_bij: "self_inv f \<Longrightarrow> bij f"
  apply(unfold self_inv_def)
  apply(unfold bij_def)
  apply(rule conjI)
  apply(metis inj_def)
  apply(metis surj_def)
  done

lemma self_inv_flip: "\<lbrakk> self_inv f \<rbrakk> \<Longrightarrow> f y = x \<longleftrightarrow> y = f x"
  apply(frule self_inv_bij)
  apply(drule bij_is_inj)
  apply(unfold inj_def)
  apply(drule_tac x="y" in spec)
  apply(drule_tac x="f x" in spec)
  apply(unfold self_inv_def)
  apply(force)
  done

lemma ex_self_invI: "\<lbrakk> self_inv f; \<exists>y. Q y \<rbrakk> \<Longrightarrow> \<exists>x. Q (f x)"
  apply(drule self_inv_bij)
  apply(drule bij_is_surj)
  apply(unfold surj_def)
  apply(clarify)
  apply(drule_tac x=y in spec)
  apply(elim exE)
  apply(rule_tac x=x in exI)
  apply(simp)
  done

lemma lt_length_append_iff[rule_format]: "i < length xs \<longrightarrow> P ((xs@ys)!i) = P (xs!i)"
  apply(induct ys)
  apply(force)
  apply(simp add: nth_append)
  done

lemma map_self_inv: "self_inv f \<Longrightarrow> self_inv (map f)"
  apply(unfold self_inv_def)
  apply(auto iff:lt_length_append_iff)
  done

lemma rev_self_inv: "self_inv rev"
  apply(unfold self_inv_def)
  apply(auto)
  done

lemma self_inv_image_subsetI: "\<lbrakk> self_inv f; x \<subseteq> y; fx = f ` x \<rbrakk> \<Longrightarrow> fx \<subseteq> f ` y"
  apply(frule self_inv_bij)
  apply(unfold self_inv_def)
  apply(auto)
  done

lemma image_self_inv: "self_inv f \<Longrightarrow> self_inv (image f)"
  apply(unfold self_inv_def)
  apply(subst image_comp)
  apply(subst self_inv_comp)
  apply(unfold self_inv_def)
  apply(assumption)
  apply(force)
  done
end


text \<open>Multiplication\<close>
theory Integers_Rep_Mul
imports Integers_Rep_Base
begin

definition "Int_Rep_mul x y \<equiv>
  if x = Int_Rep_zero \<or> y = Int_Rep_zero then Int_Rep_zero
  else Int_Rep_rec
    (\<lambda>m. Int_Rep_rec (\<lambda>n. Int_Rep_nonneg (m * n)) (\<lambda>n. Int_Rep_neg (m * n)) y)
    (\<lambda>m. Int_Rep_rec (\<lambda>n. Int_Rep_neg (m * n)) (\<lambda>n. Int_Rep_nonneg (m * n)) y)
    x"

lemma Int_Rep_zero_mul_eq [simp]:
  "Int_Rep_mul Int_Rep_zero x = Int_Rep_zero"
  unfolding Int_Rep_mul_def Int_Rep_zero_def by simp

lemma Int_Rep_nonneg_mul_nonneg_eq [simp]:
  assumes "n : Nat" "m : Nat"
  shows "Int_Rep_mul (Int_Rep_nonneg n) (Int_Rep_nonneg m) = Int_Rep_nonneg (n * m)"
  unfolding Int_Rep_mul_def Int_Rep_zero_def by simp

lemma Int_Rep_nonneg_mul_neg_eq [simp]:
  assumes "n : Nat" "m : Nat"
  and "n \<noteq> 0"
  shows "Int_Rep_mul (Int_Rep_nonneg n) (Int_Rep_neg m) = Int_Rep_neg (n * m)"
  using assms unfolding Int_Rep_mul_def Int_Rep_zero_def by simp

lemma Int_Rep_neg_mul_nonneg_eq [simp]:
  assumes "n : Nat" "m : Nat"
  and "m \<noteq> 0"
  shows "Int_Rep_mul (Int_Rep_neg n) (Int_Rep_nonneg m) = Int_Rep_neg (n * m)"
  using assms unfolding Int_Rep_mul_def Int_Rep_zero_def by simp

lemma Int_Rep_neg_mul_neg_eq [simp]:
  assumes "n : Nat" "m : Nat"
  shows "Int_Rep_mul (Int_Rep_neg n) (Int_Rep_neg m) = Int_Rep_nonneg (n * m)"
  using assms unfolding Int_Rep_mul_def Int_Rep_zero_def by simp

lemma Int_Rep_mul_zero_eq [simp]:
  "x : Int_Rep \<Longrightarrow> Int_Rep_mul x Int_Rep_zero = Int_Rep_zero"
  unfolding Int_Rep_mul_def Int_Rep_zero_def by auto

lemma Int_Rep_mul_type [type]:
  "Int_Rep_mul : Int_Rep \<Rightarrow> Int_Rep \<Rightarrow> Int_Rep"
proof -
  {
    fix n m assume n_m_assms: "n \<in> \<nat>" "m \<in> \<nat>" "m \<noteq> 0"
    then have nonneg_neg:
      "Int_Rep_mul (Int_Rep_nonneg n) (Int_Rep_neg m) : Int_Rep"
    proof (cases n rule: mem_natE)
      case (succ n)
      with n_m_assms have "succ n * m \<in> \<nat> \<setminus> {0}"
        using Nat_mul_ne_zero_if_ne_zero_if_ne_zero by auto
      with succ show ?thesis by auto
    qed (auto simp: Int_Rep_zero_def[symmetric])

    from n_m_assms have "m \<in> \<nat> \<setminus> {0}" by simp
    with \<open>m \<in> \<nat>\<close> \<open>m \<noteq> 0\<close> have
      "Int_Rep_mul (Int_Rep_neg m) (Int_Rep_nonneg n) : Int_Rep"
    proof (cases n rule: mem_natE)
      case (succ n)
      with n_m_assms have "m * succ n \<in> \<nat> \<setminus> {0}"
        using Nat_mul_ne_zero_if_ne_zero_if_ne_zero by auto
      with succ show ?thesis by auto
    qed (auto simp: Int_Rep_zero_def[symmetric])
    note this nonneg_neg
  }
  note this[intro!]
  show ?thesis by (intro Dep_fun_typeI, erule Int_RepE; erule Int_RepE)
    (auto simp: Int_Rep_zero_def)
qed

lemma Int_Rep_one_mul_eq [simp]: "x : Int_Rep \<Longrightarrow> Int_Rep_mul Int_Rep_one x = x"
  unfolding Int_Rep_one_def
  by (elim Int_RepE) (auto simp: nat_zero_ne_one[symmetric])

lemma Int_Rep_mul_one_eq [simp]: "x : Int_Rep \<Longrightarrow> Int_Rep_mul x Int_Rep_one = x"
  unfolding Int_Rep_one_def
  by (elim Int_RepE) (auto simp: nat_zero_ne_one[symmetric])

lemma Int_Rep_mul_assoc:
  assumes "x : Int_Rep" "y : Int_Rep" "z : Int_Rep"
  shows "Int_Rep_mul (Int_Rep_mul x y) z = Int_Rep_mul x (Int_Rep_mul y z)"
  (*TODO: ugly proof*)
  unfolding Int_Rep_mul_def
  by (rule Int_RepE[OF \<open>x : _\<close>];
    rule Int_RepE[OF \<open>y : _\<close>];
    rule Int_RepE[OF \<open>z : _\<close>])
    (auto 0 2 simp: Nat_mul_assoc Int_Rep_zero_def Nat_mul_eq_zero_iff)

end