(* author: R. Thiemann *)

section \<open>The Sunflower Lemma\<close>

text \<open>We formalize the proof of the sunflower lemma of Erd\H{o}s and Rado~\<^cite>\<open>"erdos_rado"\<close>,
as it is presented in the textbook~\<^cite>\<open>\<open>Chapter~6\<close> in "book"\<close>.
We further integrate Exercise 6.2 from the textbook,
which provides a lower bound on the existence of sunflowers.\<close>

theory Erdos_Rado_Sunflower
  imports
    Sunflower
begin

text \<open>When removing an element from all subsets, then one can afterwards
  add these elements to a sunflower and get a new sunflower.\<close>

lemma sunflower_remove_element_lift:
  assumes S: "S \<subseteq> { A - {a} | A . A \<in> F \<and> a \<in> A}"
    and sf: "sunflower S"
  shows "\<exists> Sa. sunflower Sa \<and> Sa \<subseteq> F \<and> card Sa = card S \<and> Sa = insert a ` S"
proof (intro exI[of _ "insert a ` S"] conjI refl)
  let ?Sa = "insert a ` S"
  {
    fix B
    assume "B \<in> ?Sa"
    then obtain C where C: "C \<in> S" and B: "B = insert a C"
      by auto
    from C S obtain T where "T \<in> F" "a \<in> T" "C = T - {a}"
      by auto
    with B have "B = T" by auto
    with \<open>T \<in> F\<close> have "B \<in> F" by auto
  }
  thus SaF: "?Sa \<subseteq> F" by auto
  have inj: "inj_on (insert a) S" using S
    by (intro inj_on_inverseI[of _ "\<lambda> B. B - {a}"], auto)
  thus "card ?Sa = card S" by (rule card_image)
  show "sunflower ?Sa" unfolding sunflower_def
  proof (intro allI, intro impI)
    fix x
    assume "\<exists>C D. C \<in> ?Sa \<and> D \<in> ?Sa \<and> C \<noteq> D \<and> x \<in> C \<and> x \<in> D"
    then obtain C D where *: "C \<in> ?Sa" "D \<in> ?Sa" "C \<noteq> D" "x \<in> C" "x \<in> D"
      by auto
    from *(1-2) obtain C' D' where
      **: "C' \<in> S" "D' \<in> S" "C = insert a C'" "D = insert a D'"
      by auto
    with \<open>C \<noteq> D\<close> inj have CD': "C' \<noteq> D'" by auto
    show "\<forall>E. E \<in> ?Sa \<longrightarrow> x \<in> E"
    proof (cases "x = a")
      case False
      with * ** have "x \<in> C'" "x \<in> D'" by auto
      with ** CD' have "\<exists>C D. C \<in> S \<and> D \<in> S \<and> C \<noteq> D \<and> x \<in> C \<and> x \<in> D" by auto
      from sf[unfolded sunflower_def, rule_format, OF this]
      show ?thesis by auto
    qed auto
  qed
qed

text \<open>The sunflower-lemma of Erd\H{o}s and Rado:
  if a set has a certain size and all elements
  have the same cardinality, then a sunflower exists.\<close>

lemma Erdos_Rado_sunflower_same_card:
  assumes "\<forall> A \<in> F. finite A \<and> card A = k"
    and "card F > (r - 1)^k * fact k"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> {} \<notin> S"
  using assms
proof (induct k arbitrary: F)
  case 0
  hence "F = {{}} \<or> F = {}" "card F \<ge> 2" by auto
  hence False by auto
  thus ?case by simp
next
  case (Suc k F)
  define pd_sub :: "'a set set \<Rightarrow> nat \<Rightarrow> bool" where
    "pd_sub = (\<lambda> G t. G \<subseteq> F \<and> card G = t \<and> pairwise disjnt G \<and> {} \<notin> G)"
  show ?case
  proof (cases "\<exists> t G. pd_sub G t \<and> t \<ge> r")
    case True
    then obtain t G where pd_sub: "pd_sub G t" and t: "t \<ge> r" by auto
    from pd_sub[unfolded pd_sub_def] pairwise_disjnt_imp_sunflower
    have *: "G \<subseteq> F" "card G = t" "sunflower G" "{} \<notin> G" by auto
    from t \<open>card G = t\<close> obtain H where "H \<subseteq> G" "card H = r"
      by (metis obtain_subset_with_card_n)
    with sunflower_subset[OF \<open>H \<subseteq> G\<close>] * show ?thesis by blast
  next
    case False
    define P where "P = (\<lambda> t. \<exists> G. pd_sub G t)"
    have ex: "\<exists> t. P t" unfolding P_def
      by (intro exI[of _ 0] exI[of _ "{}"], auto simp: pd_sub_def)
    have large': "\<And> t. P t \<Longrightarrow> t < r" using False unfolding P_def by auto
    hence large: "\<And> t. P t \<Longrightarrow> t \<le> r" by fastforce
    define t where "t = (GREATEST t. P t)"
    from GreatestI_ex_nat[OF ex large, folded t_def] have Pt: "P t" .
    from Greatest_le_nat[of P, OF _ large]
    have greatest: "\<And> s. P s \<Longrightarrow> s \<le> t" unfolding t_def by auto
    from large'[OF Pt] have tr: "t \<le> r - 1" by simp
    from Pt[unfolded P_def pd_sub_def] obtain G where
      cardG: "card G = t" and
      disj: "pairwise disjnt G" and
      GF: "G \<subseteq> F"
      by blast
    define A where "A = (\<Union> G)"
    from Suc(3) have "card F > 0" by simp
    hence "finite F" by (rule card_ge_0_finite)
    from GF \<open>finite F\<close> have finG: "finite G" by (rule finite_subset)
    have "card (\<Union> G) \<le> sum card G"
      using card_Union_le_sum_card by blast
    also have "\<dots> \<le> of_nat (card G) * Suc k"
      by (metis GF Suc.prems(1) le_Suc_eq subsetD sum_bounded_above)
    also have "\<dots> \<le> (r - 1) * Suc k"
      using tr[folded cardG] by (metis id_apply mult_le_mono1 of_nat_eq_id)
    finally have cardA: "card A \<le> (r - 1) * Suc k" unfolding A_def .
    {
      fix B
      assume *: "B \<in> F"
      with Suc(2) have nE: "B \<noteq> {}" by auto
      from Suc(2) have eF: "{} \<notin> F" by auto
      have "B \<inter> A \<noteq> {}"
      proof
        assume dis: "B \<inter> A = {}"
        hence disj: "pairwise disjnt ({B} \<union> G)"  using disj unfolding A_def
          by (smt (verit, ccfv_SIG) Int_commute Un_iff
              Union_disjoint disjnt_def pairwise_def singleton_iff)
        from nE dis have "B \<notin> G" unfolding A_def by auto
        with finG have c: "card ({B} \<union> G) = Suc t" by (simp add: cardG)
        have "P (Suc t)" unfolding P_def pd_sub_def
          by (intro exI[of _ "{B} \<union> G"], insert eF disj c * GF, auto)
        with greatest show False by force
      qed
    } note overlap = this
    have "F \<noteq> {}" using Suc(2-) by auto
    with overlap have Ane: "A \<noteq> {}" unfolding A_def by auto
    have "finite A" unfolding A_def using finG Suc(2-) GF by auto
    let ?g = "\<lambda> B x. x \<in> B \<inter> A"
    define f where "f = (\<lambda> B. SOME x. ?g B x)"
    have "f \<in> F \<rightarrow> A"
    proof
      fix B
      assume "B \<in> F"
      from overlap[OF this] have "\<exists> x. ?g B x" unfolding A_def by auto
      from someI_ex[OF this] show "f B \<in> A" unfolding f_def by auto
    qed
    from pigeonhole_card[OF this \<open>finite F\<close> \<open>finite A\<close> Ane]
    obtain a where a: "a \<in> A"
      and le: "card F \<le> card (f -` {a} \<inter> F) * card A" by auto
    {
      fix S
      assume "S \<in> F" "f S \<in> {a}"
      with someI_ex[of "?g S"] a overlap[OF this(1)]
      have "a \<in> S" unfolding f_def by auto
    } note FaS = this
    let ?F = "{S - {a} | S . S \<in> F \<and> f S \<in> {a}}"
    from cardA have "((r - 1) ^ k * fact k) * card A \<le> ((r - 1) ^ k * fact k) * ((r - 1) * Suc k)"
      by simp
    also have "\<dots> = (r - 1) ^ (Suc k) * fact (Suc k)"
      by (metis (no_types, lifting) fact_Suc mult.assoc mult.commute of_nat_id power_Suc2)
    also have "\<dots> < card (f -` {a} \<inter> F) * card A"
      using Suc(3) le by auto
    also have "f -` {a} \<inter> F = {S \<in> F. f S \<in> {a}}" by auto
    also have "card \<dots> = card ((\<lambda> S. S - {a}) ` {S \<in> F. f S \<in> {a}})"
      by (subst card_image; intro inj_onI refl, insert FaS) auto
    also have "(\<lambda> S. S - {a}) ` {S \<in> F. f S \<in> {a}} = ?F" by auto
    finally have lt: "(r - 1) ^ k * fact k < card ?F" by simp
    have "\<forall> A \<in> ?F. finite A \<and> card A = k" using Suc(2) FaS by auto
    from Suc(1)[OF this lt] obtain S
      where "sunflower S" "card S = r" "S \<subseteq> ?F" by auto
    from \<open>S \<subseteq> ?F\<close> FaS have "S \<subseteq> {A - {a} |A. A \<in> F \<and> a \<in> A}" by auto
    from sunflower_remove_element_lift[OF this \<open>sunflower S\<close>] \<open>card S = r\<close>
    show ?thesis by auto
  qed
qed

text \<open>Using @{thm [source] sunflower_card_subset_lift} we can easily
  replace the condition that the cardinality is exactly @{term k}
  by the requirement that the cardinality is at most @{term k}.
  However, then @{term "{} \<notin> S"} cannot be ensured.
  Consider @{term "(r :: nat) = 1 \<and> (k :: nat) > 0 \<and> F = {{}}"}.\<close>

lemma Erdos_Rado_sunflower:
  assumes "\<forall> A \<in> F. finite A \<and> card A \<le> k"
    and "card F > (r - 1)^k * fact k"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r"
  by (rule sunflower_card_subset_lift[OF _ assms],
      metis Erdos_Rado_sunflower_same_card)

text \<open>We further provide a lower bound on the existence of sunflowers,
i.e., Exercise 6.2 of the textbook~\<^cite>\<open>"book"\<close>.
To be more precise, we prove that there is a set of sets of cardinality
@{term \<open>(r - 1 :: nat)^k\<close>}, where each element is a set of cardinality
@{term k}, such that there is no subset which is a sunflower with cardinality
of at least @{term r}.\<close>

lemma sunflower_lower_bound:
  assumes inf: "infinite (UNIV :: 'a set)"
    and r: "r \<noteq> 0"
    and rk: "r = 1 \<Longrightarrow> k \<noteq> 0"
  shows "\<exists> F.
    card F = (r - 1)^k \<and> finite F \<and>
    (\<forall> A \<in> F. finite (A :: 'a set) \<and> card A = k) \<and>
    (\<nexists> S. S \<subseteq> F \<and> sunflower S \<and> card S \<ge> r)"
proof (cases "r = 1")
  case False
  with r have r: "r > 1" by auto
  show ?thesis
  proof (induct k)
    case 0
    have id: "S \<subseteq> {{}} \<longleftrightarrow> (S = {} \<or> S = {{}})" for S :: "'a set set" by auto
    show ?case using r
      by (intro exI[of _ "{{}}"], auto simp: id)
  next
    case (Suc k)
    then obtain F where
      cardF: "card F = (r - 1) ^ k" and
      fin: "finite F" and
      AF: "\<And> A. (A :: 'a set) \<in> F \<Longrightarrow> finite A \<and> card A = k" and
      sf: "\<not> (\<exists>S\<subseteq>F. sunflower S \<and> r \<le> card S)"
      by metis
    text \<open>main idea: get @{term "k-1 :: nat"} fresh elements
      and add one of these to all elements of F\<close>
    have "finite (\<Union> F)" using fin AF by simp
    hence "infinite (UNIV - \<Union> F)" using inf by simp
    from infinite_arbitrarily_large[OF this, of "r - 1"]
    obtain New where New: "finite New" "card New = r - 1"
      "New \<inter> \<Union> F = {}" by auto
    define G where "G = (\<lambda> (A, a). insert a A) ` (F \<times> New)"
    show ?case
    proof (intro exI[of _ G] conjI)
      show "finite G" using New fin unfolding G_def by simp
      have "card G = card (F \<times> New)" unfolding G_def
      proof ((subst card_image; (intro refl)?), intro inj_onI, clarsimp, goal_cases)
        case (1 A a B b)
        hence ab: "a = b" using New by auto
        from 1(1) have "insert a A - {a} = insert b B - {a}" by simp
        also have "insert a A - {a} = A" using New 1 by auto
        also have "insert b B - {a} = B" using New 1 ab[symmetric] by auto
        finally show ?case using ab by auto
      qed
      also have "\<dots> = card F * card New" using New fin by auto
      finally show "card G = (r - 1) ^ Suc k"
        unfolding cardF New by simp
      {
        fix B
        assume "B \<in> G"
        then obtain a A where G: "a \<in> New" "A \<in> F" "B = insert a A"
          unfolding G_def by auto
        with AF[of A] New have "finite B" "card B = Suc k"
          by (auto simp: card_insert_if)
      }
      thus "\<forall>A\<in>G. finite A \<and> card A = Suc k" by auto
      show "\<not> (\<exists>S\<subseteq>G. sunflower S \<and> r \<le> card S)"
      proof (intro notI, elim exE conjE)
        fix S
        assume *: "S \<subseteq> G" "sunflower S" "r \<le> card S"
        define g where "g B = (SOME a. a \<in> New \<and> a \<in> B)" for B
        {
          fix B
          assume "B \<in> S"
          with \<open>S \<subseteq> G\<close> have "B \<in> G" by auto
          hence "\<exists> a. a \<in> New \<and> a \<in> B" unfolding G_def by auto
          from someI_ex[OF this, folded g_def]
          have "g B \<in> New" "g B \<in> B" by auto
        } note gB = this
        have "card (g ` S) \<le> card New"
          by (rule card_mono, insert New gB, auto)
        also have "\<dots> < r" unfolding New using r by simp
        also have "\<dots> \<le> card S" by fact
        finally have "card (g ` S) < card S" .
        from pigeonhole[OF this] have "\<not> inj_on g S" .
        then obtain B1 B2 where B12: "B1 \<in> S" "B2 \<in> S" "B1 \<noteq> B2" "g B1 = g B2"
          unfolding inj_on_def by auto
        define a where "a = g B2"
        from B12 gB[of B1] gB[of B2] have a: "a \<in> New" "a \<in> B1" "a \<in> B2"
          unfolding a_def by auto
        with B12 have "\<exists>B1 B2. B1 \<in> S \<and> B2 \<in> S \<and> B1 \<noteq> B2 \<and> a \<in> B1 \<and> a \<in> B2"
          unfolding a_def by blast
        from \<open>sunflower S\<close>[unfolded sunflower_def, rule_format, OF this]
        have aS: "B \<in> S \<Longrightarrow> a \<in> B" for B by auto
        define h where "h B = B - {a}" for B
        define T where "T = h ` S"
        have "\<exists>S\<subseteq>F. sunflower S \<and> r \<le> card S"
        proof (intro exI[of _ T] conjI)
          {
            fix B
            assume "B \<in> S"
            have hB: "h B = B - {a}"
              unfolding h_def T_def by auto
            from aS \<open>B \<in> S\<close> have aB: "a \<in> B" by auto
            from \<open>B \<in> S\<close> \<open>S \<subseteq> G\<close> obtain a' A where AF: "A \<in> F"
              and B: "B = insert a' A"
              and a': "a' \<in> New" unfolding G_def by force
            from aB B a' New AF a(1) hB AF have "insert a (h B) = B" "h B = A" by auto
            hence "insert a (h B) = B" "h B \<in> F" "insert a (h B) \<in> S" using AF \<open>B \<in> S\<close> by auto
          } note main = this
          have CTS: "C \<in> T \<Longrightarrow> insert a C \<in> S" for C using main unfolding T_def by force
          show "T \<subseteq> F" unfolding T_def using main by auto
          have "r \<le> card S" by fact
          also have "\<dots> = card T" unfolding T_def
            by (subst card_image, intro inj_on_inverseI[of _ "insert a"], insert main, auto)
          finally show "r \<le> card T" .
          show "sunflower T" unfolding sunflower_def
          proof (intro allI impI, elim exE conjE, goal_cases)
            case (1 x C C1 C2)
            from CTS[OF \<open>C1 \<in> T\<close>] CTS[OF \<open>C2 \<in> T\<close>] CTS[OF \<open>C \<in> T\<close>]
            have *: "insert a C1 \<in> S" "insert a C2 \<in> S" "insert a C \<in> S" by auto
            from 1 have "insert a C1 \<noteq> insert a C2" using main
              unfolding T_def by auto
            hence "\<exists>A B. A \<in> S \<and> B \<in> S \<and> A \<noteq> B \<and> x \<in> A \<and> x \<in> B"
              using * 1 by auto
            from \<open>sunflower S\<close>[unfolded sunflower_def, rule_format, OF this *(3)]
            have "x \<in> insert a C" .
            with 1 show "x \<in> C" unfolding T_def h_def by auto
          qed
        qed
        with sf
        show False ..
      qed
    qed
  qed
next
  case r: True
  with rk have "k \<noteq> 0" by auto
  then obtain l where k: "k = Suc l" by (cases k, auto)
  show ?thesis unfolding r k
    by (intro exI[of _ "{}"], auto)
qed

text \<open>The difference between the lower and the
upper bound on the existence of sunflowers as they have been formalized
is @{term \<open>fact k\<close>}. There is more recent work with tighter bounds
\<^cite>\<open>"sunflower_new"\<close>, but we only integrate the initial
result of Erd\H{o}s and Rado in this theory.\<close>

text \<open>We further provide the Erd\H{o}s Rado lemma
  lifted to obtain non-empty cores or cores of arbitrary cardinality.\<close>

lemma Erdos_Rado_sunflower_card_core:
  assumes "finite E"
    and "\<forall> A \<in> F. A \<subseteq> E \<and> s \<le> card A \<and> card A \<le> k"
    and "card F > (card E choose s) * (r - 1)^k * fact k"
    and "s \<noteq> 0"
    and "r \<noteq> 0"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> card (\<Inter> S) \<ge> s"
  by (rule sunflower_card_core_lift[OF assms(1) _ assms(2) _ assms(4-5),
        of "(r - 1)^k * fact k"],
      rule Erdos_Rado_sunflower, insert assms(3), auto simp: ac_simps)

lemma Erdos_Rado_sunflower_nonempty_core:
  assumes "finite E"
    and "\<forall> A \<in> F. A \<subseteq> E \<and> card A \<le> k"
    and "{} \<notin> F"
    and "card F > card E * (r - 1)^k * fact k"
  shows "\<exists> S. S \<subseteq> F \<and> sunflower S \<and> card S = r \<and> \<Inter> S \<noteq> {}"
  by (rule sunflower_nonempty_core_lift[OF assms(1)
      _ assms(2-3), of "(r - 1)^k * fact k"],
      rule Erdos_Rado_sunflower, insert assms(4), auto simp: ac_simps)

end


(*  Title:      HOL/Hahn_Banach/Vector_Space.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Vector spaces\<close>

theory Vector_Space
imports Complex_Main Bounds
begin

subsection \<open>Signature\<close>

text \<open>
  For the definition of real vector spaces a type @{typ 'a} of the sort
  \<open>{plus, minus, zero}\<close> is considered, on which a real scalar multiplication
  \<open>\<cdot>\<close> is declared.
\<close>

consts
  prod :: "real \<Rightarrow> 'a::{plus,minus,zero} \<Rightarrow> 'a"  (infixr "\<cdot>" 70)

subsection \<open>Vector space laws\<close>

text \<open>
  A \<^emph>\<open>vector space\<close> is a non-empty set \<open>V\<close> of elements from @{typ 'a} with the
  following vector space laws: The set \<open>V\<close> is closed under addition and scalar
  multiplication, addition is associative and commutative; \<open>- x\<close> is the
  inverse of \<open>x\<close> wrt.\ addition and \<open>0\<close> is the neutral element of addition.
  Addition and multiplication are distributive; scalar multiplication is
  associative and the real number \<open>1\<close> is the neutral element of scalar
  multiplication.
\<close>

locale vectorspace =
  fixes V
  assumes non_empty [iff, intro?]: "V \<noteq> {}"
    and add_closed [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y \<in> V"
    and mult_closed [iff]: "x \<in> V \<Longrightarrow> a \<cdot> x \<in> V"
    and add_assoc: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x + y) + z = x + (y + z)"
    and add_commute: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y = y + x"
    and diff_self [simp]: "x \<in> V \<Longrightarrow> x - x = 0"
    and add_zero_left [simp]: "x \<in> V \<Longrightarrow> 0 + x = x"
    and add_mult_distrib1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<cdot> (x + y) = a \<cdot> x + a \<cdot> y"
    and add_mult_distrib2: "x \<in> V \<Longrightarrow> (a + b) \<cdot> x = a \<cdot> x + b \<cdot> x"
    and mult_assoc: "x \<in> V \<Longrightarrow> (a * b) \<cdot> x = a \<cdot> (b \<cdot> x)"
    and mult_1 [simp]: "x \<in> V \<Longrightarrow> 1 \<cdot> x = x"
    and negate_eq1: "x \<in> V \<Longrightarrow> - x = (- 1) \<cdot> x"
    and diff_eq1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y = x + - y"
begin

lemma negate_eq2: "x \<in> V \<Longrightarrow> (- 1) \<cdot> x = - x"
  by (rule negate_eq1 [symmetric])

lemma negate_eq2a: "x \<in> V \<Longrightarrow> -1 \<cdot> x = - x"
  by (simp add: negate_eq1)

lemma diff_eq2: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + - y = x - y"
  by (rule diff_eq1 [symmetric])

lemma diff_closed [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y \<in> V"
  by (simp add: diff_eq1 negate_eq1)

lemma neg_closed [iff]: "x \<in> V \<Longrightarrow> - x \<in> V"
  by (simp add: negate_eq1)

lemma add_left_commute:
  "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> x + (y + z) = y + (x + z)"
proof -
  assume xyz: "x \<in> V"  "y \<in> V"  "z \<in> V"
  then have "x + (y + z) = (x + y) + z"
    by (simp only: add_assoc)
  also from xyz have "\<dots> = (y + x) + z" by (simp only: add_commute)
  also from xyz have "\<dots> = y + (x + z)" by (simp only: add_assoc)
  finally show ?thesis .
qed

lemmas add_ac = add_assoc add_commute add_left_commute

text \<open>
  The existence of the zero element of a vector space follows from the
  non-emptiness of carrier set.
\<close>

lemma zero [iff]: "0 \<in> V"
proof -
  from non_empty obtain x where x: "x \<in> V" by blast
  then have "0 = x - x" by (rule diff_self [symmetric])
  also from x x have "\<dots> \<in> V" by (rule diff_closed)
  finally show ?thesis .
qed

lemma add_zero_right [simp]: "x \<in> V \<Longrightarrow>  x + 0 = x"
proof -
  assume x: "x \<in> V"
  from this and zero have "x + 0 = 0 + x" by (rule add_commute)
  also from x have "\<dots> = x" by (rule add_zero_left)
  finally show ?thesis .
qed

lemma mult_assoc2: "x \<in> V \<Longrightarrow> a \<cdot> b \<cdot> x = (a * b) \<cdot> x"
  by (simp only: mult_assoc)

lemma diff_mult_distrib1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<cdot> (x - y) = a \<cdot> x - a \<cdot> y"
  by (simp add: diff_eq1 negate_eq1 add_mult_distrib1 mult_assoc2)

lemma diff_mult_distrib2: "x \<in> V \<Longrightarrow> (a - b) \<cdot> x = a \<cdot> x - (b \<cdot> x)"
proof -
  assume x: "x \<in> V"
  have " (a - b) \<cdot> x = (a + - b) \<cdot> x"
    by simp
  also from x have "\<dots> = a \<cdot> x + (- b) \<cdot> x"
    by (rule add_mult_distrib2)
  also from x have "\<dots> = a \<cdot> x + - (b \<cdot> x)"
    by (simp add: negate_eq1 mult_assoc2)
  also from x have "\<dots> = a \<cdot> x - (b \<cdot> x)"
    by (simp add: diff_eq1)
  finally show ?thesis .
qed

lemmas distrib =
  add_mult_distrib1 add_mult_distrib2
  diff_mult_distrib1 diff_mult_distrib2

text \<open>\<^medskip> Further derived laws:\<close>

lemma mult_zero_left [simp]: "x \<in> V \<Longrightarrow> 0 \<cdot> x = 0"
proof -
  assume x: "x \<in> V"
  have "0 \<cdot> x = (1 - 1) \<cdot> x" by simp
  also have "\<dots> = (1 + - 1) \<cdot> x" by simp
  also from x have "\<dots> =  1 \<cdot> x + (- 1) \<cdot> x"
    by (rule add_mult_distrib2)
  also from x have "\<dots> = x + (- 1) \<cdot> x" by simp
  also from x have "\<dots> = x + - x" by (simp add: negate_eq2a)
  also from x have "\<dots> = x - x" by (simp add: diff_eq2)
  also from x have "\<dots> = 0" by simp
  finally show ?thesis .
qed

lemma mult_zero_right [simp]: "a \<cdot> 0 = (0::'a)"
proof -
  have "a \<cdot> 0 = a \<cdot> (0 - (0::'a))" by simp
  also have "\<dots> =  a \<cdot> 0 - a \<cdot> 0"
    by (rule diff_mult_distrib1) simp_all
  also have "\<dots> = 0" by simp
  finally show ?thesis .
qed

lemma minus_mult_cancel [simp]: "x \<in> V \<Longrightarrow> (- a) \<cdot> - x = a \<cdot> x"
  by (simp add: negate_eq1 mult_assoc2)

lemma add_minus_left_eq_diff: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - x + y = y - x"
proof -
  assume xy: "x \<in> V"  "y \<in> V"
  then have "- x + y = y + - x" by (simp add: add_commute)
  also from xy have "\<dots> = y - x" by (simp add: diff_eq1)
  finally show ?thesis .
qed

lemma add_minus [simp]: "x \<in> V \<Longrightarrow> x + - x = 0"
  by (simp add: diff_eq2)

lemma add_minus_left [simp]: "x \<in> V \<Longrightarrow> - x + x = 0"
  by (simp add: diff_eq2 add_commute)

lemma minus_minus [simp]: "x \<in> V \<Longrightarrow> - (- x) = x"
  by (simp add: negate_eq1 mult_assoc2)

lemma minus_zero [simp]: "- (0::'a) = 0"
  by (simp add: negate_eq1)

lemma minus_zero_iff [simp]:
  assumes x: "x \<in> V"
  shows "(- x = 0) = (x = 0)"
proof
  from x have "x = - (- x)" by simp
  also assume "- x = 0"
  also have "- \<dots> = 0" by (rule minus_zero)
  finally show "x = 0" .
next
  assume "x = 0"
  then show "- x = 0" by simp
qed

lemma add_minus_cancel [simp]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + (- x + y) = y"
  by (simp add: add_assoc [symmetric])

lemma minus_add_cancel [simp]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - x + (x + y) = y"
  by (simp add: add_assoc [symmetric])

lemma minus_add_distrib [simp]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - (x + y) = - x + - y"
  by (simp add: negate_eq1 add_mult_distrib1)

lemma diff_zero [simp]: "x \<in> V \<Longrightarrow> x - 0 = x"
  by (simp add: diff_eq1)

lemma diff_zero_right [simp]: "x \<in> V \<Longrightarrow> 0 - x = - x"
  by (simp add: diff_eq1)

lemma add_left_cancel:
  assumes x: "x \<in> V" and y: "y \<in> V" and z: "z \<in> V"
  shows "(x + y = x + z) = (y = z)"
proof
  from y have "y = 0 + y" by simp
  also from x y have "\<dots> = (- x + x) + y" by simp
  also from x y have "\<dots> = - x + (x + y)" by (simp add: add.assoc)
  also assume "x + y = x + z"
  also from x z have "- x + (x + z) = - x + x + z" by (simp add: add.assoc)
  also from x z have "\<dots> = z" by simp
  finally show "y = z" .
next
  assume "y = z"
  then show "x + y = x + z" by (simp only:)
qed

lemma add_right_cancel:
    "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (y + x = z + x) = (y = z)"
  by (simp only: add_commute add_left_cancel)

lemma add_assoc_cong:
  "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x' \<in> V \<Longrightarrow> y' \<in> V \<Longrightarrow> z \<in> V
    \<Longrightarrow> x + y = x' + y' \<Longrightarrow> x + (y + z) = x' + (y' + z)"
  by (simp only: add_assoc [symmetric])

lemma mult_left_commute: "x \<in> V \<Longrightarrow> a \<cdot> b \<cdot> x = b \<cdot> a \<cdot> x"
  by (simp add: mult.commute mult_assoc2)

lemma mult_zero_uniq:
  assumes x: "x \<in> V"  "x \<noteq> 0" and ax: "a \<cdot> x = 0"
  shows "a = 0"
proof (rule classical)
  assume a: "a \<noteq> 0"
  from x a have "x = (inverse a * a) \<cdot> x" by simp
  also from \<open>x \<in> V\<close> have "\<dots> = inverse a \<cdot> (a \<cdot> x)" by (rule mult_assoc)
  also from ax have "\<dots> = inverse a \<cdot> 0" by simp
  also have "\<dots> = 0" by simp
  finally have "x = 0" .
  with \<open>x \<noteq> 0\<close> show "a = 0" by contradiction
qed

lemma mult_left_cancel:
  assumes x: "x \<in> V" and y: "y \<in> V" and a: "a \<noteq> 0"
  shows "(a \<cdot> x = a \<cdot> y) = (x = y)"
proof
  from x have "x = 1 \<cdot> x" by simp
  also from a have "\<dots> = (inverse a * a) \<cdot> x" by simp
  also from x have "\<dots> = inverse a \<cdot> (a \<cdot> x)"
    by (simp only: mult_assoc)
  also assume "a \<cdot> x = a \<cdot> y"
  also from a y have "inverse a \<cdot> \<dots> = y"
    by (simp add: mult_assoc2)
  finally show "x = y" .
next
  assume "x = y"
  then show "a \<cdot> x = a \<cdot> y" by (simp only:)
qed

lemma mult_right_cancel:
  assumes x: "x \<in> V" and neq: "x \<noteq> 0"
  shows "(a \<cdot> x = b \<cdot> x) = (a = b)"
proof
  from x have "(a - b) \<cdot> x = a \<cdot> x - b \<cdot> x"
    by (simp add: diff_mult_distrib2)
  also assume "a \<cdot> x = b \<cdot> x"
  with x have "a \<cdot> x - b \<cdot> x = 0" by simp
  finally have "(a - b) \<cdot> x = 0" .
  with x neq have "a - b = 0" by (rule mult_zero_uniq)
  then show "a = b" by simp
next
  assume "a = b"
  then show "a \<cdot> x = b \<cdot> x" by (simp only:)
qed

lemma eq_diff_eq:
  assumes x: "x \<in> V" and y: "y \<in> V" and z: "z \<in> V"
  shows "(x = z - y) = (x + y = z)"
proof
  assume "x = z - y"
  then have "x + y = z - y + y" by simp
  also from y z have "\<dots> = z + - y + y"
    by (simp add: diff_eq1)
  also have "\<dots> = z + (- y + y)"
    by (rule add_assoc) (simp_all add: y z)
  also from y z have "\<dots> = z + 0"
    by (simp only: add_minus_left)
  also from z have "\<dots> = z"
    by (simp only: add_zero_right)
  finally show "x + y = z" .
next
  assume "x + y = z"
  then have "z - y = (x + y) - y" by simp
  also from x y have "\<dots> = x + y + - y"
    by (simp add: diff_eq1)
  also have "\<dots> = x + (y + - y)"
    by (rule add_assoc) (simp_all add: x y)
  also from x y have "\<dots> = x" by simp
  finally show "x = z - y" ..
qed

lemma add_minus_eq_minus:
  assumes x: "x \<in> V" and y: "y \<in> V" and xy: "x + y = 0"
  shows "x = - y"
proof -
  from x y have "x = (- y + y) + x" by simp
  also from x y have "\<dots> = - y + (x + y)" by (simp add: add_ac)
  also note xy
  also from y have "- y + 0 = - y" by simp
  finally show "x = - y" .
qed

lemma add_minus_eq:
  assumes x: "x \<in> V" and y: "y \<in> V" and xy: "x - y = 0"
  shows "x = y"
proof -
  from x y xy have eq: "x + - y = 0" by (simp add: diff_eq1)
  with _ _ have "x = - (- y)"
    by (rule add_minus_eq_minus) (simp_all add: x y)
  with x y show "x = y" by simp
qed

lemma add_diff_swap:
  assumes vs: "a \<in> V"  "b \<in> V"  "c \<in> V"  "d \<in> V"
    and eq: "a + b = c + d"
  shows "a - c = d - b"
proof -
  from assms have "- c + (a + b) = - c + (c + d)"
    by (simp add: add_left_cancel)
  also have "\<dots> = d" using \<open>c \<in> V\<close> \<open>d \<in> V\<close> by (rule minus_add_cancel)
  finally have eq: "- c + (a + b) = d" .
  from vs have "a - c = (- c + (a + b)) + - b"
    by (simp add: add_ac diff_eq1)
  also from vs eq have "\<dots>  = d + - b"
    by (simp add: add_right_cancel)
  also from vs have "\<dots> = d - b" by (simp add: diff_eq2)
  finally show "a - c = d - b" .
qed

lemma vs_add_cancel_21:
  assumes vs: "x \<in> V"  "y \<in> V"  "z \<in> V"  "u \<in> V"
  shows "(x + (y + z) = y + u) = (x + z = u)"
proof
  from vs have "x + z = - y + y + (x + z)" by simp
  also have "\<dots> = - y + (y + (x + z))"
    by (rule add_assoc) (simp_all add: vs)
  also from vs have "y + (x + z) = x + (y + z)"
    by (simp add: add_ac)
  also assume "x + (y + z) = y + u"
  also from vs have "- y + (y + u) = u" by simp
  finally show "x + z = u" .
next
  assume "x + z = u"
  with vs show "x + (y + z) = y + u"
    by (simp only: add_left_commute [of x])
qed

lemma add_cancel_end:
  assumes vs: "x \<in> V"  "y \<in> V"  "z \<in> V"
  shows "(x + (y + z) = y) = (x = - z)"
proof
  assume "x + (y + z) = y"
  with vs have "(x + z) + y = 0 + y" by (simp add: add_ac)
  with vs have "x + z = 0" by (simp only: add_right_cancel add_closed zero)
  with vs show "x = - z" by (simp add: add_minus_eq_minus)
next
  assume eq: "x = - z"
  then have "x + (y + z) = - z + (y + z)" by simp
  also have "\<dots> = y + (- z + z)" by (rule add_left_commute) (simp_all add: vs)
  also from vs have "\<dots> = y"  by simp
  finally show "x + (y + z) = y" .
qed

end

end


(*  Title:      HOL/Groups_Big.thy
    Author:     Tobias Nipkow
    Author:     Lawrence C Paulson
    Author:     Markus Wenzel
    Author:     Jeremy Avigad
*)

section \<open>Big sum and product over finite (non-empty) sets\<close>

theory Groups_Big
  imports Finite_Set Power
begin

subsection \<open>Generic monoid operation over a set\<close>

locale comm_monoid_set = comm_monoid
begin

interpretation comp_fun_commute f
  by standard (simp add: fun_eq_iff left_commute)

interpretation comp?: comp_fun_commute "f \<circ> g"
  by (fact comp_comp_fun_commute)

definition F :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'a"
  where eq_fold: "F g A = Finite_Set.fold (f \<circ> g) \<^bold>1 A"

lemma infinite [simp]: "\<not> finite A \<Longrightarrow> F g A = \<^bold>1"
  by (simp add: eq_fold)

lemma empty [simp]: "F g {} = \<^bold>1"
  by (simp add: eq_fold)

lemma insert [simp]: "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> F g (insert x A) = g x \<^bold>* F g A"
  by (simp add: eq_fold)

lemma remove:
  assumes "finite A" and "x \<in> A"
  shows "F g A = g x \<^bold>* F g (A - {x})"
proof -
  from \<open>x \<in> A\<close> obtain B where B: "A = insert x B" and "x \<notin> B"
    by (auto dest: mk_disjoint_insert)
  moreover from \<open>finite A\<close> B have "finite B" by simp
  ultimately show ?thesis by simp
qed

lemma insert_remove: "finite A \<Longrightarrow> F g (insert x A) = g x \<^bold>* F g (A - {x})"
  by (cases "x \<in> A") (simp_all add: remove insert_absorb)

lemma insert_if: "finite A \<Longrightarrow> F g (insert x A) = (if x \<in> A then F g A else g x \<^bold>* F g A)"
  by (cases "x \<in> A") (simp_all add: insert_absorb)

lemma neutral: "\<forall>x\<in>A. g x = \<^bold>1 \<Longrightarrow> F g A = \<^bold>1"
  by (induct A rule: infinite_finite_induct) simp_all

lemma neutral_const [simp]: "F (\<lambda>_. \<^bold>1) A = \<^bold>1"
  by (simp add: neutral)

lemma union_inter:
  assumes "finite A" and "finite B"
  shows "F g (A \<union> B) \<^bold>* F g (A \<inter> B) = F g A \<^bold>* F g B"
  \<comment> \<open>The reversed orientation looks more natural, but LOOPS as a simprule!\<close>
  using assms
proof (induct A)
  case empty
  then show ?case by simp
next
  case (insert x A)
  then show ?case
    by (auto simp: insert_absorb Int_insert_left commute [of _ "g x"] assoc left_commute)
qed

corollary union_inter_neutral:
  assumes "finite A" and "finite B"
    and "\<forall>x \<in> A \<inter> B. g x = \<^bold>1"
  shows "F g (A \<union> B) = F g A \<^bold>* F g B"
  using assms by (simp add: union_inter [symmetric] neutral)

corollary union_disjoint:
  assumes "finite A" and "finite B"
  assumes "A \<inter> B = {}"
  shows "F g (A \<union> B) = F g A \<^bold>* F g B"
  using assms by (simp add: union_inter_neutral)

lemma union_diff2:
  assumes "finite A" and "finite B"
  shows "F g (A \<union> B) = F g (A - B) \<^bold>* F g (B - A) \<^bold>* F g (A \<inter> B)"
proof -
  have "A \<union> B = A - B \<union> (B - A) \<union> A \<inter> B"
    by auto
  with assms show ?thesis
    by simp (subst union_disjoint, auto)+
qed

lemma subset_diff:
  assumes "B \<subseteq> A" and "finite A"
  shows "F g A = F g (A - B) \<^bold>* F g B"
proof -
  from assms have "finite (A - B)" by auto
  moreover from assms have "finite B" by (rule finite_subset)
  moreover from assms have "(A - B) \<inter> B = {}" by auto
  ultimately have "F g (A - B \<union> B) = F g (A - B) \<^bold>* F g B" by (rule union_disjoint)
  moreover from assms have "A \<union> B = A" by auto
  ultimately show ?thesis by simp
qed

lemma setdiff_irrelevant:
  assumes "finite A"
  shows "F g (A - {x. g x = z}) = F g A"
  using assms by (induct A) (simp_all add: insert_Diff_if)

lemma not_neutral_contains_not_neutral:
  assumes "F g A \<noteq> \<^bold>1"
  obtains a where "a \<in> A" and "g a \<noteq> \<^bold>1"
proof -
  from assms have "\<exists>a\<in>A. g a \<noteq> \<^bold>1"
  proof (induct A rule: infinite_finite_induct)
    case infinite
    then show ?case by simp
  next
    case empty
    then show ?case by simp
  next
    case (insert a A)
    then show ?case by fastforce
  qed
  with that show thesis by blast
qed

lemma cong [fundef_cong]:
  assumes "A = B"
  assumes g_h: "\<And>x. x \<in> B \<Longrightarrow> g x = h x"
  shows "F g A = F h B"
  using g_h unfolding \<open>A = B\<close>
  by (induct B rule: infinite_finite_induct) auto

lemma strong_cong [cong]:
  assumes "A = B" "\<And>x. x \<in> B =simp=> g x = h x"
  shows "F (\<lambda>x. g x) A = F (\<lambda>x. h x) B"
  by (rule cong) (use assms in \<open>simp_all add: simp_implies_def\<close>)

lemma reindex_cong:
  assumes "inj_on l B"
  assumes "A = l ` B"
  assumes "\<And>x. x \<in> B \<Longrightarrow> g (l x) = h x"
  shows "F g A = F h B"
  using assms by (simp add: reindex)

lemma UNION_disjoint:
  assumes "finite I" and "\<forall>i\<in>I. finite (A i)"
    and "\<forall>i\<in>I. \<forall>j\<in>I. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}"
  shows "F g (UNION I A) = F (\<lambda>x. F g (A x)) I"
  apply (insert assms)
  apply (induct rule: finite_induct)
   apply simp
  apply atomize
  apply (subgoal_tac "\<forall>i\<in>Fa. x \<noteq> i")
   prefer 2 apply blast
  apply (subgoal_tac "A x \<inter> UNION Fa A = {}")
   prefer 2 apply blast
  apply (simp add: union_disjoint)
  done

lemma Union_disjoint:
  assumes "\<forall>A\<in>C. finite A" "\<forall>A\<in>C. \<forall>B\<in>C. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
  shows "F g (\<Union>C) = (F \<circ> F) g C"
proof (cases "finite C")
  case True
  from UNION_disjoint [OF this assms] show ?thesis by simp
next
  case False
  then show ?thesis by (auto dest: finite_UnionD intro: infinite)
qed

lemma distrib: "F (\<lambda>x. g x \<^bold>* h x) A = F g A \<^bold>* F h A"
  by (induct A rule: infinite_finite_induct) (simp_all add: assoc commute left_commute)

lemma Sigma:
  "finite A \<Longrightarrow> \<forall>x\<in>A. finite (B x) \<Longrightarrow> F (\<lambda>x. F (g x) (B x)) A = F (case_prod g) (SIGMA x:A. B x)"
  apply (subst Sigma_def)
  apply (subst UNION_disjoint)
     apply assumption
    apply simp
   apply blast
  apply (rule cong)
   apply rule
  apply (simp add: fun_eq_iff)
  apply (subst UNION_disjoint)
     apply simp
    apply simp
   apply blast
  apply (simp add: comp_def)
  done

lemma related:
  assumes Re: "R \<^bold>1 \<^bold>1"
    and Rop: "\<forall>x1 y1 x2 y2. R x1 x2 \<and> R y1 y2 \<longrightarrow> R (x1 \<^bold>* y1) (x2 \<^bold>* y2)"
    and fin: "finite S"
    and R_h_g: "\<forall>x\<in>S. R (h x) (g x)"
  shows "R (F h S) (F g S)"
  using fin by (rule finite_subset_induct) (use assms in auto)

lemma mono_neutral_cong_left:
  assumes "finite T"
    and "S \<subseteq> T"
    and "\<forall>i \<in> T - S. h i = \<^bold>1"
    and "\<And>x. x \<in> S \<Longrightarrow> g x = h x"
  shows "F g S = F h T"
proof-
  have eq: "T = S \<union> (T - S)" using \<open>S \<subseteq> T\<close> by blast
  have d: "S \<inter> (T - S) = {}" using \<open>S \<subseteq> T\<close> by blast
  from \<open>finite T\<close> \<open>S \<subseteq> T\<close> have f: "finite S" "finite (T - S)"
    by (auto intro: finite_subset)
  show ?thesis using assms(4)
    by (simp add: union_disjoint [OF f d, unfolded eq [symmetric]] neutral [OF assms(3)])
qed

lemma mono_neutral_cong_right:
  "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> g x = h x) \<Longrightarrow>
    F g T = F h S"
  by (auto intro!: mono_neutral_cong_left [symmetric])

lemma mono_neutral_left: "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> F g S = F g T"
  by (blast intro: mono_neutral_cong_left)

lemma mono_neutral_right: "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> F g T = F g S"
  by (blast intro!: mono_neutral_left [symmetric])

lemma reindex_bij_betw: "bij_betw h S T \<Longrightarrow> F (\<lambda>x. g (h x)) S = F g T"
  by (auto simp: bij_betw_def reindex)

lemma reindex_bij_witness:
  assumes witness:
    "\<And>a. a \<in> S \<Longrightarrow> i (j a) = a"
    "\<And>a. a \<in> S \<Longrightarrow> j a \<in> T"
    "\<And>b. b \<in> T \<Longrightarrow> j (i b) = b"
    "\<And>b. b \<in> T \<Longrightarrow> i b \<in> S"
  assumes eq:
    "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
  shows "F g S = F h T"
proof -
  have "bij_betw j S T"
    using bij_betw_byWitness[where A=S and f=j and f'=i and A'=T] witness by auto
  moreover have "F g S = F (\<lambda>x. h (j x)) S"
    by (intro cong) (auto simp: eq)
  ultimately show ?thesis
    by (simp add: reindex_bij_betw)
qed

lemma reindex_bij_betw_not_neutral:
  assumes fin: "finite S'" "finite T'"
  assumes bij: "bij_betw h (S - S') (T - T')"
  assumes nn:
    "\<And>a. a \<in> S' \<Longrightarrow> g (h a) = z"
    "\<And>b. b \<in> T' \<Longrightarrow> g b = z"
  shows "F (\<lambda>x. g (h x)) S = F g T"
proof -
  have [simp]: "finite S \<longleftrightarrow> finite T"
    using bij_betw_finite[OF bij] fin by auto
  show ?thesis
  proof (cases "finite S")
    case True
    with nn have "F (\<lambda>x. g (h x)) S = F (\<lambda>x. g (h x)) (S - S')"
      by (intro mono_neutral_cong_right) auto
    also have "\<dots> = F g (T - T')"
      using bij by (rule reindex_bij_betw)
    also have "\<dots> = F g T"
      using nn \<open>finite S\<close> by (intro mono_neutral_cong_left) auto
    finally show ?thesis .
  next
    case False
    then show ?thesis by simp
  qed
qed

lemma reindex_nontrivial:
  assumes "finite A"
    and nz: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<noteq> y \<Longrightarrow> h x = h y \<Longrightarrow> g (h x) = \<^bold>1"
  shows "F g (h ` A) = F (g \<circ> h) A"
proof (subst reindex_bij_betw_not_neutral [symmetric])
  show "bij_betw h (A - {x \<in> A. (g \<circ> h) x = \<^bold>1}) (h ` A - h ` {x \<in> A. (g \<circ> h) x = \<^bold>1})"
    using nz by (auto intro!: inj_onI simp: bij_betw_def)
qed (use \<open>finite A\<close> in auto)

lemma reindex_bij_witness_not_neutral:
  assumes fin: "finite S'" "finite T'"
  assumes witness:
    "\<And>a. a \<in> S - S' \<Longrightarrow> i (j a) = a"
    "\<And>a. a \<in> S - S' \<Longrightarrow> j a \<in> T - T'"
    "\<And>b. b \<in> T - T' \<Longrightarrow> j (i b) = b"
    "\<And>b. b \<in> T - T' \<Longrightarrow> i b \<in> S - S'"
  assumes nn:
    "\<And>a. a \<in> S' \<Longrightarrow> g a = z"
    "\<And>b. b \<in> T' \<Longrightarrow> h b = z"
  assumes eq:
    "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
  shows "F g S = F h T"
proof -
  have bij: "bij_betw j (S - (S' \<inter> S)) (T - (T' \<inter> T))"
    using witness by (intro bij_betw_byWitness[where f'=i]) auto
  have F_eq: "F g S = F (\<lambda>x. h (j x)) S"
    by (intro cong) (auto simp: eq)
  show ?thesis
    unfolding F_eq using fin nn eq
    by (intro reindex_bij_betw_not_neutral[OF _ _ bij]) auto
qed

lemma delta:
  assumes fS: "finite S"
  shows "F (\<lambda>k. if k = a then b k else \<^bold>1) S = (if a \<in> S then b a else \<^bold>1)"
proof -
  let ?f = "(\<lambda>k. if k = a then b k else \<^bold>1)"
  show ?thesis
  proof (cases "a \<in> S")
    case False
    then have "\<forall>k\<in>S. ?f k = \<^bold>1" by simp
    with False show ?thesis by simp
  next
    case True
    let ?A = "S - {a}"
    let ?B = "{a}"
    from True have eq: "S = ?A \<union> ?B" by blast
    have dj: "?A \<inter> ?B = {}" by simp
    from fS have fAB: "finite ?A" "finite ?B" by auto
    have "F ?f S = F ?f ?A \<^bold>* F ?f ?B"
      using union_disjoint [OF fAB dj, of ?f, unfolded eq [symmetric]] by simp
    with True show ?thesis by simp
  qed
qed

lemma delta':
  assumes fin: "finite S"
  shows "F (\<lambda>k. if a = k then b k else \<^bold>1) S = (if a \<in> S then b a else \<^bold>1)"
  using delta [OF fin, of a b, symmetric] by (auto intro: cong)

lemma If_cases:
  fixes P :: "'b \<Rightarrow> bool" and g h :: "'b \<Rightarrow> 'a"
  assumes fin: "finite A"
  shows "F (\<lambda>x. if P x then h x else g x) A = F h (A \<inter> {x. P x}) \<^bold>* F g (A \<inter> - {x. P x})"
proof -
  have a: "A = A \<inter> {x. P x} \<union> A \<inter> -{x. P x}" "(A \<inter> {x. P x}) \<inter> (A \<inter> -{x. P x}) = {}"
    by blast+
  from fin have f: "finite (A \<inter> {x. P x})" "finite (A \<inter> -{x. P x})" by auto
  let ?g = "\<lambda>x. if P x then h x else g x"
  from union_disjoint [OF f a(2), of ?g] a(1) show ?thesis
    by (subst (1 2) cong) simp_all
qed

lemma cartesian_product: "F (\<lambda>x. F (g x) B) A = F (case_prod g) (A \<times> B)"
  apply (rule sym)
  apply (cases "finite A")
   apply (cases "finite B")
    apply (simp add: Sigma)
   apply (cases "A = {}")
    apply simp
   apply simp
   apply (auto intro: infinite dest: finite_cartesian_productD2)
  apply (cases "B = {}")
   apply (auto intro: infinite dest: finite_cartesian_productD1)
  done

lemma inter_restrict:
  assumes "finite A"
  shows "F g (A \<inter> B) = F (\<lambda>x. if x \<in> B then g x else \<^bold>1) A"
proof -
  let ?g = "\<lambda>x. if x \<in> A \<inter> B then g x else \<^bold>1"
  have "\<forall>i\<in>A - A \<inter> B. (if i \<in> A \<inter> B then g i else \<^bold>1) = \<^bold>1" by simp
  moreover have "A \<inter> B \<subseteq> A" by blast
  ultimately have "F ?g (A \<inter> B) = F ?g A"
    using \<open>finite A\<close> by (intro mono_neutral_left) auto
  then show ?thesis by simp
qed

lemma inter_filter:
  "finite A \<Longrightarrow> F g {x \<in> A. P x} = F (\<lambda>x. if P x then g x else \<^bold>1) A"
  by (simp add: inter_restrict [symmetric, of A "{x. P x}" g, simplified mem_Collect_eq] Int_def)

lemma Union_comp:
  assumes "\<forall>A \<in> B. finite A"
    and "\<And>A1 A2 x. A1 \<in> B \<Longrightarrow> A2 \<in> B \<Longrightarrow> A1 \<noteq> A2 \<Longrightarrow> x \<in> A1 \<Longrightarrow> x \<in> A2 \<Longrightarrow> g x = \<^bold>1"
  shows "F g (\<Union>B) = (F \<circ> F) g B"
  using assms
proof (induct B rule: infinite_finite_induct)
  case (infinite A)
  then have "\<not> finite (\<Union>A)" by (blast dest: finite_UnionD)
  with infinite show ?case by simp
next
  case empty
  then show ?case by simp
next
  case (insert A B)
  then have "finite A" "finite B" "finite (\<Union>B)" "A \<notin> B"
    and "\<forall>x\<in>A \<inter> \<Union>B. g x = \<^bold>1"
    and H: "F g (\<Union>B) = (F \<circ> F) g B" by auto
  then have "F g (A \<union> \<Union>B) = F g A \<^bold>* F g (\<Union>B)"
    by (simp add: union_inter_neutral)
  with \<open>finite B\<close> \<open>A \<notin> B\<close> show ?case
    by (simp add: H)
qed

lemma commute: "F (\<lambda>i. F (g i) B) A = F (\<lambda>j. F (\<lambda>i. g i j) A) B"
  unfolding cartesian_product
  by (rule reindex_bij_witness [where i = "\<lambda>(i, j). (j, i)" and j = "\<lambda>(i, j). (j, i)"]) auto

lemma commute_restrict:
  "finite A \<Longrightarrow> finite B \<Longrightarrow>
    F (\<lambda>x. F (g x) {y. y \<in> B \<and> R x y}) A = F (\<lambda>y. F (\<lambda>x. g x y) {x. x \<in> A \<and> R x y}) B"
  by (simp add: inter_filter) (rule commute)

lemma Plus:
  fixes A :: "'b set" and B :: "'c set"
  assumes fin: "finite A" "finite B"
  shows "F g (A <+> B) = F (g \<circ> Inl) A \<^bold>* F (g \<circ> Inr) B"
proof -
  have "A <+> B = Inl ` A \<union> Inr ` B" by auto
  moreover from fin have "finite (Inl ` A)" "finite (Inr ` B)" by auto
  moreover have "Inl ` A \<inter> Inr ` B = {}" by auto
  moreover have "inj_on Inl A" "inj_on Inr B" by (auto intro: inj_onI)
  ultimately show ?thesis
    using fin by (simp add: union_disjoint reindex)
qed

lemma same_carrier:
  assumes "finite C"
  assumes subset: "A \<subseteq> C" "B \<subseteq> C"
  assumes trivial: "\<And>a. a \<in> C - A \<Longrightarrow> g a = \<^bold>1" "\<And>b. b \<in> C - B \<Longrightarrow> h b = \<^bold>1"
  shows "F g A = F h B \<longleftrightarrow> F g C = F h C"
proof -
  have "finite A" and "finite B" and "finite (C - A)" and "finite (C - B)"
    using \<open>finite C\<close> subset by (auto elim: finite_subset)
  from subset have [simp]: "A - (C - A) = A" by auto
  from subset have [simp]: "B - (C - B) = B" by auto
  from subset have "C = A \<union> (C - A)" by auto
  then have "F g C = F g (A \<union> (C - A))" by simp
  also have "\<dots> = F g (A - (C - A)) \<^bold>* F g (C - A - A) \<^bold>* F g (A \<inter> (C - A))"
    using \<open>finite A\<close> \<open>finite (C - A)\<close> by (simp only: union_diff2)
  finally have *: "F g C = F g A" using trivial by simp
  from subset have "C = B \<union> (C - B)" by auto
  then have "F h C = F h (B \<union> (C - B))" by simp
  also have "\<dots> = F h (B - (C - B)) \<^bold>* F h (C - B - B) \<^bold>* F h (B \<inter> (C - B))"
    using \<open>finite B\<close> \<open>finite (C - B)\<close> by (simp only: union_diff2)
  finally have "F h C = F h B"
    using trivial by simp
  with * show ?thesis by simp
qed

lemma same_carrierI:
  assumes "finite C"
  assumes subset: "A \<subseteq> C" "B \<subseteq> C"
  assumes trivial: "\<And>a. a \<in> C - A \<Longrightarrow> g a = \<^bold>1" "\<And>b. b \<in> C - B \<Longrightarrow> h b = \<^bold>1"
  assumes "F g C = F h C"
  shows "F g A = F h B"
  using assms same_carrier [of C A B] by simp

end

subsection \<open>Generalized summation over a set\<close>

context comm_monoid_add
begin

sublocale sum: comm_monoid_set plus 0
  defines sum = sum.F ..

abbreviation Sum ("\<Sum>_" [1000] 999)
  where "\<Sum>A \<equiv> sum (\<lambda>x. x) A"

end

text \<open>Now: lot's of fancy syntax. First, @{term "sum (\<lambda>x. e) A"} is written \<open>\<Sum>x\<in>A. e\<close>.\<close>

syntax (ASCII)
  "_sum" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(3SUM _:_./ _)" [0, 51, 10] 10)
syntax
  "_sum" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(2\<Sum>_\<in>_./ _)" [0, 51, 10] 10)
translations \<comment> \<open>Beware of argument permutation!\<close>
  "\<Sum>i\<in>A. b" \<rightleftharpoons> "CONST sum (\<lambda>i. b) A"

text \<open>Instead of @{term"\<Sum>x\<in>{x. P}. e"} we introduce the shorter \<open>\<Sum>x|P. e\<close>.\<close>

syntax (ASCII)
  "_qsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(3SUM _ |/ _./ _)" [0, 0, 10] 10)
syntax
  "_qsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(2\<Sum>_ | (_)./ _)" [0, 0, 10] 10)
translations
  "\<Sum>x|P. t" => "CONST sum (\<lambda>x. t) {x. P}"

print_translation \<open>
let
  fun sum_tr' [Abs (x, Tx, t), Const (@{const_syntax Collect}, _) $ Abs (y, Ty, P)] =
        if x <> y then raise Match
        else
          let
            val x' = Syntax_Trans.mark_bound_body (x, Tx);
            val t' = subst_bound (x', t);
            val P' = subst_bound (x', P);
          in
            Syntax.const @{syntax_const "_qsum"} $ Syntax_Trans.mark_bound_abs (x, Tx) $ P' $ t'
          end
    | sum_tr' _ = raise Match;
in [(@{const_syntax sum}, K sum_tr')] end
\<close>

(* TODO generalization candidates *)

lemma (in comm_monoid_add) sum_image_gen:
  assumes fin: "finite S"
  shows "sum g S = sum (\<lambda>y. sum g {x. x \<in> S \<and> f x = y}) (f ` S)"
proof -
  have "{y. y\<in> f`S \<and> f x = y} = {f x}" if "x \<in> S" for x
    using that by auto
  then have "sum g S = sum (\<lambda>x. sum (\<lambda>y. g x) {y. y\<in> f`S \<and> f x = y}) S"
    by simp
  also have "\<dots> = sum (\<lambda>y. sum g {x. x \<in> S \<and> f x = y}) (f ` S)"
    by (rule sum.commute_restrict [OF fin finite_imageI [OF fin]])
  finally show ?thesis .
qed

subsubsection \<open>Properties in more restricted classes of structures\<close>

lemma sum_Un:
  "finite A \<Longrightarrow> finite B \<Longrightarrow> sum f (A \<union> B) = sum f A + sum f B - sum f (A \<inter> B)"
  for f :: "'b \<Rightarrow> 'a::ab_group_add"
  by (subst sum.union_inter [symmetric]) (auto simp add: algebra_simps)

lemma sum_Un2:
  assumes "finite (A \<union> B)"
  shows "sum f (A \<union> B) = sum f (A - B) + sum f (B - A) + sum f (A \<inter> B)"
proof -
  have "A \<union> B = A - B \<union> (B - A) \<union> A \<inter> B"
    by auto
  with assms show ?thesis
    by simp (subst sum.union_disjoint, auto)+
qed

lemma sum_diff1:
  fixes f :: "'b \<Rightarrow> 'a::ab_group_add"
  assumes "finite A"
  shows "sum f (A - {a}) = (if a \<in> A then sum f A - f a else sum f A)"
  using assms by induct (auto simp: insert_Diff_if)

lemma sum_diff:
  fixes f :: "'b \<Rightarrow> 'a::ab_group_add"
  assumes "finite A" "B \<subseteq> A"
  shows "sum f (A - B) = sum f A - sum f B"
proof -
  from assms(2,1) have "finite B" by (rule finite_subset)
  from this \<open>B \<subseteq> A\<close>
  show ?thesis
  proof induct
    case empty
    thus ?case by simp
  next
    case (insert x F)
    with \<open>finite A\<close> \<open>finite B\<close> show ?case
      by (simp add: Diff_insert[where a=x and B=F] sum_diff1 insert_absorb)
  qed
qed

lemma (in ordered_comm_monoid_add) sum_mono:
  "(\<And>i. i\<in>K \<Longrightarrow> f i \<le> g i) \<Longrightarrow> (\<Sum>i\<in>K. f i) \<le> (\<Sum>i\<in>K. g i)"
  by (induct K rule: infinite_finite_induct) (use add_mono in auto)

lemma (in strict_ordered_comm_monoid_add) sum_strict_mono:
  assumes "finite A" "A \<noteq> {}"
    and "\<And>x. x \<in> A \<Longrightarrow> f x < g x"
  shows "sum f A < sum g A"
  using assms
proof (induct rule: finite_ne_induct)
  case singleton
  then show ?case by simp
next
  case insert
  then show ?case by (auto simp: add_strict_mono)
qed

lemma sum_strict_mono_ex1:
  fixes f g :: "'i \<Rightarrow> 'a::ordered_cancel_comm_monoid_add"
  assumes "finite A"
    and "\<forall>x\<in>A. f x \<le> g x"
    and "\<exists>a\<in>A. f a < g a"
  shows "sum f A < sum g A"
proof-
  from assms(3) obtain a where a: "a \<in> A" "f a < g a" by blast
  have "sum f A = sum f ((A - {a}) \<union> {a})"
    by(simp add: insert_absorb[OF \<open>a \<in> A\<close>])
  also have "\<dots> = sum f (A - {a}) + sum f {a}"
    using \<open>finite A\<close> by(subst sum.union_disjoint) auto
  also have "sum f (A - {a}) \<le> sum g (A - {a})"
    by (rule sum_mono) (simp add: assms(2))
  also from a have "sum f {a} < sum g {a}" by simp
  also have "sum g (A - {a}) + sum g {a} = sum g((A - {a}) \<union> {a})"
    using \<open>finite A\<close> by (subst sum.union_disjoint[symmetric]) auto
  also have "\<dots> = sum g A" by (simp add: insert_absorb[OF \<open>a \<in> A\<close>])
  finally show ?thesis
    by (auto simp add: add_right_mono add_strict_left_mono)
qed

lemma sum_mono_inv:
  fixes f g :: "'i \<Rightarrow> 'a :: ordered_cancel_comm_monoid_add"
  assumes eq: "sum f I = sum g I"
  assumes le: "\<And>i. i \<in> I \<Longrightarrow> f i \<le> g i"
  assumes i: "i \<in> I"
  assumes I: "finite I"
  shows "f i = g i"
proof (rule ccontr)
  assume "\<not> ?thesis"
  with le[OF i] have "f i < g i" by simp
  with i have "\<exists>i\<in>I. f i < g i" ..
  from sum_strict_mono_ex1[OF I _ this] le have "sum f I < sum g I"
    by blast
  with eq show False by simp
qed

lemma member_le_sum:
  fixes f :: "_ \<Rightarrow> 'b::{semiring_1, ordered_comm_monoid_add}"
  assumes le: "\<And>x. x \<in> A \<Longrightarrow> 0 \<le> f x"
    and "i \<in> A"
    and "finite A"
  shows "f i \<le> sum f A"
proof -
  have "f i \<le> sum f (A \<inter> {i})"
    by (simp add: assms)
  also have "... = (\<Sum>x\<in>A. if x \<in> {i} then f x else 0)"
    using assms sum.inter_restrict by blast
  also have "... \<le> sum f A"
    apply (rule sum_mono)
    apply (auto simp: le)
    done
  finally show ?thesis .
qed

lemma sum_negf: "(\<Sum>x\<in>A. - f x) = - (\<Sum>x\<in>A. f x)"
  for f :: "'b \<Rightarrow> 'a::ab_group_add"
  by (induct A rule: infinite_finite_induct) auto

lemma sum_subtractf: "(\<Sum>x\<in>A. f x - g x) = (\<Sum>x\<in>A. f x) - (\<Sum>x\<in>A. g x)"
  for f g :: "'b \<Rightarrow>'a::ab_group_add"
  using sum.distrib [of f "- g" A] by (simp add: sum_negf)

lemma sum_subtractf_nat:
  "(\<And>x. x \<in> A \<Longrightarrow> g x \<le> f x) \<Longrightarrow> (\<Sum>x\<in>A. f x - g x) = (\<Sum>x\<in>A. f x) - (\<Sum>x\<in>A. g x)"
  for f g :: "'a \<Rightarrow> nat"
  by (induct A rule: infinite_finite_induct) (auto simp: sum_mono)

context ordered_comm_monoid_add
begin

lemma sum_nonneg: "\<forall>x\<in>A. 0 \<le> f x \<Longrightarrow> 0 \<le> sum f A"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case (insert x F)
  then have "0 + 0 \<le> f x + sum f F" by (blast intro: add_mono)
  with insert show ?case by simp
qed

lemma sum_nonpos: "\<forall>x\<in>A. f x \<le> 0 \<Longrightarrow> sum f A \<le> 0"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case (insert x F)
  then have "f x + sum f F \<le> 0 + 0" by (blast intro: add_mono)
  with insert show ?case by simp
qed

lemma sum_nonneg_eq_0_iff:
  "finite A \<Longrightarrow> \<forall>x\<in>A. 0 \<le> f x \<Longrightarrow> sum f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
  by (induct set: finite) (simp_all add: add_nonneg_eq_0_iff sum_nonneg)

lemma sum_nonneg_0:
  "finite s \<Longrightarrow> (\<And>i. i \<in> s \<Longrightarrow> f i \<ge> 0) \<Longrightarrow> (\<Sum> i \<in> s. f i) = 0 \<Longrightarrow> i \<in> s \<Longrightarrow> f i = 0"
  by (simp add: sum_nonneg_eq_0_iff)

lemma sum_nonneg_leq_bound:
  assumes "finite s" "\<And>i. i \<in> s \<Longrightarrow> f i \<ge> 0" "(\<Sum>i \<in> s. f i) = B" "i \<in> s"
  shows "f i \<le> B"
proof -
  from assms have "f i \<le> f i + (\<Sum>i \<in> s - {i}. f i)"
    by (intro add_increasing2 sum_nonneg) auto
  also have "\<dots> = B"
    using sum.remove[of s i f] assms by simp
  finally show ?thesis by auto
qed

lemma sum_mono2:
  assumes fin: "finite B"
    and sub: "A \<subseteq> B"
    and nn: "\<And>b. b \<in> B-A \<Longrightarrow> 0 \<le> f b"
  shows "sum f A \<le> sum f B"
proof -
  have "sum f A \<le> sum f A + sum f (B-A)"
    by(simp add: add_increasing2[OF sum_nonneg] nn Ball_def)
  also from fin finite_subset[OF sub fin] have "\<dots> = sum f (A \<union> (B-A))"
    by (simp add: sum.union_disjoint del: Un_Diff_cancel)
  also from sub have "A \<union> (B-A) = B" by blast
  finally show ?thesis .
qed

lemma sum_le_included:
  assumes "finite s" "finite t"
  and "\<forall>y\<in>t. 0 \<le> g y" "(\<forall>x\<in>s. \<exists>y\<in>t. i y = x \<and> f x \<le> g y)"
  shows "sum f s \<le> sum g t"
proof -
  have "sum f s \<le> sum (\<lambda>y. sum g {x. x\<in>t \<and> i x = y}) s"
  proof (rule sum_mono)
    fix y
    assume "y \<in> s"
    with assms obtain z where z: "z \<in> t" "y = i z" "f y \<le> g z" by auto
    with assms show "f y \<le> sum g {x \<in> t. i x = y}" (is "?A y \<le> ?B y")
      using order_trans[of "?A (i z)" "sum g {z}" "?B (i z)", intro]
      by (auto intro!: sum_mono2)
  qed
  also have "\<dots> \<le> sum (\<lambda>y. sum g {x. x\<in>t \<and> i x = y}) (i ` t)"
    using assms(2-4) by (auto intro!: sum_mono2 sum_nonneg)
  also have "\<dots> \<le> sum g t"
    using assms by (auto simp: sum_image_gen[symmetric])
  finally show ?thesis .
qed

lemma sum_mono3: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> \<forall>x\<in>B - A. 0 \<le> f x \<Longrightarrow> sum f A \<le> sum f B"
  by (rule sum_mono2) auto

end

lemma (in canonically_ordered_monoid_add) sum_eq_0_iff [simp]:
  "finite F \<Longrightarrow> (sum f F = 0) = (\<forall>a\<in>F. f a = 0)"
  by (intro ballI sum_nonneg_eq_0_iff zero_le)

lemma sum_distrib_left: "r * sum f A = sum (\<lambda>n. r * f n) A"
  for f :: "'a \<Rightarrow> 'b::semiring_0"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case insert
  then show ?case by (simp add: distrib_left)
qed

lemma sum_distrib_right: "sum f A * r = (\<Sum>n\<in>A. f n * r)"
  for r :: "'a::semiring_0"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case insert
  then show ?case by (simp add: distrib_right)
qed

lemma sum_divide_distrib: "sum f A / r = (\<Sum>n\<in>A. f n / r)"
  for r :: "'a::field"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case insert
  then show ?case by (simp add: add_divide_distrib)
qed

lemma sum_abs[iff]: "\<bar>sum f A\<bar> \<le> sum (\<lambda>i. \<bar>f i\<bar>) A"
  for f :: "'a \<Rightarrow> 'b::ordered_ab_group_add_abs"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case insert
  then show ?case by (auto intro: abs_triangle_ineq order_trans)
qed

lemma sum_abs_ge_zero[iff]: "0 \<le> sum (\<lambda>i. \<bar>f i\<bar>) A"
  for f :: "'a \<Rightarrow> 'b::ordered_ab_group_add_abs"
  by (simp add: sum_nonneg)

lemma abs_sum_abs[simp]: "\<bar>\<Sum>a\<in>A. \<bar>f a\<bar>\<bar> = (\<Sum>a\<in>A. \<bar>f a\<bar>)"
  for f :: "'a \<Rightarrow> 'b::ordered_ab_group_add_abs"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case (insert a A)
  then have "\<bar>\<Sum>a\<in>insert a A. \<bar>f a\<bar>\<bar> = \<bar>\<bar>f a\<bar> + (\<Sum>a\<in>A. \<bar>f a\<bar>)\<bar>" by simp
  also from insert have "\<dots> = \<bar>\<bar>f a\<bar> + \<bar>\<Sum>a\<in>A. \<bar>f a\<bar>\<bar>\<bar>" by simp
  also have "\<dots> = \<bar>f a\<bar> + \<bar>\<Sum>a\<in>A. \<bar>f a\<bar>\<bar>" by (simp del: abs_of_nonneg)
  also from insert have "\<dots> = (\<Sum>a\<in>insert a A. \<bar>f a\<bar>)" by simp
  finally show ?case .
qed

lemma sum_diff1_ring:
  fixes f :: "'b \<Rightarrow> 'a::ring"
  assumes "finite A" "a \<in> A"
  shows "sum f (A - {a}) = sum f A - (f a)"
  unfolding sum.remove [OF assms] by auto

lemma sum_product:
  fixes f :: "'a \<Rightarrow> 'b::semiring_0"
  shows "sum f A * sum g B = (\<Sum>i\<in>A. \<Sum>j\<in>B. f i * g j)"
  by (simp add: sum_distrib_left sum_distrib_right) (rule sum.commute)

lemma sum_mult_sum_if_inj:
  fixes f :: "'a \<Rightarrow> 'b::semiring_0"
  shows "inj_on (\<lambda>(a, b). f a * g b) (A \<times> B) \<Longrightarrow>
    sum f A * sum g B = sum id {f a * g b |a b. a \<in> A \<and> b \<in> B}"
  by(auto simp: sum_product sum.cartesian_product intro!: sum.reindex_cong[symmetric])

lemma sum_SucD: "sum f A = Suc n \<Longrightarrow> \<exists>a\<in>A. 0 < f a"
  by (induct A rule: infinite_finite_induct) auto

lemma sum_eq_Suc0_iff:
  "finite A \<Longrightarrow> sum f A = Suc 0 \<longleftrightarrow> (\<exists>a\<in>A. f a = Suc 0 \<and> (\<forall>b\<in>A. a \<noteq> b \<longrightarrow> f b = 0))"
  by (induct A rule: finite_induct) (auto simp add: add_is_1)

lemmas sum_eq_1_iff = sum_eq_Suc0_iff[simplified One_nat_def[symmetric]]

lemma sum_Un_nat:
  "finite A \<Longrightarrow> finite B \<Longrightarrow> sum f (A \<union> B) = sum f A + sum f B - sum f (A \<inter> B)"
  for f :: "'a \<Rightarrow> nat"
  \<comment> \<open>For the natural numbers, we have subtraction.\<close>
  by (subst sum.union_inter [symmetric]) (auto simp: algebra_simps)

lemma sum_diff1_nat: "sum f (A - {a}) = (if a \<in> A then sum f A - f a else sum f A)"
  for f :: "'a \<Rightarrow> nat"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case insert
  then show ?case
    apply (auto simp: insert_Diff_if)
    apply (drule mk_disjoint_insert)
    apply auto
    done
qed

lemma sum_diff_nat:
  fixes f :: "'a \<Rightarrow> nat"
  assumes "finite B" and "B \<subseteq> A"
  shows "sum f (A - B) = sum f A - sum f B"
  using assms
proof induct
  case empty
  then show ?case by simp
next
  case (insert x F)
  note IH = \<open>F \<subseteq> A \<Longrightarrow> sum f (A - F) = sum f A - sum f F\<close>
  from \<open>x \<notin> F\<close> \<open>insert x F \<subseteq> A\<close> have "x \<in> A - F" by simp
  then have A: "sum f ((A - F) - {x}) = sum f (A - F) - f x"
    by (simp add: sum_diff1_nat)
  from \<open>insert x F \<subseteq> A\<close> have "F \<subseteq> A" by simp
  with IH have "sum f (A - F) = sum f A - sum f F" by simp
  with A have B: "sum f ((A - F) - {x}) = sum f A - sum f F - f x"
    by simp
  from \<open>x \<notin> F\<close> have "A - insert x F = (A - F) - {x}" by auto
  with B have C: "sum f (A - insert x F) = sum f A - sum f F - f x"
    by simp
  from \<open>finite F\<close> \<open>x \<notin> F\<close> have "sum f (insert x F) = sum f F + f x"
    by simp
  with C have "sum f (A - insert x F) = sum f A - sum f (insert x F)"
    by simp
  then show ?case by simp
qed

lemma sum_comp_morphism:
  "h 0 = 0 \<Longrightarrow> (\<And>x y. h (x + y) = h x + h y) \<Longrightarrow> sum (h \<circ> g) A = h (sum g A)"
  by (induct A rule: infinite_finite_induct) simp_all

lemma (in comm_semiring_1) dvd_sum: "(\<And>a. a \<in> A \<Longrightarrow> d dvd f a) \<Longrightarrow> d dvd sum f A"
  by (induct A rule: infinite_finite_induct) simp_all

lemma (in ordered_comm_monoid_add) sum_pos:
  "finite I \<Longrightarrow> I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> 0 < f i) \<Longrightarrow> 0 < sum f I"
  by (induct I rule: finite_ne_induct) (auto intro: add_pos_pos)

lemma (in ordered_comm_monoid_add) sum_pos2:
  assumes I: "finite I" "i \<in> I" "0 < f i" "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> f i"
  shows "0 < sum f I"
proof -
  have "0 < f i + sum f (I - {i})"
    using assms by (intro add_pos_nonneg sum_nonneg) auto
  also have "\<dots> = sum f I"
    using assms by (simp add: sum.remove)
  finally show ?thesis .
qed

lemma sum_cong_Suc:
  assumes "0 \<notin> A" "\<And>x. Suc x \<in> A \<Longrightarrow> f (Suc x) = g (Suc x)"
  shows "sum f A = sum g A"
proof (rule sum.cong)
  fix x
  assume "x \<in> A"
  with assms(1) show "f x = g x"
    by (cases x) (auto intro!: assms(2))
qed simp_all

subsubsection \<open>Cardinality as special case of @{const sum}\<close>

lemma card_eq_sum: "card A = sum (\<lambda>x. 1) A"
proof -
  have "plus \<circ> (\<lambda>_. Suc 0) = (\<lambda>_. Suc)"
    by (simp add: fun_eq_iff)
  then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) = Finite_Set.fold (\<lambda>_. Suc)"
    by (rule arg_cong)
  then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) 0 A = Finite_Set.fold (\<lambda>_. Suc) 0 A"
    by (blast intro: fun_cong)
  then show ?thesis
    by (simp add: card.eq_fold sum.eq_fold)
qed

lemma sum_constant [simp]: "(\<Sum>x \<in> A. y) = of_nat (card A) * y"
  by (induct A rule: infinite_finite_induct) (auto simp: algebra_simps)

lemma sum_Suc: "sum (\<lambda>x. Suc(f x)) A = sum f A + card A"
  using sum.distrib[of f "\<lambda>_. 1" A] by simp

lemma sum_bounded_above:
  fixes K :: "'a::{semiring_1,ordered_comm_monoid_add}"
  assumes le: "\<And>i. i\<in>A \<Longrightarrow> f i \<le> K"
  shows "sum f A \<le> of_nat (card A) * K"
proof (cases "finite A")
  case True
  then show ?thesis
    using le sum_mono[where K=A and g = "\<lambda>x. K"] by simp
next
  case False
  then show ?thesis by simp
qed

lemma sum_bounded_above_strict:
  fixes K :: "'a::{ordered_cancel_comm_monoid_add,semiring_1}"
  assumes "\<And>i. i\<in>A \<Longrightarrow> f i < K" "card A > 0"
  shows "sum f A < of_nat (card A) * K"
  using assms sum_strict_mono[where A=A and g = "\<lambda>x. K"]
  by (simp add: card_gt_0_iff)

lemma sum_bounded_below:
  fixes K :: "'a::{semiring_1,ordered_comm_monoid_add}"
  assumes le: "\<And>i. i\<in>A \<Longrightarrow> K \<le> f i"
  shows "of_nat (card A) * K \<le> sum f A"
proof (cases "finite A")
  case True
  then show ?thesis
    using le sum_mono[where K=A and f = "\<lambda>x. K"] by simp
next
  case False
  then show ?thesis by simp
qed

lemma card_UN_disjoint:
  assumes "finite I" and "\<forall>i\<in>I. finite (A i)"
    and "\<forall>i\<in>I. \<forall>j\<in>I. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}"
  shows "card (UNION I A) = (\<Sum>i\<in>I. card(A i))"
proof -
  have "(\<Sum>i\<in>I. card (A i)) = (\<Sum>i\<in>I. \<Sum>x\<in>A i. 1)"
    by simp
  with assms show ?thesis
    by (simp add: card_eq_sum sum.UNION_disjoint del: sum_constant)
qed

lemma card_Union_disjoint:
  "finite C \<Longrightarrow> \<forall>A\<in>C. finite A \<Longrightarrow> \<forall>A\<in>C. \<forall>B\<in>C. A \<noteq> B \<longrightarrow> A \<inter> B = {} \<Longrightarrow>
    card (\<Union>C) = sum card C"
  by (frule card_UN_disjoint [of C id]) simp_all

lemma sum_multicount_gen:
  assumes "finite s" "finite t" "\<forall>j\<in>t. (card {i\<in>s. R i j} = k j)"
  shows "sum (\<lambda>i. (card {j\<in>t. R i j})) s = sum k t"
    (is "?l = ?r")
proof-
  have "?l = sum (\<lambda>i. sum (\<lambda>x.1) {j\<in>t. R i j}) s"
    by auto
  also have "\<dots> = ?r"
    unfolding sum.commute_restrict [OF assms(1-2)]
    using assms(3) by auto
  finally show ?thesis .
qed

lemma sum_multicount:
  assumes "finite S" "finite T" "\<forall>j\<in>T. (card {i\<in>S. R i j} = k)"
  shows "sum (\<lambda>i. card {j\<in>T. R i j}) S = k * card T" (is "?l = ?r")
proof-
  have "?l = sum (\<lambda>i. k) T"
    by (rule sum_multicount_gen) (auto simp: assms)
  also have "\<dots> = ?r" by (simp add: mult.commute)
  finally show ?thesis by auto
qed

subsubsection \<open>Cardinality of products\<close>

lemma card_SigmaI [simp]:
  "finite A \<Longrightarrow> \<forall>a\<in>A. finite (B a) \<Longrightarrow> card (SIGMA x: A. B x) = (\<Sum>a\<in>A. card (B a))"
  by (simp add: card_eq_sum sum.Sigma del: sum_constant)

(*
lemma SigmaI_insert: "y \<notin> A ==>
  (SIGMA x:(insert y A). B x) = (({y} \<times> (B y)) \<union> (SIGMA x: A. B x))"
  by auto
*)

lemma card_cartesian_product: "card (A \<times> B) = card A * card B"
  by (cases "finite A \<and> finite B")
    (auto simp add: card_eq_0_iff dest: finite_cartesian_productD1 finite_cartesian_productD2)

lemma card_cartesian_product_singleton:  "card ({x} \<times> A) = card A"
  by (simp add: card_cartesian_product)

subsection \<open>Generalized product over a set\<close>

context comm_monoid_mult
begin

sublocale prod: comm_monoid_set times 1
  defines prod = prod.F ..

abbreviation Prod ("\<Prod>_" [1000] 999)
  where "\<Prod>A \<equiv> prod (\<lambda>x. x) A"

end

syntax (ASCII)
  "_prod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(4PROD _:_./ _)" [0, 51, 10] 10)
syntax
  "_prod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(2\<Prod>_\<in>_./ _)" [0, 51, 10] 10)
translations \<comment> \<open>Beware of argument permutation!\<close>
  "\<Prod>i\<in>A. b" == "CONST prod (\<lambda>i. b) A"

text \<open>Instead of @{term"\<Prod>x\<in>{x. P}. e"} we introduce the shorter \<open>\<Prod>x|P. e\<close>.\<close>

syntax (ASCII)
  "_qprod" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(4PROD _ |/ _./ _)" [0, 0, 10] 10)
syntax
  "_qprod" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(2\<Prod>_ | (_)./ _)" [0, 0, 10] 10)
translations
  "\<Prod>x|P. t" => "CONST prod (\<lambda>x. t) {x. P}"

context comm_monoid_mult
begin

lemma prod_dvd_prod: "(\<And>a. a \<in> A \<Longrightarrow> f a dvd g a) \<Longrightarrow> prod f A dvd prod g A"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by (auto intro: dvdI)
next
  case empty
  then show ?case by (auto intro: dvdI)
next
  case (insert a A)
  then have "f a dvd g a" and "prod f A dvd prod g A"
    by simp_all
  then obtain r s where "g a = f a * r" and "prod g A = prod f A * s"
    by (auto elim!: dvdE)
  then have "g a * prod g A = f a * prod f A * (r * s)"
    by (simp add: ac_simps)
  with insert.hyps show ?case
    by (auto intro: dvdI)
qed

lemma prod_dvd_prod_subset: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> prod f A dvd prod f B"
  by (auto simp add: prod.subset_diff ac_simps intro: dvdI)

end

subsubsection \<open>Properties in more restricted classes of structures\<close>

context comm_semiring_1
begin

lemma dvd_prod_eqI [intro]:
  assumes "finite A" and "a \<in> A" and "b = f a"
  shows "b dvd prod f A"
proof -
  from \<open>finite A\<close> have "prod f (insert a (A - {a})) = f a * prod f (A - {a})"
    by (intro prod.insert) auto
  also from \<open>a \<in> A\<close> have "insert a (A - {a}) = A"
    by blast
  finally have "prod f A = f a * prod f (A - {a})" .
  with \<open>b = f a\<close> show ?thesis
    by simp
qed

lemma dvd_prodI [intro]: "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> f a dvd prod f A"
  by auto

lemma prod_zero:
  assumes "finite A" and "\<exists>a\<in>A. f a = 0"
  shows "prod f A = 0"
  using assms
proof (induct A)
  case empty
  then show ?case by simp
next
  case (insert a A)
  then have "f a = 0 \<or> (\<exists>a\<in>A. f a = 0)" by simp
  then have "f a * prod f A = 0" by rule (simp_all add: insert)
  with insert show ?case by simp
qed

lemma prod_dvd_prod_subset2:
  assumes "finite B" and "A \<subseteq> B" and "\<And>a. a \<in> A \<Longrightarrow> f a dvd g a"
  shows "prod f A dvd prod g B"
proof -
  from assms have "prod f A dvd prod g A"
    by (auto intro: prod_dvd_prod)
  moreover from assms have "prod g A dvd prod g B"
    by (auto intro: prod_dvd_prod_subset)
  ultimately show ?thesis by (rule dvd_trans)
qed

end

lemma (in semidom) prod_zero_iff [simp]:
  fixes f :: "'b \<Rightarrow> 'a"
  assumes "finite A"
  shows "prod f A = 0 \<longleftrightarrow> (\<exists>a\<in>A. f a = 0)"
  using assms by (induct A) (auto simp: no_zero_divisors)

lemma (in semidom_divide) prod_diff1:
  assumes "finite A" and "f a \<noteq> 0"
  shows "prod f (A - {a}) = (if a \<in> A then prod f A div f a else prod f A)"
proof (cases "a \<notin> A")
  case True
  then show ?thesis by simp
next
  case False
  with assms show ?thesis
  proof induct
    case empty
    then show ?case by simp
  next
    case (insert b B)
    then show ?case
    proof (cases "a = b")
      case True
      with insert show ?thesis by simp
    next
      case False
      with insert have "a \<in> B" by simp
      define C where "C = B - {a}"
      with \<open>finite B\<close> \<open>a \<in> B\<close> have "B = insert a C" "finite C" "a \<notin> C"
        by auto
      with insert show ?thesis
        by (auto simp add: insert_commute ac_simps)
    qed
  qed
qed

lemma sum_zero_power [simp]: "(\<Sum>i\<in>A. c i * 0^i) = (if finite A \<and> 0 \<in> A then c 0 else 0)"
  for c :: "nat \<Rightarrow> 'a::division_ring"
  by (induct A rule: infinite_finite_induct) auto

lemma sum_zero_power' [simp]:
  "(\<Sum>i\<in>A. c i * 0^i / d i) = (if finite A \<and> 0 \<in> A then c 0 / d 0 else 0)"
  for c :: "nat \<Rightarrow> 'a::field"
  using sum_zero_power [of "\<lambda>i. c i / d i" A] by auto

lemma (in field) prod_inversef:
  "finite A \<Longrightarrow> prod (inverse \<circ> f) A = inverse (prod f A)"
  by (induct A rule: finite_induct) simp_all

lemma (in field) prod_dividef: "finite A \<Longrightarrow> (\<Prod>x\<in>A. f x / g x) = prod f A / prod g A"
  using prod_inversef [of A g] by (simp add: divide_inverse prod.distrib)

lemma prod_Un:
  fixes f :: "'b \<Rightarrow> 'a :: field"
  assumes "finite A" and "finite B"
    and "\<forall>x\<in>A \<inter> B. f x \<noteq> 0"
  shows "prod f (A \<union> B) = prod f A * prod f B / prod f (A \<inter> B)"
proof -
  from assms have "prod f A * prod f B = prod f (A \<union> B) * prod f (A \<inter> B)"
    by (simp add: prod.union_inter [symmetric, of A B])
  with assms show ?thesis
    by simp
qed

lemma (in linordered_semidom) prod_nonneg: "(\<forall>a\<in>A. 0 \<le> f a) \<Longrightarrow> 0 \<le> prod f A"
  by (induct A rule: infinite_finite_induct) simp_all

lemma (in linordered_semidom) prod_pos: "(\<forall>a\<in>A. 0 < f a) \<Longrightarrow> 0 < prod f A"
  by (induct A rule: infinite_finite_induct) simp_all

lemma (in linordered_semidom) prod_mono:
  "\<forall>i\<in>A. 0 \<le> f i \<and> f i \<le> g i \<Longrightarrow> prod f A \<le> prod g A"
  by (induct A rule: infinite_finite_induct) (auto intro!: prod_nonneg mult_mono)

lemma (in linordered_semidom) prod_mono_strict:
  assumes "finite A" "\<forall>i\<in>A. 0 \<le> f i \<and> f i < g i" "A \<noteq> {}"
  shows "prod f A < prod g A"
  using assms
proof (induct A rule: finite_induct)
  case empty
  then show ?case by simp
next
  case insert
  then show ?case by (force intro: mult_strict_mono' prod_nonneg)
qed

lemma (in linordered_field) abs_prod: "\<bar>prod f A\<bar> = (\<Prod>x\<in>A. \<bar>f x\<bar>)"
  by (induct A rule: infinite_finite_induct) (simp_all add: abs_mult)

lemma prod_eq_1_iff [simp]: "finite A \<Longrightarrow> prod f A = 1 \<longleftrightarrow> (\<forall>a\<in>A. f a = 1)"
  for f :: "'a \<Rightarrow> nat"
  by (induct A rule: finite_induct) simp_all

lemma prod_pos_nat_iff [simp]: "finite A \<Longrightarrow> prod f A > 0 \<longleftrightarrow> (\<forall>a\<in>A. f a > 0)"
  for f :: "'a \<Rightarrow> nat"
  using prod_zero_iff by (simp del: neq0_conv add: zero_less_iff_neq_zero)

lemma prod_constant: "(\<Prod>x\<in> A. y) = y ^ card A"
  for y :: "'a::comm_monoid_mult"
  by (induct A rule: infinite_finite_induct) simp_all

lemma prod_power_distrib: "prod f A ^ n = prod (\<lambda>x. (f x) ^ n) A"
  for f :: "'a \<Rightarrow> 'b::comm_semiring_1"
  by (induct A rule: infinite_finite_induct) (auto simp add: power_mult_distrib)

lemma power_sum: "c ^ (\<Sum>a\<in>A. f a) = (\<Prod>a\<in>A. c ^ f a)"
  by (induct A rule: infinite_finite_induct) (simp_all add: power_add)

lemma prod_gen_delta:
  fixes b :: "'b \<Rightarrow> 'a::comm_monoid_mult"
  assumes fin: "finite S"
  shows "prod (\<lambda>k. if k = a then b k else c) S =
    (if a \<in> S then b a * c ^ (card S - 1) else c ^ card S)"
proof -
  let ?f = "(\<lambda>k. if k=a then b k else c)"
  show ?thesis
  proof (cases "a \<in> S")
    case False
    then have "\<forall> k\<in> S. ?f k = c" by simp
    with False show ?thesis by (simp add: prod_constant)
  next
    case True
    let ?A = "S - {a}"
    let ?B = "{a}"
    from True have eq: "S = ?A \<union> ?B" by blast
    have disjoint: "?A \<inter> ?B = {}" by simp
    from fin have fin': "finite ?A" "finite ?B" by auto
    have f_A0: "prod ?f ?A = prod (\<lambda>i. c) ?A"
      by (rule prod.cong) auto
    from fin True have card_A: "card ?A = card S - 1" by auto
    have f_A1: "prod ?f ?A = c ^ card ?A"
      unfolding f_A0 by (rule prod_constant)
    have "prod ?f ?A * prod ?f ?B = prod ?f S"
      using prod.union_disjoint[OF fin' disjoint, of ?f, unfolded eq[symmetric]]
      by simp
    with True card_A show ?thesis
      by (simp add: f_A1 field_simps cong add: prod.cong cong del: if_weak_cong)
  qed
qed

lemma sum_image_le:
  fixes g :: "'a \<Rightarrow> 'b::ordered_ab_group_add"
  assumes "finite I" "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> g(f i)"
    shows "sum g (f ` I) \<le> sum (g \<circ> f) I"
  using assms
proof induction
  case empty
  then show ?case by auto
next
  case (insert x F) then
  have "sum g (f ` insert x F) = sum g (insert (f x) (f ` F))" by simp
  also have "\<dots> \<le> g (f x) + sum g (f ` F)"
    by (simp add: insert sum.insert_if)
  also have "\<dots>  \<le> sum (g \<circ> f) (insert x F)"
    using insert by auto
  finally show ?case .
qed

end


(*  Title:      IP_Address.thy
    Authors:    Cornelius Diekmann
*)
theory IP_Address
imports "Word_Lib.Word_Lemmas"
        Hs_Compat
        WordInterval
begin

section \<open>Modelling IP Adresses\<close>
  text\<open>An IP address is basically an unsigned integer.
    We model IP addresses of arbitrary lengths.

    We will write @{typ "'i::len word"} for IP addresses of length @{term "LENGTH('i::len)"}.
    We use the convention to write @{typ 'i} whenever we mean IP addresses instead of generic words.
    When we will later have theorems with several polymorphic types in it (e.g. arbitrarily
    extensible packets), this notation makes it easier to spot that type @{typ 'i} is for
    IP addresses.

    The files @{file \<open>IPv4.thy\<close>} @{file \<open>IPv6.thy\<close>} concrete this for IPv4 and IPv6.\<close>

  text\<open>The maximum IP address\<close>
  definition max_ip_addr :: "'i::len word" where
    "max_ip_addr \<equiv> of_nat ((2^(len_of(TYPE('i)))) - 1)"

  lemma max_ip_addr_max_word: "max_ip_addr = max_word"
    by(simp add: max_ip_addr_def max_word_def word_of_int_minus)

  lemma max_ip_addr_max: "\<forall>a. a \<le> max_ip_addr"
    by(simp add: max_ip_addr_max_word)
  lemma range_0_max_UNIV: "UNIV = {0 .. max_ip_addr}" (*not in the simp set, for a reason*)
    by(simp add: max_ip_addr_max_word) fastforce

  lemma "size (x::'i::len word) = len_of(TYPE('i))" by(simp add:word_size)

subsection\<open>Sets of IP Addresses\<close>
  (*Warning, not executable!*)
  text\<open>Specifying sets with network masks: 192.168.0.0 255.255.255.0\<close>
  definition ipset_from_netmask::"'i::len word \<Rightarrow> 'i::len word \<Rightarrow> 'i::len word set" where
    "ipset_from_netmask addr netmask \<equiv>
      let
        network_prefix = (addr AND netmask)
      in
        {network_prefix .. network_prefix OR (NOT netmask)}"

  text\<open>Example (pseudo syntax):
    @{const ipset_from_netmask} \<open>192.168.1.129  255.255.255.0\<close> =
        \<open>{192.168.1.0 .. 192.168.1.255}\<close>\<close>

  text\<open>A network mask of all ones (i.e. @{term "(- 1)::'i::len word"}).\<close>
  lemma ipset_from_netmask_minusone:
    "ipset_from_netmask ip (- 1) = {ip}" by (simp add: ipset_from_netmask_def)
  lemma ipset_from_netmask_maxword:
    "ipset_from_netmask ip max_word = {ip}" by (simp add: ipset_from_netmask_def)

  lemma ipset_from_netmask_zero:
    "ipset_from_netmask ip 0 = UNIV" by (auto simp add: ipset_from_netmask_def)

  text\<open>Specifying sets in Classless Inter-domain Routing (CIDR) notation: 192.168.0.0/24\<close>
  definition ipset_from_cidr ::"'i::len word \<Rightarrow> nat \<Rightarrow> 'i::len word set" where
    "ipset_from_cidr addr pflength \<equiv>
       ipset_from_netmask addr ((mask pflength) << (len_of(TYPE('i)) - pflength))"

  text\<open>Example (pseudo syntax):
    @{const ipset_from_cidr} \<open>192.168.1.129 24\<close> = \<open>{192.168.1.0 .. 192.168.1.255}\<close>\<close>

  (*does this simplify stuff?*)
  lemma "(case ipcidr of (base, len) \<Rightarrow> ipset_from_cidr base len) = uncurry ipset_from_cidr ipcidr"
    by(simp add: uncurry_case_stmt)

  lemma ipset_from_cidr_0: "ipset_from_cidr ip 0 = UNIV"
    by(auto simp add: ipset_from_cidr_def ipset_from_netmask_def Let_def)

  text\<open>A prefix length of word size gives back the singleton set with the IP address.
       Example: \<open>192.168.1.2/32 = {192.168.1.2}\<close>\<close>
  lemma ipset_from_cidr_wordlength:
    fixes ip :: "'i::len word"
    shows "ipset_from_cidr ip (LENGTH('i)) = {ip}"
    by(simp add: ipset_from_cidr_def ipset_from_netmask_def Let_def mask_def)

  text\<open>Alternative definition: Considering words as bit lists:\<close>
  lemma ipset_from_cidr_bl:
    fixes addr :: "'i::len word"
    shows "ipset_from_cidr addr pflength \<equiv>
            ipset_from_netmask addr (of_bl ((replicate pflength True) @
                                            (replicate ((len_of(TYPE('i))) - pflength)) False))"
    by(simp add: ipset_from_cidr_def mask_bl Word.shiftl_of_bl)

  lemma ipset_from_cidr_alt:
    fixes pre :: "'i::len word"
    shows "ipset_from_cidr pre len =
            {pre AND (mask len << LENGTH('i) - len)
             ..
             pre OR mask (LENGTH('i) - len)}"
    apply(simp add: ipset_from_cidr_def ipset_from_netmask_def Let_def)
    apply(simp add: Word.word_oa_dist)
    apply(simp add: NOT_mask_shifted_lenword)
    done

  lemma ipset_from_cidr_alt2:
    fixes base ::"'i::len word"
    shows "ipset_from_cidr base len =
           ipset_from_netmask base (NOT (mask (LENGTH('i) - len)))"
    apply(simp add: ipset_from_cidr_def)
    using NOT_mask_shifted_lenword by(metis word_not_not)

  text\<open>In CIDR notation, we cannot express the empty set.\<close>
  lemma ipset_from_cidr_not_empty: "ipset_from_cidr base len \<noteq> {}"
    by(simp add: ipset_from_cidr_alt bitmagic_zeroLast_leq_or1Last)

  text\<open>Though we can write 192.168.1.2/24, we say that 192.168.0.0/24 is well-formed.\<close>
  lemma ipset_from_cidr_base_wellforemd: fixes base:: "'i::len word"
    assumes "mask (LENGTH('i) - l) AND base = 0"
      shows "ipset_from_cidr base l = {base .. base OR mask (LENGTH('i) - l)}"
  proof -
    have maskshift_eq_not_mask_generic:
      "((mask l << LENGTH('i) - l) :: 'i::len word) = NOT (mask (LENGTH('i) - l))"
      using NOT_mask_shifted_lenword by (metis word_not_not)
    have *: "base AND NOT (mask (LENGTH('i) - l)) = base"
      unfolding mask_eq_0_eq_x[symmetric] using assms word_bw_comms(1)[of base] by simp
    hence **: "base AND NOT (mask (LENGTH('i) - l)) OR mask (LENGTH('i) - l) =
                base OR mask (LENGTH('i) - l)" by simp
    have "ipset_from_netmask base (NOT (mask (LENGTH('i) - l))) =
            {base .. base || mask (LENGTH('i) - l)}"
      by(simp add: ipset_from_netmask_def Let_def ** *)
    thus ?thesis by(simp add: ipset_from_cidr_def maskshift_eq_not_mask_generic)
  qed

  lemma ipset_from_cidr_large_pfxlen:
    fixes ip:: "'i::len word"
    assumes "n \<ge> LENGTH('i)"
    shows "ipset_from_cidr ip n = {ip}"
  proof -
    have obviously: "mask (LENGTH('i) - n) = 0" by (simp add: assms)
    show ?thesis
      apply(subst ipset_from_cidr_base_wellforemd)
       subgoal using assms by simp
      by (simp add: obviously)
  qed

  lemma ipset_from_netmask_base_mask_consume:
    fixes base :: "'i::len word"
    shows "ipset_from_netmask (base AND NOT (mask (LENGTH('i) - m)))
                              (NOT (mask (LENGTH('i) - m)))
            =
             ipset_from_netmask base (NOT (mask (LENGTH('i) - m)))"
    unfolding ipset_from_netmask_def by(simp)

  text\<open>Another definition of CIDR notation:
       All IP address which are equal on the first @{term "len - n"} bits\<close>
  definition ip_cidr_set :: "'i::len word \<Rightarrow> nat \<Rightarrow> 'i word set" where
    "ip_cidr_set i r \<equiv>
      {j . i AND NOT (mask (LENGTH('i) - r)) = j AND NOT (mask (LENGTH('i) - r))}"

  text\<open>The definitions are equal\<close>
  lemma ipset_from_cidr_eq_ip_cidr_set:
    fixes base::"'i::len word"
    shows "ipset_from_cidr base len = ip_cidr_set base len"
  proof -
    have maskshift_eq_not_mask_generic:
      "((mask len << LENGTH('a) - len) :: 'a::len word) = NOT (mask (LENGTH('a) - len))"
      using NOT_mask_shifted_lenword by (metis word_not_not)
    have 1: "mask (len - m) AND base AND NOT (mask (len - m)) = 0"
      for len m and base::"'i::len word"
      by(simp add: word_bw_lcs)
    have 2: "mask (LENGTH('i) - len) AND pfxm_p = 0 \<Longrightarrow>
           (a \<in> ipset_from_netmask pfxm_p (NOT (mask (LENGTH('i) - len)))) \<longleftrightarrow>
           (pfxm_p = NOT (mask (LENGTH('i) - len)) AND a)" for a::"'i::len word" and pfxm_p
    apply(subst ipset_from_cidr_alt2[symmetric])
    apply(subst zero_base_lsb_imp_set_eq_as_bit_operation)
     apply(simp; fail)
    apply(subst ipset_from_cidr_base_wellforemd)
     apply(simp; fail)
    apply(simp)
    done
    from 2[OF 1, of _ base] have
      "(x \<in> ipset_from_netmask base (~~ (mask (LENGTH('i) - len)))) \<longleftrightarrow>
       (base && ~~ (mask (LENGTH('i) - len)) = x && ~~ (mask (LENGTH('i) - len)))" for x
    apply(simp add: ipset_from_netmask_base_mask_consume)
    unfolding word_bw_comms(1)[of _ " ~~ (mask (LENGTH('i) - len))"] by simp
    then show ?thesis
      unfolding ip_cidr_set_def ipset_from_cidr_def
      by(auto simp add:  maskshift_eq_not_mask_generic)
  qed

  lemma ip_cidr_set_change_base: "j \<in> ip_cidr_set i r \<Longrightarrow> ip_cidr_set j r = ip_cidr_set i r"
    by (auto simp: ip_cidr_set_def)

subsection\<open>IP Addresses as WordIntervals\<close>
  text\<open>The nice thing is: @{typ "'i wordinterval"}s are executable.\<close>

  definition iprange_single :: "'i::len word \<Rightarrow> 'i wordinterval" where
    "iprange_single ip \<equiv> WordInterval ip ip"

  fun iprange_interval :: "('i::len word \<times> 'i::len word) \<Rightarrow> 'i wordinterval" where
    "iprange_interval (ip_start, ip_end) = WordInterval ip_start ip_end"
  declare iprange_interval.simps[simp del]

  lemma iprange_interval_uncurry: "iprange_interval ipcidr = uncurry WordInterval ipcidr"
    by(cases ipcidr) (simp add: iprange_interval.simps)

  lemma "wordinterval_to_set (iprange_single ip) = {ip}"
    by(simp add: iprange_single_def)
  lemma "wordinterval_to_set (iprange_interval (ip1, ip2)) = {ip1 .. ip2}"
    by(simp add: iprange_interval.simps)

  text\<open>Now we can use the set operations on @{typ "'i::len wordinterval"}s\<close>
  term wordinterval_to_set
  term wordinterval_element
  term wordinterval_union
  term wordinterval_empty
  term wordinterval_setminus
  term wordinterval_UNIV
  term wordinterval_invert
  term wordinterval_intersection
  term wordinterval_subset
  term wordinterval_eq

subsection\<open>IP Addresses in CIDR Notation\<close>
  text\<open>We want to convert IP addresses in CIDR notation to intervals.
    We already have @{const ipset_from_cidr}, which gives back a non-executable set.
    We want to convert to something we can store in an @{typ "'i wordinterval"}.\<close>

  fun ipcidr_to_interval_start :: "('i::len word \<times> nat) \<Rightarrow> 'i::len word" where
    "ipcidr_to_interval_start (pre, len) = (
      let netmask = (mask len) << (LENGTH('i) - len);
          network_prefix = (pre AND netmask)
      in network_prefix)"
  fun ipcidr_to_interval_end :: "('i::len word \<times> nat) \<Rightarrow> 'i::len word" where
    "ipcidr_to_interval_end (pre, len) = (
      let netmask = (mask len) << (LENGTH('i) - len);
          network_prefix = (pre AND netmask)
      in network_prefix OR (NOT netmask))"
  definition ipcidr_to_interval :: "('i::len word \<times> nat) \<Rightarrow> ('i word \<times> 'i word)" where
    "ipcidr_to_interval cidr \<equiv> (ipcidr_to_interval_start cidr, ipcidr_to_interval_end cidr)"

  lemma ipset_from_cidr_ipcidr_to_interval:
    "ipset_from_cidr base len =
      {ipcidr_to_interval_start (base,len) .. ipcidr_to_interval_end (base,len)}"
    by(simp add: Let_def ipcidr_to_interval_def ipset_from_cidr_def ipset_from_netmask_def)
  declare ipcidr_to_interval_start.simps[simp del] ipcidr_to_interval_end.simps[simp del]

  lemma ipcidr_to_interval:
    "ipcidr_to_interval (base, len) = (s,e) \<Longrightarrow> ipset_from_cidr base len = {s .. e}"
    by (simp add: ipcidr_to_interval_def ipset_from_cidr_ipcidr_to_interval)

  definition ipcidr_tuple_to_wordinterval :: "('i::len word \<times> nat) \<Rightarrow> 'i wordinterval" where
    "ipcidr_tuple_to_wordinterval iprng \<equiv> iprange_interval (ipcidr_to_interval iprng)"

  lemma wordinterval_to_set_ipcidr_tuple_to_wordinterval:
    "wordinterval_to_set (ipcidr_tuple_to_wordinterval (b, m)) = ipset_from_cidr b m"
    unfolding ipcidr_tuple_to_wordinterval_def ipset_from_cidr_ipcidr_to_interval
              ipcidr_to_interval_def
    by(simp add: iprange_interval.simps)

  lemma wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry:
    "wordinterval_to_set (ipcidr_tuple_to_wordinterval ipcidr) = uncurry ipset_from_cidr ipcidr"
    by(cases ipcidr, simp add: wordinterval_to_set_ipcidr_tuple_to_wordinterval)

  definition ipcidr_union_set :: "('i::len word \<times> nat) set \<Rightarrow> ('i word) set" where
    "ipcidr_union_set ips \<equiv> \<Union>(base, len) \<in> ips. ipset_from_cidr base len"

  lemma ipcidr_union_set_uncurry:
    "ipcidr_union_set ips = (\<Union> ipcidr \<in> ips. uncurry ipset_from_cidr ipcidr)"
    by(simp add: ipcidr_union_set_def uncurry_case_stmt)

subsection\<open>Clever Operations on IP Addresses in CIDR Notation\<close>
  text\<open>Intersecting two intervals may result in a new interval.
    Example: \<open>{1..10} \<inter> {5..20} = {5..10}\<close>

    Intersecting two IP address ranges represented as CIDR ranges results either in the empty set
    or the smaller of the two ranges. It will never create a new range.
    \<close>
  context
  begin
    (*contributed by Lars Noschinski*)
    private lemma less_and_not_mask_eq:
      fixes i :: "('a :: len) word"
      assumes "r2 \<le> r1" "i && ~~ (mask r2) = x && ~~ (mask r2)"
      shows "i && ~~ (mask r1) = x && ~~ (mask r1)"
    proof -
      have "i AND NOT (mask r1) = (i && ~~ (mask r2)) && ~~ (mask r1)" (is "_ = ?w && _")
        using \<open>r2 \<le> r1\<close> by (simp add: and_not_mask_twice max_def)
      also have "?w = x && ~~ (mask r2)" by fact
      also have "\<dots> && ~~ (mask r1) = x && ~~ (mask r1)"
        using \<open>r2 \<le> r1\<close> by (simp add: and_not_mask_twice max_def)
      finally show ?thesis .
    qed

    lemma ip_cidr_set_less:
      fixes i :: "'i::len word"
      shows "r1 \<le> r2 \<Longrightarrow> ip_cidr_set i r2 \<subseteq> ip_cidr_set i r1"
      unfolding ip_cidr_set_def
      apply auto
      apply (rule less_and_not_mask_eq[where ?r2.0="LENGTH('i) - r2"])
      apply auto
      done

    private lemma ip_cidr_set_intersect_subset_helper:
      fixes i1 r1 i2 r2
      assumes disj: "ip_cidr_set i1 r1 \<inter> ip_cidr_set i2 r2 \<noteq> {}" and  "r1 \<le> r2"
      shows "ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1"
      proof -
      from disj obtain j where "j \<in> ip_cidr_set i1 r1" "j \<in> ip_cidr_set i2 r2" by auto
      with \<open>r1 \<le> r2\<close> have "j \<in> ip_cidr_set j r1" "j \<in> ip_cidr_set j r1"
        using ip_cidr_set_change_base ip_cidr_set_less by blast+

      show "ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1"
      proof
        fix i assume "i \<in> ip_cidr_set i2 r2"
        with \<open>j \<in> ip_cidr_set i2 r2\<close> have "i \<in> ip_cidr_set j r2" using ip_cidr_set_change_base by auto
        also have "ip_cidr_set j r2 \<subseteq> ip_cidr_set j r1" using \<open>r1 \<le> r2\<close> ip_cidr_set_less by blast
        also have "\<dots> = ip_cidr_set i1 r1" using \<open>j \<in> ip_cidr_set i1 r1\<close> ip_cidr_set_change_base by blast
        finally show "i \<in> ip_cidr_set i1 r1" .
      qed
    qed

    lemma ip_cidr_set_notsubset_empty_inter:
      "\<not> ip_cidr_set i1 r1 \<subseteq> ip_cidr_set i2 r2 \<Longrightarrow>
       \<not> ip_cidr_set i2 r2 \<subseteq> ip_cidr_set i1 r1 \<Longrightarrow>
       ip_cidr_set i1 r1 \<inter> ip_cidr_set i2 r2 = {}"
      apply(cases "r1 \<le> r2")
       subgoal using ip_cidr_set_intersect_subset_helper by blast
      apply(cases "r2 \<le> r1")
       subgoal using ip_cidr_set_intersect_subset_helper by blast
      by(simp)
  end

  lemma ip_cidr_intersect:
     "\<not> ipset_from_cidr b2 m2 \<subseteq> ipset_from_cidr b1 m1 \<Longrightarrow>
      \<not> ipset_from_cidr b1 m1 \<subseteq> ipset_from_cidr b2 m2 \<Longrightarrow>
      ipset_from_cidr b1 m1 \<inter> ipset_from_cidr b2 m2 = {}"
    apply(simp add: ipset_from_cidr_eq_ip_cidr_set)
    using ip_cidr_set_notsubset_empty_inter by blast

  text\<open>Computing the intersection of two IP address ranges in CIDR notation\<close>
  fun ipcidr_conjunct :: "('i::len word \<times> nat) \<Rightarrow> ('i word \<times> nat) \<Rightarrow> ('i word \<times> nat) option" where
    "ipcidr_conjunct (base1, m1) (base2, m2) = (
       if
         ipset_from_cidr base1 m1 \<inter> ipset_from_cidr base2 m2 = {}
       then
         None
       else if
         ipset_from_cidr base1 m1 \<subseteq> ipset_from_cidr base2 m2
       then
         Some (base1, m1)
       else
         Some (base2, m2)
      )"

  text\<open>Intersecting with an address with prefix length zero always yields a non-empty result.\<close>
  lemma ipcidr_conjunct_any: "ipcidr_conjunct a (x,0) \<noteq> None" "ipcidr_conjunct (y,0) b \<noteq> None"
     apply(cases a, simp add: ipset_from_cidr_0 ipset_from_cidr_not_empty)
    by(cases b, simp add: ipset_from_cidr_0 ipset_from_cidr_not_empty)

  lemma ipcidr_conjunct_correct: "(case ipcidr_conjunct (b1, m1) (b2, m2)
                                          of Some (bx, mx) \<Rightarrow> ipset_from_cidr bx mx
                                          |  None \<Rightarrow> {}) =
                                   (ipset_from_cidr b1 m1) \<inter> (ipset_from_cidr b2 m2)"
    apply(simp split: if_split_asm)
    using ip_cidr_intersect by fast
  declare ipcidr_conjunct.simps[simp del]

subsection\<open>Code Equations\<close>
  text\<open>Executable definition using word intervals\<close>
  lemma ipcidr_conjunct_word[code_unfold]:
  "ipcidr_conjunct ips1 ips2 = (
     if
      wordinterval_empty (wordinterval_intersection
                            (ipcidr_tuple_to_wordinterval ips1) (ipcidr_tuple_to_wordinterval ips2))
     then
       None
     else if
       wordinterval_subset (ipcidr_tuple_to_wordinterval ips1) (ipcidr_tuple_to_wordinterval ips2)
     then
       Some ips1
     else
       Some ips2
     )"
  apply(simp)
  apply(cases ips1, cases ips2, rename_tac b1 m1 b2 m2, simp)
  apply(auto simp add: wordinterval_to_set_ipcidr_tuple_to_wordinterval ipcidr_conjunct.simps
             split: if_split_asm)
  done

  (*with the code_unfold lemma before, this works!*)
  lemma "ipcidr_conjunct (0::32 word,0) (8,1) = Some (8, 1)" by eval
  export_code ipcidr_conjunct checking SML

  text\<open>making element check executable\<close>
  lemma addr_in_ipset_from_netmask_code[code_unfold]:
    "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: ipset_from_netmask_def Let_def)
  lemma addr_in_ipset_from_cidr_code[code_unfold]:
    "(addr::'i::len word) \<in> (ipset_from_cidr pre len) \<longleftrightarrow>
       (pre AND ((mask len) << (LENGTH('i) - len))) \<le> addr \<and>
        addr \<le> pre OR (mask (LENGTH('i) - len))"
  unfolding ipset_from_cidr_alt by simp

end