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

section {* Big sum and product over finite (non-empty) sets *}

theory Groups_Big
imports Finite_Set
begin

subsection {* Generic monoid operation over a set *}

no_notation times (infixl "*" 70)
no_notation Groups.one ("1")

locale comm_monoid_set = comm_monoid
begin

interpretation comp_fun_commute f
  by default (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) 1 A"

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

lemma empty [simp]:
  "F g {} = 1"
  by (simp add: eq_fold)

lemma insert [simp]:
  assumes "finite A" and "x \<notin> A"
  shows "F g (insert x A) = g x * F g A"
  using assms by (simp add: eq_fold)

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

lemma insert_remove:
  assumes "finite A"
  shows "F g (insert x A) = g x * F g (A - {x})"
  using assms by (cases "x \<in> A") (simp_all add: remove insert_absorb)

lemma neutral:
  assumes "\<forall>x\<in>A. g x = 1"
  shows "F g A = 1"
  using assms by (induct A rule: infinite_finite_induct) simp_all

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

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

corollary union_inter_neutral:
  assumes "finite A" and "finite B"
  and I0: "\<forall>x \<in> A \<inter> B. g x = 1"
  shows "F g (A \<union> B) = F g A * 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 * 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) * F g (B - A) * 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) * 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) * 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> z"
  obtains a where "a \<in> A" and "g a \<noteq> z"
proof -
  from assms have "\<exists>a\<in>A. g a \<noteq> z"
  proof (induct A rule: infinite_finite_induct)
    case (insert a A)
    then show ?case by simp (rule, simp)
  qed simp_all
  with that show thesis by blast
qed

lemma 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 `A = B`
  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) (insert assms, simp_all add: simp_implies_def)

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 Int 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
  assume "finite C"
  from UNION_disjoint [OF this assms]
  show ?thesis by simp
qed (auto dest: finite_UnionD intro: infinite)

lemma distrib:
  "F (\<lambda>x. g x * h x) A = F g A * F h A"
  using assms 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 (split g) (SIGMA x:A. B x)"
apply (subst Sigma_def)
apply (subst UNION_disjoint, assumption, simp)
 apply blast
apply (rule cong)
apply rule
apply (simp add: fun_eq_iff)
apply (subst UNION_disjoint, simp, simp)
 apply blast
apply (simp add: comp_def)
done

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

lemma mono_neutral_cong_left:
  assumes "finite T" and "S \<subseteq> T" and "\<forall>i \<in> T - S. h i = 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 `S \<subseteq> T` by blast
  have d: "S \<inter> (T - S) = {}" using `S \<subseteq> T` by blast
  from `finite T` `S \<subseteq> T` 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:
  "\<lbrakk> finite T; S \<subseteq> T; \<forall>i \<in> T - S. g i = 1; \<And>x. x \<in> S \<Longrightarrow> g x = h x \<rbrakk>
   \<Longrightarrow> F g T = F h S"
  by (auto intro!: mono_neutral_cong_left [symmetric])

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

lemma mono_neutral_right:
  "\<lbrakk> finite T;  S \<subseteq> T;  \<forall>i \<in> T - S. g i = 1 \<rbrakk> \<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
    assume "finite S"
    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 `finite S` by (intro mono_neutral_cong_left) auto
    finally show ?thesis .
  qed simp
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) = 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 = 1}) (h ` A - h ` {x \<in> A. (g \<circ> h) x = 1})"
    using nz by (auto intro!: inj_onI simp: bij_betw_def)
qed (insert `finite A`, 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 1) S = (if a \<in> S then b a else 1)"
proof-
  let ?f = "(\<lambda>k. if k=a then b k else 1)"
  { assume a: "a \<notin> S"
    hence "\<forall>k\<in>S. ?f k = 1" by simp
    hence ?thesis  using a by simp }
  moreover
  { assume a: "a \<in> S"
    let ?A = "S - {a}"
    let ?B = "{a}"
    have eq: "S = ?A \<union> ?B" using a 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 * F ?f ?B"
      using union_disjoint [OF fAB dj, of ?f, unfolded eq [symmetric]]
      by simp
    then have ?thesis using a by simp }
  ultimately show ?thesis by blast
qed

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

lemma If_cases:
  fixes P :: "'b \<Rightarrow> bool" and g h :: "'b \<Rightarrow> 'a"
  assumes fA: "finite A"
  shows "F (\<lambda>x. if P x then h x else g x) A =
    F h (A \<inter> {x. P x}) * 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 fA
  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 (split g) (A <*> B)"
apply (rule sym)
apply (cases "finite A")
 apply (cases "finite B")
  apply (simp add: Sigma)
 apply (cases "A={}", 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 1) A"
proof -
  let ?g = "\<lambda>x. if x \<in> A \<inter> B then g x else 1"
  have "\<forall>i\<in>A - A \<inter> B. (if i \<in> A \<inter> B then g i else 1) = 1"
   by simp
  moreover have "A \<inter> B \<subseteq> A" by blast
  ultimately have "F ?g (A \<inter> B) = F ?g A" using `finite A`
    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 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 = 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 = 1"
    and H: "F g (\<Union>B) = (F o F) g B" by auto
  then have "F g (A \<union> \<Union>B) = F g A * F g (\<Union>B)"
    by (simp add: union_inter_neutral)
  with `finite B` `A \<notin> B` 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 * F (g \<circ> Inr) B"
proof -
  have "A <+> B = Inl ` A \<union> Inr ` B" by auto
  moreover from fin have "finite (Inl ` A :: ('b + 'c) set)" "finite (Inr ` B :: ('b + 'c) set)"
    by auto
  moreover have "Inl ` A \<inter> Inr ` B = ({} :: ('b + 'c) set)" by auto
  moreover have "inj_on (Inl :: 'b \<Rightarrow> 'b + 'c) A" "inj_on (Inr :: 'c \<Rightarrow> 'b + 'c) 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 = 1" "\<And>b. b \<in> C - B \<Longrightarrow> h b = 1"
  shows "F g A = F h B \<longleftrightarrow> F g C = F h C"
proof -
  from `finite C` subset have
    "finite A" and "finite B" and "finite (C - A)" and "finite (C - B)"
    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)) * F g (C - A - A) * F g (A \<inter> (C - A))"
    using `finite A` `finite (C - A)` by (simp only: union_diff2)
  finally have P: "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)) * F h (C - B - B) * F h (B \<inter> (C - B))"
    using `finite B` `finite (C - B)` by (simp only: union_diff2)
  finally have Q: "F h C = F h B" using trivial by simp
  from P Q 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 = 1" "\<And>b. b \<in> C - B \<Longrightarrow> h b = 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

notation times (infixl "*" 70)
notation Groups.one ("1")

subsection {* Generalized summation over a set *}

context comm_monoid_add
begin

definition setsum :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'a"
where
  "setsum = comm_monoid_set.F plus 0"

sublocale setsum!: comm_monoid_set plus 0
where
  "comm_monoid_set.F plus 0 = setsum"
proof -
  show "comm_monoid_set plus 0" ..
  then interpret setsum!: comm_monoid_set plus 0 .
  from setsum_def show "comm_monoid_set.F plus 0 = setsum" by rule
qed

abbreviation
  Setsum ("\<Sum>_" [1000] 999) where
  "\<Sum>A \<equiv> setsum (%x. x) A"

end

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

syntax
  "_setsum" :: "pttrn => 'a set => 'b => 'b::comm_monoid_add"    ("(3SUM _:_. _)" [0, 51, 10] 10)
syntax (xsymbols)
  "_setsum" :: "pttrn => 'a set => 'b => 'b::comm_monoid_add"    ("(3\<Sum>_\<in>_. _)" [0, 51, 10] 10)
syntax (HTML output)
  "_setsum" :: "pttrn => 'a set => 'b => 'b::comm_monoid_add"    ("(3\<Sum>_\<in>_. _)" [0, 51, 10] 10)

translations -- {* Beware of argument permutation! *}
  "SUM i:A. b" == "CONST setsum (%i. b) A"
  "\<Sum>i\<in>A. b" == "CONST setsum (%i. b) A"

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

syntax
  "_qsetsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a" ("(3SUM _ |/ _./ _)" [0,0,10] 10)
syntax (xsymbols)
  "_qsetsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a" ("(3\<Sum>_ | (_)./ _)" [0,0,10] 10)
syntax (HTML output)
  "_qsetsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a" ("(3\<Sum>_ | (_)./ _)" [0,0,10] 10)

translations
  "SUM x|P. t" => "CONST setsum (%x. t) {x. P}"
  "\<Sum>x|P. t" => "CONST setsum (%x. t) {x. P}"

print_translation {*
let
  fun setsum_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 "_qsetsum"} $ Syntax_Trans.mark_bound_abs (x, Tx) $ P' $ t'
          end
    | setsum_tr' _ = raise Match;
in [(@{const_syntax setsum}, K setsum_tr')] end
*}

text {* TODO generalization candidates *}

lemma setsum_image_gen:
  assumes fS: "finite S"
  shows "setsum g S = setsum (\<lambda>y. setsum g {x. x \<in> S \<and> f x = y}) (f ` S)"
proof-
  { fix x assume "x \<in> S" then have "{y. y\<in> f`S \<and> f x = y} = {f x}" by auto }
  hence "setsum g S = setsum (\<lambda>x. setsum (\<lambda>y. g x) {y. y\<in> f`S \<and> f x = y}) S"
    by simp
  also have "\<dots> = setsum (\<lambda>y. setsum g {x. x \<in> S \<and> f x = y}) (f ` S)"
    by (rule setsum.commute_restrict [OF fS finite_imageI [OF fS]])
  finally show ?thesis .
qed

subsubsection {* Properties in more restricted classes of structures *}

lemma setsum_Un: "finite A ==> finite B ==>
  (setsum f (A Un B) :: 'a :: ab_group_add) =
   setsum f A + setsum f B - setsum f (A Int B)"
by (subst setsum.union_inter [symmetric], auto simp add: algebra_simps)

lemma setsum_Un2:
  assumes "finite (A \<union> B)"
  shows "setsum f (A \<union> B) = setsum f (A - B) + setsum f (B - A) + setsum 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 setsum.union_disjoint, auto)+
qed

lemma setsum_diff1: "finite A \<Longrightarrow>
  (setsum f (A - {a}) :: ('a::ab_group_add)) =
  (if a:A then setsum f A - f a else setsum f A)"
by (erule finite_induct) (auto simp add: insert_Diff_if)

lemma setsum_diff:
  assumes le: "finite A" "B \<subseteq> A"
  shows "setsum f (A - B) = setsum f A - ((setsum f B)::('a::ab_group_add))"
proof -
  from le have finiteB: "finite B" using finite_subset by auto
  show ?thesis using finiteB le
  proof induct
    case empty
    thus ?case by auto
  next
    case (insert x F)
    thus ?case using le finiteB
      by (simp add: Diff_insert[where a=x and B=F] setsum_diff1 insert_absorb)
  qed
qed

lemma setsum_mono:
  assumes le: "\<And>i. i\<in>K \<Longrightarrow> f (i::'a) \<le> ((g i)::('b::{comm_monoid_add, ordered_ab_semigroup_add}))"
  shows "(\<Sum>i\<in>K. f i) \<le> (\<Sum>i\<in>K. g i)"
proof (cases "finite K")
  case True
  thus ?thesis using le
  proof induct
    case empty
    thus ?case by simp
  next
    case insert
    thus ?case using add_mono by fastforce
  qed
next
  case False then show ?thesis by simp
qed

lemma setsum_strict_mono:
  fixes f :: "'a \<Rightarrow> 'b::{ordered_cancel_ab_semigroup_add,comm_monoid_add}"
  assumes "finite A"  "A \<noteq> {}"
    and "!!x. x:A \<Longrightarrow> f x < g x"
  shows "setsum f A < setsum g A"
  using assms
proof (induct rule: finite_ne_induct)
  case singleton thus ?case by simp
next
  case insert thus ?case by (auto simp: add_strict_mono)
qed

lemma setsum_strict_mono_ex1:
fixes f :: "'a \<Rightarrow> 'b::{comm_monoid_add, ordered_cancel_ab_semigroup_add}"
assumes "finite A" and "ALL x:A. f x \<le> g x" and "EX a:A. f a < g a"
shows "setsum f A < setsum g A"
proof-
  from assms(3) obtain a where a: "a:A" "f a < g a" by blast
  have "setsum f A = setsum f ((A-{a}) \<union> {a})"
    by(simp add:insert_absorb[OF `a:A`])
  also have "\<dots> = setsum f (A-{a}) + setsum f {a}"
    using `finite A` by(subst setsum.union_disjoint) auto
  also have "setsum f (A-{a}) \<le> setsum g (A-{a})"
    by(rule setsum_mono)(simp add: assms(2))
  also have "setsum f {a} < setsum g {a}" using a by simp
  also have "setsum g (A - {a}) + setsum g {a} = setsum g((A-{a}) \<union> {a})"
    using `finite A` by(subst setsum.union_disjoint[symmetric]) auto
  also have "\<dots> = setsum g A" by(simp add:insert_absorb[OF `a:A`])
  finally show ?thesis by (auto simp add: add_right_mono add_strict_left_mono)
qed

lemma setsum_negf:
  "setsum (%x. - (f x)::'a::ab_group_add) A = - setsum f A"
proof (cases "finite A")
  case True thus ?thesis by (induct set: finite) auto
next
  case False thus ?thesis by simp
qed

lemma setsum_subtractf:
  "setsum (%x. ((f x)::'a::ab_group_add) - g x) A =
    setsum f A - setsum g A"
  using setsum.distrib [of f "- g" A] by (simp add: setsum_negf)

lemma setsum_nonneg:
  assumes nn: "\<forall>x\<in>A. (0::'a::{ordered_ab_semigroup_add,comm_monoid_add}) \<le> f x"
  shows "0 \<le> setsum f A"
proof (cases "finite A")
  case True thus ?thesis using nn
  proof induct
    case empty then show ?case by simp
  next
    case (insert x F)
    then have "0 + 0 \<le> f x + setsum f F" by (blast intro: add_mono)
    with insert show ?case by simp
  qed
next
  case False thus ?thesis by simp
qed

lemma setsum_nonpos:
  assumes np: "\<forall>x\<in>A. f x \<le> (0::'a::{ordered_ab_semigroup_add,comm_monoid_add})"
  shows "setsum f A \<le> 0"
proof (cases "finite A")
  case True thus ?thesis using np
  proof induct
    case empty then show ?case by simp
  next
    case (insert x F)
    then have "f x + setsum f F \<le> 0 + 0" by (blast intro: add_mono)
    with insert show ?case by simp
  qed
next
  case False thus ?thesis by simp
qed

lemma setsum_nonneg_leq_bound:
  fixes f :: "'a \<Rightarrow> 'b::{ordered_ab_group_add}"
  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 -
  have "0 \<le> (\<Sum> i \<in> s - {i}. f i)" and "0 \<le> f i"
    using assms by (auto intro!: setsum_nonneg)
  moreover
  have "(\<Sum> i \<in> s - {i}. f i) + f i = B"
    using assms by (simp add: setsum_diff1)
  ultimately show ?thesis by auto
qed

lemma setsum_nonneg_0:
  fixes f :: "'a \<Rightarrow> 'b::{ordered_ab_group_add}"
  assumes "finite s" and pos: "\<And> i. i \<in> s \<Longrightarrow> f i \<ge> 0"
  and "(\<Sum> i \<in> s. f i) = 0" and i: "i \<in> s"
  shows "f i = 0"
  using setsum_nonneg_leq_bound[OF assms] pos[OF i] by auto

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

lemma setsum_le_included:
  fixes f :: "'a \<Rightarrow> 'b::ordered_comm_monoid_add"
  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 "setsum f s \<le> setsum g t"
proof -
  have "setsum f s \<le> setsum (\<lambda>y. setsum g {x. x\<in>t \<and> i x = y}) s"
  proof (rule setsum_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> setsum g {x \<in> t. i x = y}" (is "?A y \<le> ?B y")
      using order_trans[of "?A (i z)" "setsum g {z}" "?B (i z)", intro]
      by (auto intro!: setsum_mono2)
  qed
  also have "... \<le> setsum (\<lambda>y. setsum g {x. x\<in>t \<and> i x = y}) (i ` t)"
    using assms(2-4) by (auto intro!: setsum_mono2 setsum_nonneg)
  also have "... \<le> setsum g t"
    using assms by (auto simp: setsum_image_gen[symmetric])
  finally show ?thesis .
qed

lemma setsum_mono3: "finite B ==> A <= B ==>
    ALL x: B - A.
      0 <= ((f x)::'a::{comm_monoid_add,ordered_ab_semigroup_add}) ==>
        setsum f A <= setsum f B"
  apply (subgoal_tac "setsum f B = setsum f A + setsum f (B - A)")
  apply (erule ssubst)
  apply (subgoal_tac "setsum f A + 0 <= setsum f A + setsum f (B - A)")
  apply simp
  apply (rule add_left_mono)
  apply (erule setsum_nonneg)
  apply (subst setsum.union_disjoint [THEN sym])
  apply (erule finite_subset, assumption)
  apply (rule finite_subset)
  prefer 2
  apply assumption
  apply (auto simp add: sup_absorb2)
done

lemma setsum_right_distrib:
  fixes f :: "'a => ('b::semiring_0)"
  shows "r * setsum f A = setsum (%n. r * f n) A"
proof (cases "finite A")
  case True
  thus ?thesis
  proof induct
    case empty thus ?case by simp
  next
    case (insert x A) thus ?case by (simp add: distrib_left)
  qed
next
  case False thus ?thesis by simp
qed

lemma setsum_left_distrib:
  "setsum f A * (r::'a::semiring_0) = (\<Sum>n\<in>A. f n * r)"
proof (cases "finite A")
  case True
  then show ?thesis
  proof induct
    case empty thus ?case by simp
  next
    case (insert x A) thus ?case by (simp add: distrib_right)
  qed
next
  case False thus ?thesis by simp
qed

lemma setsum_divide_distrib:
  "setsum f A / (r::'a::field) = (\<Sum>n\<in>A. f n / r)"
proof (cases "finite A")
  case True
  then show ?thesis
  proof induct
    case empty thus ?case by simp
  next
    case (insert x A) thus ?case by (simp add: add_divide_distrib)
  qed
next
  case False thus ?thesis by simp
qed

lemma setsum_abs[iff]:
  fixes f :: "'a => ('b::ordered_ab_group_add_abs)"
  shows "abs (setsum f A) \<le> setsum (%i. abs(f i)) A"
proof (cases "finite A")
  case True
  thus ?thesis
  proof induct
    case empty thus ?case by simp
  next
    case (insert x A)
    thus ?case by (auto intro: abs_triangle_ineq order_trans)
  qed
next
  case False thus ?thesis by simp
qed

lemma setsum_abs_ge_zero[iff]:
  fixes f :: "'a => ('b::ordered_ab_group_add_abs)"
  shows "0 \<le> setsum (%i. abs(f i)) A"
proof (cases "finite A")
  case True
  thus ?thesis
  proof induct
    case empty thus ?case by simp
  next
    case (insert x A) thus ?case by auto
  qed
next
  case False thus ?thesis by simp
qed

lemma abs_setsum_abs[simp]:
  fixes f :: "'a => ('b::ordered_ab_group_add_abs)"
  shows "abs (\<Sum>a\<in>A. abs(f a)) = (\<Sum>a\<in>A. abs(f a))"
proof (cases "finite A")
  case True
  thus ?thesis
  proof induct
    case empty thus ?case by simp
  next
    case (insert a A)
    hence "\<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 have "\<dots> = \<bar>\<bar>f a\<bar> + \<bar>\<Sum>a\<in>A. \<bar>f a\<bar>\<bar>\<bar>"  using insert 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 have "\<dots> = (\<Sum>a\<in>insert a A. \<bar>f a\<bar>)" using insert by simp
    finally show ?case .
  qed
next
  case False thus ?thesis by simp
qed

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

lemma setsum_product:
  fixes f :: "'a => ('b::semiring_0)"
  shows "setsum f A * setsum g B = (\<Sum>i\<in>A. \<Sum>j\<in>B. f i * g j)"
  by (simp add: setsum_right_distrib setsum_left_distrib) (rule setsum.commute)

lemma setsum_mult_setsum_if_inj:
fixes f :: "'a => ('b::semiring_0)"
shows "inj_on (%(a,b). f a * g b) (A \<times> B) ==>
  setsum f A * setsum g B = setsum id {f a * g b|a b. a:A & b:B}"
by(auto simp: setsum_product setsum.cartesian_product
        intro!:  setsum.reindex_cong[symmetric])

lemma setsum_SucD: "setsum f A = Suc n ==> EX a:A. 0 < f a"
apply (case_tac "finite A")
 prefer 2 apply simp
apply (erule rev_mp)
apply (erule finite_induct, auto)
done

lemma setsum_eq_0_iff [simp]:
  "finite F ==> (setsum f F = 0) = (ALL a:F. f a = (0::nat))"
  by (induct set: finite) auto

lemma setsum_eq_Suc0_iff: "finite A \<Longrightarrow>
  setsum f A = Suc 0 \<longleftrightarrow> (EX a:A. f a = Suc 0 & (ALL b:A. a\<noteq>b \<longrightarrow> f b = 0))"
apply(erule finite_induct)
apply (auto simp add:add_is_1)
done

lemmas setsum_eq_1_iff = setsum_eq_Suc0_iff[simplified One_nat_def[symmetric]]

lemma setsum_Un_nat: "finite A ==> finite B ==>
  (setsum f (A Un B) :: nat) = setsum f A + setsum f B - setsum f (A Int B)"
  -- {* For the natural numbers, we have subtraction. *}
by (subst setsum.union_inter [symmetric], auto simp add: algebra_simps)

lemma setsum_diff1_nat: "(setsum f (A - {a}) :: nat) =
  (if a:A then setsum f A - f a else setsum f A)"
apply (case_tac "finite A")
 prefer 2 apply simp
apply (erule finite_induct)
 apply (auto simp add: insert_Diff_if)
apply (drule_tac a = a in mk_disjoint_insert, auto)
done

lemma setsum_diff_nat:
assumes "finite B" and "B \<subseteq> A"
shows "(setsum f (A - B) :: nat) = (setsum f A) - (setsum f B)"
using assms
proof induct
  show "setsum f (A - {}) = (setsum f A) - (setsum f {})" by simp
next
  fix F x assume finF: "finite F" and xnotinF: "x \<notin> F"
    and xFinA: "insert x F \<subseteq> A"
    and IH: "F \<subseteq> A \<Longrightarrow> setsum f (A - F) = setsum f A - setsum f F"
  from xnotinF xFinA have xinAF: "x \<in> (A - F)" by simp
  from xinAF have A: "setsum f ((A - F) - {x}) = setsum f (A - F) - f x"
    by (simp add: setsum_diff1_nat)
  from xFinA have "F \<subseteq> A" by simp
  with IH have "setsum f (A - F) = setsum f A - setsum f F" by simp
  with A have B: "setsum f ((A - F) - {x}) = setsum f A - setsum f F - f x"
    by simp
  from xnotinF have "A - insert x F = (A - F) - {x}" by auto
  with B have C: "setsum f (A - insert x F) = setsum f A - setsum f F - f x"
    by simp
  from finF xnotinF have "setsum f (insert x F) = setsum f F + f x" by simp
  with C have "setsum f (A - insert x F) = setsum f A - setsum f (insert x F)"
    by simp
  thus "setsum f (A - insert x F) = setsum f A - setsum f (insert x F)" by simp
qed

lemma setsum_comp_morphism:
  assumes "h 0 = 0" and "\<And>x y. h (x + y) = h x + h y"
  shows "setsum (h \<circ> g) A = h (setsum g A)"
proof (cases "finite A")
  case False then show ?thesis by (simp add: assms)
next
  case True then show ?thesis by (induct A) (simp_all add: assms)
qed

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

subsubsection {* Cardinality as special case of @{const setsum} *}

lemma card_eq_setsum:
  "card A = setsum (\<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 setsum.eq_fold)
qed

lemma setsum_constant [simp]:
  "(\<Sum>x \<in> A. y) = of_nat (card A) * y"
apply (cases "finite A")
apply (erule finite_induct)
apply (auto simp add: algebra_simps)
done

lemma setsum_Suc: "setsum (%x. Suc(f x)) A = setsum f A + card A"
using setsum.distrib[of f "%_. 1" A] by(simp)

lemma setsum_bounded:
  assumes le: "\<And>i. i\<in>A \<Longrightarrow> f i \<le> (K::'a::{semiring_1, ordered_ab_semigroup_add})"
  shows "setsum f A \<le> of_nat (card A) * K"
proof (cases "finite A")
  case True
  thus ?thesis using le setsum_mono[where K=A and g = "%x. K"] by simp
next
  case False thus ?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_setsum setsum.UNION_disjoint del: setsum_constant)
qed

lemma card_Union_disjoint:
  "finite C ==> (ALL A:C. finite A) ==>
   (ALL A:C. ALL B:C. A \<noteq> B --> A Int B = {})
   ==> card (Union C) = setsum card C"
apply (frule card_UN_disjoint [of C id])
apply simp_all
done

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

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

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

subsubsection {* Cardinality of products *}

lemma card_SigmaI [simp]:
  "\<lbrakk> finite A; ALL a:A. finite (B a) \<rbrakk>
  \<Longrightarrow> card (SIGMA x: A. B x) = (\<Sum>a\<in>A. card (B a))"
by(simp add: card_eq_setsum setsum.Sigma del:setsum_constant)

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

lemma card_cartesian_product: "card (A <*> 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} <*> A) = card(A)"
by (simp add: card_cartesian_product)

subsection {* Generalized product over a set *}

context comm_monoid_mult
begin

definition setprod :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'a"
where
  "setprod = comm_monoid_set.F times 1"

sublocale setprod!: comm_monoid_set times 1
where
  "comm_monoid_set.F times 1 = setprod"
proof -
  show "comm_monoid_set times 1" ..
  then interpret setprod!: comm_monoid_set times 1 .
  from setprod_def show "comm_monoid_set.F times 1 = setprod" by rule
qed

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

end

syntax
  "_setprod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(3PROD _:_. _)" [0, 51, 10] 10)
syntax (xsymbols)
  "_setprod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(3\<Prod>_\<in>_. _)" [0, 51, 10] 10)
syntax (HTML output)
  "_setprod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(3\<Prod>_\<in>_. _)" [0, 51, 10] 10)

translations -- {* Beware of argument permutation! *}
  "PROD i:A. b" == "CONST setprod (%i. b) A"
  "\<Prod>i\<in>A. b" == "CONST setprod (%i. b) A"

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

syntax
  "_qsetprod" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a" ("(3PROD _ |/ _./ _)" [0,0,10] 10)
syntax (xsymbols)
  "_qsetprod" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a" ("(3\<Prod>_ | (_)./ _)" [0,0,10] 10)
syntax (HTML output)
  "_qsetprod" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a" ("(3\<Prod>_ | (_)./ _)" [0,0,10] 10)

translations
  "PROD x|P. t" => "CONST setprod (%x. t) {x. P}"
  "\<Prod>x|P. t" => "CONST setprod (%x. t) {x. P}"

context comm_monoid_mult
begin

lemma setprod_dvd_setprod:
  "(\<And>a. a \<in> A \<Longrightarrow> f a dvd g a) \<Longrightarrow> setprod f A dvd setprod 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 "setprod f A dvd setprod g A" by simp_all
  then obtain r s where "g a = f a * r" and "setprod g A = setprod f A * s" by (auto elim!: dvdE)
  then have "g a * setprod g A = f a * setprod f A * (r * s)" by (simp add: ac_simps)
  with insert.hyps show ?case by (auto intro: dvdI)
qed

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

end

subsubsection {* Properties in more restricted classes of structures *}

context comm_semiring_1
begin

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

lemma dvd_setprodI [intro]:
  assumes "finite A" and "a \<in> A"
  shows "f a dvd setprod f A"
  using assms by auto

lemma setprod_zero:
  assumes "finite A" and "\<exists>a\<in>A. f a = 0"
  shows "setprod 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 * setprod f A = 0" by rule (simp_all add: insert)
  with insert show ?case by simp
qed

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

end

lemma setprod_zero_iff [simp]:
  assumes "finite A"
  shows "setprod f A = (0::'a::{comm_semiring_1,no_zero_divisors}) \<longleftrightarrow> (\<exists>a\<in>A. f a = 0)"
  using assms by (induct A) (auto simp: no_zero_divisors)

lemma (in field) setprod_diff1:
  "finite A \<Longrightarrow> f a \<noteq> 0 \<Longrightarrow>
    (setprod f (A - {a})) = (if a \<in> A then setprod f A / f a else setprod f A)"
  by (induct A rule: finite_induct) (auto simp add: insert_Diff_if)

lemma (in field_inverse_zero) setprod_inversef:
  "finite A \<Longrightarrow> setprod (inverse \<circ> f) A = inverse (setprod f A)"
  by (induct A rule: finite_induct) simp_all

lemma (in field_inverse_zero) setprod_dividef:
  "finite A \<Longrightarrow> (\<Prod>x\<in>A. f x / g x) = setprod f A / setprod g A"
  using setprod_inversef [of A g] by (simp add: divide_inverse setprod.distrib)

lemma setprod_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 "setprod f (A \<union> B) = setprod f A * setprod f B / setprod f (A \<inter> B)"
proof -
  from assms have "setprod f A * setprod f B = setprod f (A \<union> B) * setprod f (A \<inter> B)"
    by (simp add: setprod.union_inter [symmetric, of A B])
  with assms show ?thesis by simp
qed

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

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

lemma (in linordered_semidom) setprod_mono:
  assumes "\<forall>i\<in>A. 0 \<le> f i \<and> f i \<le> g i"
  shows "setprod f A \<le> setprod g A"
  using assms by (induct A rule: infinite_finite_induct)
    (auto intro!: setprod_nonneg mult_mono)

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

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

lemma setprod_pos_nat:
  "finite A \<Longrightarrow> (\<forall>a\<in>A. f a > (0::nat)) \<Longrightarrow> setprod f A > 0"
  using setprod_zero_iff by (simp del: neq0_conv add: neq0_conv [symmetric])

lemma setprod_pos_nat_iff [simp]:
  "finite A \<Longrightarrow> setprod f A > 0 \<longleftrightarrow> (\<forall>a\<in>A. f a > (0::nat))"
  using setprod_zero_iff by (simp del:neq0_conv add:neq0_conv [symmetric])

end


theory Expressions
imports Main
begin

(* Definição de algumas primitivas binárias sobre naturais e inteiros *)
primrec "add"::"nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add x 0 = x" |
  "add x (Suc y) = Suc (add x y)"

primrec "mult"::"nat \<Rightarrow> nat \<Rightarrow> nat" where
  "mult x 0 = 0" |
  "mult x (Suc y) = add x (mult x y)"

definition "addi"::"int \<Rightarrow> int \<Rightarrow> int" where
  "addi x y = x + y"

definition "multi"::"int \<Rightarrow> int \<Rightarrow> int" where
  "multi x y = x * y"

(* Definição de um tipo indutivo para expressões sobre um tipo genérico *)
datatype 'a Exp = Const 'a
                | Var nat
                | App "'a \<Rightarrow> 'a \<Rightarrow> 'a" "'a Exp" "'a Exp"

(* Alguns termos da linguagem de expressões *)
term "Var 0"
term "Const (1::int)"
term "Const (1::nat)"
term "App add (Var 0) (Const (1::nat))"
term "App mult (Var 0) (Const (1::nat))"
term "App addi (Var 0) (App multi (Const (1::int)) (Var 1))"

(* Primitiva recursiva que efetua a valoração de uma expressão *)
primrec eval :: "'a Exp \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
    "eval (Const b) env = b" |
    "eval (Var x) env = env x" |
    "eval (App f e1 e2) env = (f (eval e1 env) (eval e2 env))"

value "eval (App add (Var 0) (Const 1)) (%x::nat. 2)"
value "eval (App mult (Var 0) (Const (1::nat))) (%x::nat. 2)"
value "eval (App addi (Var 0) (App multi (Const (1::int)) (Const (4::int)))) (%x::nat. 2)"
value "eval (App multi (App addi (Var 0) (Const 2)) (Const 3)) (%x::nat. 2)"

(* Definição de um tipo indutivo para instruções em uma pilha *)
datatype 'a Instr = IConst 'a
                  | ILoad nat
                  | IApp "'a \<Rightarrow> 'a \<Rightarrow> 'a"

(* Definição de uma primitiva recursiva que compila uma expressão em uma lista de instruções *)
primrec compile :: "'a Exp \<Rightarrow> 'a Instr list" where
  "compile (Const b) = [IConst b]" |
  "compile (Var x) = [ILoad x]" |
  "compile (App f e1 e2) = (compile e2) @ (compile e1 ) @ [IApp f]"

value "compile (App add (Var 0) (Const 1))"
value "compile (App multi (Var 0) (Const (1::int)))"
value "compile (App addi (Var 0) (App multi (Const (1::int)) (Const (4::int))))"

(* Primitiva recursiva que executa uma lista de instruções *)
primrec exec :: "'a Instr list \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "exec [] env vs = vs" |
  "exec (i # is) env vs = (case i of
      IConst v \<Rightarrow> exec is env (v # vs)
    | ILoad x  \<Rightarrow> exec is env ((env x) # vs)
    | IApp f   \<Rightarrow> exec is env ((f (hd vs) (hd (tl vs))) # (tl (tl vs))))"

value "exec [] (%x::nat. 1) []"
value "exec (compile (App add (Var 0) (Const 1))) (%x::nat. 1) []"
value "exec (compile (App multi (Var 0) (Const (1::int)))) (%x::nat. 1) []"
value "exec (compile (App addi (Var 0) (App multi (Const (1::int)) (Const (4::int))))) (%x::nat. 1) []"

(* Prova da correture do compilador *)
(* Extraída de "Practical Theorem Proving with Isabelle/Isar Lecture Notes", por Jeremy Siek *)

(* Lema auxiliar  *)
lemma exec_app [rule_format]:
  "\<forall>vs. exec (xs@ys) s vs = exec ys s (exec xs s vs)"
  apply(induct xs, simp, auto)
  apply(case_tac a, auto) done

(* Prova do teorema *)
theorem "\<forall>vs. exec (compile e) env vs = (eval e env) # vs"
  proof (induct e)
    fix v
    show "\<forall>vs. exec (compile (Const v)) env vs = (eval (Const v) env) # vs" by simp
    next
      fix x
      show "\<forall>vs. exec (compile (Var x)) env vs = eval (Var x) env # vs" by simp
      next
        fix f e1 e2
          assume IH1: "\<forall>vs. exec (compile e1) env vs = eval e1 env # vs"
          and IH2: "\<forall>vs. exec (compile e2) env vs = eval e2 env # vs"
          show "\<forall>vs. exec (compile (App f e1 e2)) env vs = eval (App f e1 e2) env # vs"
          proof
            fix vs
              have "exec (compile (App f e1 e2)) env vs = exec ((compile e2) @ (compile e1) @ [IApp f ]) env vs" by simp also
              have "\<dots> = exec ((compile e1) @ [IApp f ]) env (exec (compile e2) env vs)" using exec_app by blast also
              have "\<dots> = exec [IApp f] env (exec (compile e1) env (exec (compile e2) env vs))" using exec_app by blast also
              have "\<dots> = exec [IApp f ] env (exec (compile e1) env (eval e2 env # vs))"  using IH2 by simp also
              have "\<dots> = exec [IApp f ] env ((eval e1 env) # (eval e2 env # vs))" using IH1 by simp also
              have "\<dots> = (f (eval e1 env) (eval e2 env))#vs" by simp also
              have "\<dots> = eval (App f e1 e2) env # vs" by simp
              finally
                show "exec (compile (App f e1 e2)) env vs = eval (App f e1 e2) env # vs" by blast
          qed
  qed


(* Author: Tobias Nipkow *)

section \<open>Tree Rotations\<close>

theory Tree_Rotations
imports "HOL-Library.Tree"
begin

text \<open>How to transform a tree into a list and into any other tree (with the same @{const inorder})
by rotations.\<close>

fun is_list :: "'a tree \<Rightarrow> bool" where
"is_list (Node l _ r) = (l = Leaf \<and> is_list r)" |
"is_list Leaf = True"

text \<open>Termination proof via measure function. NB @{term "size t - rlen t"} works for
the actual rotation equation but not for the second equation.\<close>

fun rlen :: "'a tree \<Rightarrow> nat" where
"rlen Leaf = 0" |
"rlen (Node l x r) = rlen r + 1"

lemma rlen_le_size: "rlen t \<le> size t"
by(induction t) auto

subsection \<open>Without positions\<close>

function (sequential) list_of :: "'a tree \<Rightarrow> 'a tree" where
"list_of (Node (Node A a B) b C) = list_of (Node A a (Node B b C))" |
"list_of (Node Leaf a A) = Node Leaf a (list_of A)" |
"list_of Leaf = Leaf"
by pat_completeness auto

termination
proof
  let ?R = "measure(\<lambda>t. 2*size t - rlen t)"
  show "wf ?R" by (auto simp add: mlex_prod_def)

  fix A a B b C
  show "(Node A a (Node B b C), Node (Node A a B) b C) \<in> ?R"
    using rlen_le_size[of C] by(simp)

  fix a A show "(A, Node Leaf a A) \<in> ?R" using rlen_le_size[of A] by(simp)
qed

lemma is_list_rot: "is_list(list_of t)"
by (induction t rule: list_of.induct) auto

lemma inorder_rot: "inorder(list_of t) = inorder t"
by (induction t rule: list_of.induct) auto

subsection \<open>With positions\<close>

datatype dir = L | R

type_synonym "pos" = "dir list"

function (sequential) rotR_poss :: "'a tree \<Rightarrow> pos list" where
"rotR_poss (Node (Node A a B) b C) = [] # rotR_poss (Node A a (Node B b C))" |
"rotR_poss (Node Leaf a A) = map (Cons R) (rotR_poss A)" |
"rotR_poss Leaf = []"
by pat_completeness auto

termination
proof
  let ?R = "measure(\<lambda>t. 2*size t - rlen t)"
  show "wf ?R" by (auto simp add: mlex_prod_def)

  fix A a B b C
  show "(Node A a (Node B b C), Node (Node A a B) b C) \<in> ?R"
    using rlen_le_size[of C] by(simp)

  fix a A show "(A, Node Leaf a A) \<in> ?R" using rlen_le_size[of A] by(simp)
qed

fun rotR :: "'a tree \<Rightarrow> 'a tree" where
"rotR (Node (Node A a B) b C) = Node A a (Node B b C)"

fun rotL :: "'a tree \<Rightarrow> 'a tree" where
"rotL (Node A a (Node B b C)) = Node (Node A a B) b C"

fun apply_at :: "('a tree \<Rightarrow> 'a tree) \<Rightarrow> pos \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "apply_at f [] t = f t"
| "apply_at f (L # ds) (Node l a r) = Node (apply_at f ds l) a r"
| "apply_at f (R # ds) (Node l a r) = Node l a (apply_at f ds r)"

fun apply_ats :: "('a tree \<Rightarrow> 'a tree) \<Rightarrow> pos list \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"apply_ats _ [] t = t" |
"apply_ats f (p#ps) t = apply_ats f ps (apply_at f p t)"

lemma apply_ats_append:
  "apply_ats f (ps\<^sub>1 @ ps\<^sub>2) t = apply_ats f ps\<^sub>2 (apply_ats f ps\<^sub>1 t)"
by (induction ps\<^sub>1 arbitrary: t) auto

abbreviation "rotRs \<equiv> apply_ats rotR"
abbreviation "rotLs \<equiv> apply_ats rotL"

lemma apply_ats_map_R: "apply_ats f (map ((#) R) ps) \<langle>l, a, r\<rangle> = Node l a (apply_ats f ps r)"
by(induction ps arbitrary: r) auto

lemma inorder_rotRs_poss: "inorder (rotRs (rotR_poss t) t) = inorder t"
apply(induction t rule: rotR_poss.induct)
apply(auto simp: apply_ats_map_R)
done

lemma is_list_rotRs: "is_list (rotRs (rotR_poss t) t)"
apply(induction t rule: rotR_poss.induct)
apply(auto simp: apply_ats_map_R)
done

lemma "is_list (rotRs ps t) \<longrightarrow> length ps \<le> length(rotR_poss t)"
quickcheck[expect=counterexample]
oops

lemma length_rotRs_poss: "length (rotR_poss t) = size t - rlen t"
proof(induction t rule: rotR_poss.induct)
  case (1 A a B b C)
  then show ?case using rlen_le_size[of C] by simp
qed auto

lemma is_list_inorder_same:
  "is_list t1 \<Longrightarrow> is_list t2 \<Longrightarrow> inorder t1 = inorder t2 \<Longrightarrow> t1 = t2"
proof(induction t1 arbitrary: t2)
  case Leaf
  then show ?case by simp
next
  case Node
  then show ?case by (cases t2) simp_all
qed

lemma rot_id: "rotLs (rev (rotR_poss t)) (rotRs (rotR_poss t) t) = t"
apply(induction t rule: rotR_poss.induct)
apply(auto simp: apply_ats_map_R rev_map apply_ats_append)
done

corollary tree_to_tree_rotations: assumes "inorder t1 = inorder t2"
shows "rotLs (rev (rotR_poss t2)) (rotRs (rotR_poss t1) t1) = t2"
proof -
  have "rotRs (rotR_poss t1) t1 = rotRs (rotR_poss t2) t2" (is "?L = ?R")
    by (simp add: assms inorder_rotRs_poss is_list_inorder_same is_list_rotRs)
  hence "rotLs (rev (rotR_poss t2)) ?L = rotLs (rev (rotR_poss t2)) ?R"
    by simp
  also have "\<dots> = t2" by(rule rot_id)
  finally show ?thesis .
qed

lemma size_rlen_better_ub: "size t - rlen t \<le> size t - 1"
by (cases t) auto

end


header {* Dijkstra's Algorithm *}
theory Dijkstra
  imports
  Graph
  Dijkstra_Misc
  "../Collections/Refine_Dflt_ICF"
  Weight
begin
text {*
  This theory defines Dijkstra's algorithm. First, a correct result of
  Dijkstra's algorithm w.r.t. a graph and a start vertex is specified.
  Then, the refinement
  framework is used to specify Dijkstra's Algorithm, prove it correct, and
  finally refine it to datatypes that are closer to an implementation than
  the original specification.
  *}

subsection "Graph's for Dijkstra's Algorithm"
  text {* A graph annotated with weights. *}
  locale weighted_graph = valid_graph G
    for G :: "('V,'W::weight) graph"

subsection "Specification of Correct Result"
  context weighted_graph
  begin
    text {*
      A result of Dijkstra's algorithm is correct, if it is a map from nodes
      @{text "v"} to the shortest path from the start node @{text "v0"} to
      @{text "v"}. Iff there is no such path, the node is not in the map.
      *}
    definition is_shortest_path_map :: "'V \<Rightarrow> ('V \<rightharpoonup> ('V,'W) path) \<Rightarrow> bool"
      where
      "is_shortest_path_map v0 res \<equiv> \<forall>v\<in>V. (case res v of
        None \<Rightarrow> \<not>(\<exists>p. is_path v0 p v) |
        Some p \<Rightarrow> is_path v0 p v
                  \<and> (\<forall>p'. is_path v0 p' v \<longrightarrow> path_weight p \<le> path_weight p')
      )"
  end

  text {*
    The following function returns the weight of an optional path,
    where @{text "None"} is interpreted as infinity.
    *}
  fun path_weight' where
    "path_weight' None = top" |
    "path_weight' (Some p) = Num (path_weight p)"

subsection "Dijkstra's Algorithm"
  text {*
    The state in the main loop of the algorithm consists of a workset
    @{text "wl"} of vertexes that still need to be explored, and a map
    @{text "res"} that contains the current shortest path for each vertex.
    *}
  type_synonym ('V,'W) state = "('V set) \<times> ('V \<rightharpoonup> ('V,'W) path)"

  text {*
    The preconditions of Dijkstra's algorithm, i.e., that it operates on a
    valid and finite graph, and that the start node is a node of the graph,
    are summarized in a locale.
    *}
  locale Dijkstra = weighted_graph G
    for G :: "('V,'W::weight) graph"+
    fixes v0 :: 'V
    assumes finite[simp,intro!]: "finite V" "finite E"
    assumes v0_in_V[simp, intro!]: "v0\<in>V"
    assumes nonneg_weights[simp, intro]: "(v,w,v')\<in>edges G \<Longrightarrow> 0\<le>w"
  begin

  text {* Paths have non-negative weights.*}
  lemma path_nonneg_weight: "is_path v p v' \<Longrightarrow> 0 \<le> path_weight p"
    by (induct rule: is_path.induct) auto

  text {* Invariant of the main loop:
    \begin{itemize}
      \item The workset only contains nodes of the graph.
      \item If the result set contains a path for a node, it is actually a path,
        and uses only intermediate vertices outside the workset.
      \item For all vertices outside the workset, the result map contains the
        shortest path.
      \item For all vertices in the workset, the result map contains the
        shortest path among all paths that only use intermediate vertices outside
        the workset.
    \end{itemize}
    *}
  definition "dinvar \<sigma> \<equiv> let (wl,res)=\<sigma> in
    wl \<subseteq> V \<and>
    (\<forall>v\<in>V. \<forall>p. res v = Some p \<longrightarrow> is_path v0 p v \<and> int_vertices p \<subseteq> V-wl) \<and>
    (\<forall>v\<in>V-wl. \<forall>p. is_path v0 p v
       \<longrightarrow> path_weight' (res v) \<le> path_weight' (Some p)) \<and>
    (\<forall>v\<in>wl. \<forall>p. is_path v0 p v \<and> int_vertices p \<subseteq> V-wl
       \<longrightarrow> path_weight' (res v) \<le> path_weight' (Some p)
    )
    "

  text {* Sanity check: The invariant is strong enough to imply correctness
    of result. *}
  lemma invar_imp_correct: "dinvar ({},res) \<Longrightarrow> is_shortest_path_map v0 res"
    unfolding dinvar_def is_shortest_path_map_def
    by (auto simp: infty_unbox split: option.split)

  text {*
    The initial workset contains all vertices. The initial result maps
    @{text "v0"} to the empty path, and all other vertices to @{text "None"}.
    *}
  definition dinit :: "('V,'W) state nres" where
    "dinit \<equiv> SPEC ( \<lambda>(wl,res) .
        wl=V \<and> res v0 = Some [] \<and> (\<forall>v\<in>V-{v0}. res v = None))"

  text {*
    The initial state satisfies the invariant.
    *}
  lemma dinit_invar: "dinit \<le> SPEC dinvar"
    unfolding dinit_def
    apply (intro refine_vcg)
    apply (force simp: dinvar_def split: option.split)
    done

  text {*
    In each iteration, the main loop of the algorithm pops a minimal node from
    the workset, and then updates the result map accordingly.
    *}

  text {*
    Pop a minimal node from the workset. The node is minimal in the sense that
    the length of the current path for that node is minimal.
    *}
  definition pop_min :: "('V,'W) state \<Rightarrow> ('V \<times> ('V,'W) state) nres" where
    "pop_min \<sigma> \<equiv> do {
      let (wl,res)=\<sigma>;
      ASSERT (wl\<noteq>{});
      v \<leftarrow> RES (least_map (path_weight' \<circ> res) wl);
      RETURN (v,(wl-{v},res))
    }"

  text {*
    Updating the result according to a node @{text "v"} is done by checking,
    for each successor node, whether the path over @{text "v"} is shorter than
    the path currently stored into the result map.
    *}
  inductive update_spec :: "'V \<Rightarrow> ('V,'W) state \<Rightarrow> ('V,'W) state \<Rightarrow> bool"
    where
    "\<lbrakk> \<forall>v'\<in>V.
      res' v' \<in> least_map path_weight' (
        { res v' } \<union> { Some (p@[(v,w,v')]) | p w. res v = Some p \<and> (v,w,v')\<in>E }
      )
     \<rbrakk> \<Longrightarrow> update_spec v (wl,res) (wl,res')"

  text {*
    In order to ease the refinement proof, we will assert the following
    precondition for updating.
    *}
  definition update_pre :: "'V \<Rightarrow> ('V,'W) state \<Rightarrow> bool" where
    "update_pre v \<sigma> \<equiv> let (wl,res)=\<sigma> in v\<in>V
      \<and> (\<forall>v'\<in>V-wl. v'\<noteq>v \<longrightarrow> (\<forall>p. is_path v0 p v'
          \<longrightarrow> path_weight' (res v') \<le> path_weight' (Some p)))
      \<and> (\<forall>v'\<in>V. \<forall>p. res v' = Some p \<longrightarrow> is_path v0 p v')"

  definition update :: "'V \<Rightarrow> ('V,'W) state \<Rightarrow> ('V,'W) state nres" where
    "update v \<sigma> \<equiv> do {ASSERT (update_pre v \<sigma>); SPEC (update_spec v \<sigma>)}"

  text {* Finally, we define Dijkstra's algorithm: *}
  definition dijkstra where
    "dijkstra \<equiv> do {
       \<sigma>0\<leftarrow>dinit;
       (_,res) \<leftarrow> WHILE\<^sub>T\<^bsup>dinvar\<^esup> (\<lambda>(wl,_). wl\<noteq>{})
            (\<lambda>\<sigma>.
              do { (v,\<sigma>') \<leftarrow> pop_min \<sigma>; update v \<sigma>' }
            )
            \<sigma>0;
       RETURN res }
    "

  text {* The following theorem states (total) correctness of Dijkstra's
    algorithm. *}

  theorem dijkstra_correct: "dijkstra \<le> SPEC (is_shortest_path_map v0)"
    unfolding dijkstra_def
    unfolding dinit_def
    unfolding pop_min_def update_def [abs_def]
    thm refine_vcg

    apply (refine_rcg
      WHILEIT_rule[where R="inv_image {(x,y). x<y} (card \<circ> fst)"]
      refine_vcg
    )

    (* TODO/FIXME: Should we built in such massaging of the goal into
        refine_rcg ?*)
    apply (simp_all split: prod.split_asm)
    apply (tactic {*
      ALLGOALS ((REPEAT_DETERM o Hypsubst.bound_hyp_subst_tac @{context})
      THEN' asm_full_simp_tac @{context}
      )*})

  proof -
    fix wl res v
    assume INV: "dinvar (wl,res)"
    and LM: "v\<in>least_map (path_weight' \<circ> res) wl"
    hence "v\<in>V" unfolding dinvar_def by (auto dest: least_map_elemD)
    moreover
    from INV have " \<forall>v'\<in>V - (wl-{v}). v' \<noteq> v \<longrightarrow>
      (\<forall>p. is_path v0 p v' \<longrightarrow> path_weight' (res v') \<le> Num (path_weight p))"
      by (auto simp: dinvar_def)
    moreover from INV have "\<forall>v'\<in>V. \<forall>p. res v'=Some p \<longrightarrow> is_path v0 p v'"
      by (auto simp: dinvar_def)
    ultimately show "update_pre v (wl-{v},res)" by (auto simp: update_pre_def)
  next
    fix res
    assume "dinvar ({}, res)"
    thus "is_shortest_path_map v0 res"
      by (rule invar_imp_correct)
  next
    show "wf (inv_image {(x, y). x < y} (card \<circ> fst))"
      by (blast intro: wf_less)
  next
    fix wl res v \<sigma>''
    assume
      LM: "v\<in>least_map (path_weight' \<circ> res) wl" and
      UD: "update_spec v (wl-{v},res) \<sigma>''" and
      INV: "dinvar (wl,res)"

    from LM have "v\<in>wl" by (auto dest: least_map_elemD)
    moreover from UD have "fst \<sigma>'' = wl-{v}" by (auto elim: update_spec.cases)
    moreover from INV have "finite wl"
      unfolding dinvar_def by (auto dest: finite_subset)
    ultimately show "card (fst \<sigma>'') < card wl"
      apply simp
      by (metis card_gt_0_iff diff_Suc_less empty_iff)
  next
    fix a and res :: "'V \<rightharpoonup> ('V,'W) path"
    assume "a = V \<and> res v0 = Some [] \<and> (\<forall>v\<in>V-{v0}. res v = None)"
    thus "dinvar (V,res)"
      by (force simp: dinvar_def split: option.split)
  next
    fix wl res
    assume INV: "dinvar (wl,res)"
    hence
      WL_SUBSET: "wl \<subseteq> V" and
      PATH_VALID: "\<forall>v\<in>V. \<forall>p. res v = Some p
        \<longrightarrow> is_path v0 p v \<and> int_vertices p \<subseteq> V - wl" and
      NWL_MIN: "\<forall>v\<in>V - wl. \<forall>p. is_path v0 p v
        \<longrightarrow> path_weight' (res v) \<le> Num (path_weight p)" and
      WL_MIN: "\<forall>v\<in>wl. \<forall>p. is_path v0 p v \<and> int_vertices p \<subseteq> V - wl
        \<longrightarrow> path_weight' (res v) \<le> Num (path_weight p)"
      unfolding dinvar_def by auto

    fix v \<sigma>''
    assume V_LEAST: "v\<in>least_map (path_weight' o res) wl"
      and "update_spec v (wl-{v},res) \<sigma>''"
    then obtain res' where
      [simp]: "\<sigma>''=(wl-{v},res')"
      and CONSIDERED_NEW_PATHS: "\<forall>v'\<in>V. res' v' \<in> least_map path_weight'
        (insert (res v')
              ({ Some (p@[(v,w,v')]) | p w. res v = Some p \<and> (v,w,v')\<in>E }))"
      by (auto elim!: update_spec.cases)

    from V_LEAST have V_MEM: "v\<in>wl" by (blast intro: least_map_elemD)

    show "dinvar \<sigma>''"
      apply (unfold dinvar_def, simp)
      apply (intro conjI)
    proof -
      from WL_SUBSET show "wl-{v} \<subseteq> V" by auto

      show "\<forall>va\<in>V. \<forall>p. res' va = Some p
        \<longrightarrow> is_path v0 p va \<and> int_vertices p \<subseteq> V - (wl - {v})"
      proof (intro ballI conjI impI allI)
        fix v' p
        assume V'_MEM: "v'\<in>V" and [simp]: "res' v' = Some p"
        txt {* The new paths that we have added are valid and only use
          intermediate vertices outside the workset.

          This proof works as follows: A path @{term "res' v'"} is either
          the old path, or has been assembled as a path over node @{term v}.
          In the former case the proposition follows straightforwardly from the
          invariant for the old state. In the latter case we get, by the invariant
          for the old state, that the path over node @{term v} is valid.
          Then, we observe that appending an edge to a valid path yields a valid
          path again. Also, adding @{term v} as intermediate node is legal, as we
          just removed @{term v} from the workset.
          *}
        with CONSIDERED_NEW_PATHS have "res' v' \<in> (insert (res v')
          ({ Some (p@[(v,w,v')]) | p w. res v = Some p \<and> (v,w,v')\<in>E }))"
          by (rule_tac least_map_elemD) blast
        moreover {
          assume [symmetric,simp]: "res' v' = res v'"
          from V'_MEM PATH_VALID have
            "is_path v0 p v'"
            "int_vertices p \<subseteq> V - (wl-{v})"
            by force+
        } moreover {
          fix pv w
          assume "res' v' = Some (pv@[(v,w,v')])"
            and [simp]: "res v = Some pv"
            and EDGE: "(v,w,v')\<in>E"
          hence [simp]: "p = pv@[(v,w,v')]" by simp

          from bspec[OF PATH_VALID set_rev_mp[OF V_MEM WL_SUBSET]] have
            PATHV: "is_path v0 pv v" and IVV: "int_vertices pv \<subseteq> V - wl" by auto
          hence
            "is_path v0 p v'"
            "int_vertices p \<subseteq> V - (wl-{v})"
            by (auto simp: EDGE V'_MEM)
        }
        ultimately show
          "is_path v0 p v'"
          "int_vertices p \<subseteq> V - (wl-{v})"
          by blast+
      qed

      txt {*
        We show that already the {\em original} result stores the minimal
        path for all vertices not in the {\em new} workset.
        For vertices also not in the original workset, this follows
        straightforwardly from the invariant.

        For the vertex @{text v}, that has been removed from the
        workset, we split a path @{text p'} to @{text v} at the point
        @{text u} where it first enters the original workset.

        As we chose @{text v} to be the vertex in the workset with the
        minimal weight, its weight is less than the current weight of
        @{text u}.  As the vertices of the prefix of @{text p'} up to
        @{text u} are not in the workset, the current weight of
        @{text u} is less than the weight of the prefix of @{text
        p'}, and thus less than the weight of @{text p'}.
        Together, the current weight of @{text v} is less than the weight of
        @{text p'}. *}
      have RES_MIN: "\<forall>v\<in>V - (wl - {v}). \<forall>p. is_path v0 p v
        \<longrightarrow> path_weight' (res v) \<le> Num (path_weight p)"
      proof (intro ballI allI impI)
        fix v' p'
        assume NOT_IN_WL: "v' \<in> V - (wl - {v})"
          and PATH: "is_path v0 p' v'"
        hence [simp, intro!]: "v'\<in>V" by auto

        show "path_weight' (res v') \<le> Num (path_weight p')"
        proof (cases "v' = v")
          assume NE[simp]: "v'\<noteq>v"
          from bspec[OF NWL_MIN, of v'] NOT_IN_WL PATH show
            "path_weight' (res v') \<le> Num (path_weight p')" by auto
        next
          assume EQ[simp]: "v'=v"

          from path_split_set'[OF PATH, of wl] V_MEM obtain p1 p2 u where
            [simp]: "p'=p1@p2"
              and P1: "is_path v0 p1 u"
              and P2: "is_path u p2 v'"
              and P1V: "int_vertices p1 \<subseteq> -wl"
              and [simp]: "u\<in>wl"
            by auto

          from least_map_leD[OF V_LEAST]
          have "path_weight' (res v') \<le> path_weight' (res u)"by auto
          also from bspec[OF WL_MIN, of u] P1 P1V int_vertices_subset[OF P1]
          have "path_weight' (res u) \<le> Num (path_weight p1)" by auto
          also have "\<dots> \<le> Num (path_weight p')"
            using path_nonneg_weight[OF P2]
            apply (auto simp: infty_unbox )
            by (metis add_0_right add_left_mono)
          finally show ?thesis .
        qed
      qed

      txt {* With the previous statement, we easily show the
        third part of the invariant, as the new paths are not longer than the
        old ones.
        *}
      show "\<forall>v\<in>V - (wl - {v}). \<forall>p. is_path v0 p v
        \<longrightarrow> path_weight' (res' v) \<le> Num (path_weight p)"
      proof (intro allI ballI impI)
        fix v' p
        assume NOT_IN_WL: "v' \<in> V - (wl - {v})"
          and PATH: "is_path v0 p v'"
        hence [simp, intro!]: "v'\<in>V" by auto
        from bspec[OF CONSIDERED_NEW_PATHS, of v']
        have "path_weight' (res' v') \<le> path_weight' (res v')"
          by (auto dest: least_map_leD)
        also from bspec[OF RES_MIN NOT_IN_WL] PATH
        have "path_weight' (res v') \<le> Num (path_weight p)" by blast
        finally show "path_weight' (res' v') \<le> Num (path_weight p)" .
      qed

      txt {*
        Finally, we have to show that for nodes on the worklist,
        the stored paths are not longer than any path using only nodes not
        on the worklist. Compared to the situation before the step, those
        path may also use the node @{text v}.
        *}
      show "\<forall>va\<in>wl - {v}. \<forall>p.
        is_path v0 p va \<and> int_vertices p \<subseteq> V - (wl - {v})
        \<longrightarrow> path_weight' (res' va) \<le> Num (path_weight p)"
      proof (intro allI impI ballI, elim conjE)
        fix v' p
        assume IWS: "v'\<in>wl - {v}"
          and PATH: "is_path v0 p v'"
          and VERTICES: "int_vertices p \<subseteq> V - (wl - {v})"
        from IWS WL_SUBSET have [simp, intro!]: "v'\<in>V" by auto

        {
          txt {*
            If the path is empty, the proposition follows easily from the
            invariant for the original states, as no intermediate nodes are
            used at all.
            *}
          assume [simp]: "p=[]"
          from bspec[OF CONSIDERED_NEW_PATHS, of v'] have
            "path_weight' (res' v') \<le> path_weight' (res v')"
            using IWS WL_SUBSET by (auto dest: least_map_leD)
          also have "int_vertices p \<subseteq> V-wl" by auto
          with WL_MIN IWS PATH
          have "path_weight' (res v') \<le> Num (path_weight p)"
            by (auto simp del: path_weight_empty)
          finally have "path_weight' (res' v') \<le> Num (path_weight p)" .
        } moreover {
          fix p1 u w
          assume [simp]: "p = p1@[(u,w,v')]"
          txt {* If the path is not empty, we pick the last but one vertex, and
            call it @{term u}.*}
          from PATH have PATH1: "is_path v0 p1 u" and EDGE: "(u,w,v')\<in>E" by auto
          from VERTICES have NIV: "u\<in>V - (wl-{v})" by simp
          hence U_MEM[simp]: "u\<in>V" by auto

          txt {* From @{thm [source] RES_MIN}, we know that @{term "res u"} holds
            the shortest path to @{term u}. Thus @{text p} is longer than the
            path that is constructed by replacing the prefix of @{term p} by
            {term "res u"}*}
          from NIV RES_MIN PATH1
          have G: "Num (path_weight p1) \<ge> path_weight' (res u)" by simp
          then obtain pu where [simp]: "res u = Some pu"
            by (cases "res u") (auto simp: infty_unbox)
          from G have "Num (path_weight p) \<ge> path_weight' (res u) + Num w"
            by (auto simp: infty_unbox add_right_mono)
          also
          have "path_weight' (res u) + Num w \<ge> path_weight' (res' v')"
            txt {*
              The remaining argument depends on wether @{term u}
              equals @{term v}.
              In the case @{term "u\<noteq>v"}, all vertices of @{term "res u"} are
              outside the original workset. Thus, appending the edge
              @{term "(u,w,v')"} to @{term "res u"} yields a path to @{term v}
              over intermediate nodes only outside the workset. By the invariant
              for the original state, @{term "res v'"} is shorter than this path.
              As a step does not replace paths by longer ones, also
              @{term "res' v'"} is shorter.

              In the case @{term "u=v"}, the step has
              considered the path to @{text v'} over @{text v}, and thus the
              result path is not longer.
              *}
          proof (cases "u=v")
            assume "u\<noteq>v"
            with NIV have NIV': "u\<in>V-wl" by auto
            from bspec[OF PATH_VALID U_MEM] NIV'
            have "is_path v0 pu u" and VU: "int_vertices (pu@[(u,w,v')]) \<subseteq> V-wl"
              by auto
            with EDGE have PV': "is_path v0 (pu@[(u,w,v')]) v'" by auto
            with bspec[OF WL_MIN, of v'] IWS VU have
              "path_weight' (res v') \<le> Num (path_weight (pu@[(u,w,v')]))"
              by blast
            hence "path_weight' (res u) + Num w \<ge> path_weight' (res v')"
              by (auto simp: infty_unbox)
            also from CONSIDERED_NEW_PATHS have
              "path_weight' (res v') \<ge> path_weight' (res' v')"
              by (auto dest: least_map_leD)
            finally (order_trans[rotated]) show ?thesis .
          next
            assume [symmetric,simp]: "u=v"
            from CONSIDERED_NEW_PATHS EDGE have
              "path_weight' (res' v') \<le> path_weight' (Some (pu@[(v,w,v')]))"
              by (rule_tac least_map_leD) auto
            thus ?thesis by (auto simp: infty_unbox)
          qed
          finally (order_trans[rotated]) have
            "path_weight' (res' v') \<le> Num (path_weight p)" .
        } ultimately show "path_weight' (res' v') \<le> Num (path_weight p)"
          using PATH apply (cases p rule: rev_cases) by auto
      qed
    qed
  qed

  subsection {* Structural Refinement of Update *}
  text {*
    Now that we have proved correct the initial version of the algorithm, we start
    refinement towards an efficient implementation.
    *}

  text {*
    First, the update function is refined to iterate over each successor of the
    selected node, and update the result on demand.
    *}
  definition uinvar
    :: "'V \<Rightarrow> 'V set \<Rightarrow> _ \<Rightarrow> ('W\<times>'V) set \<Rightarrow> ('V,'W) state \<Rightarrow> bool" where
    "uinvar v wl res it \<sigma> \<equiv> let (wl',res')=\<sigma> in wl'=wl
    \<and> (\<forall>v'\<in>V.
      res' v' \<in> least_map path_weight' (
        { res v' } \<union> { Some (p@[(v,w,v')]) | p w. res v = Some p
          \<and> (w,v') \<in> succ G v - it }
      ))
    \<and> (\<forall>v'\<in>V. \<forall>p. res' v' = Some p \<longrightarrow> is_path v0 p v')
    \<and> res' v = res v
    "

  definition update' :: "'V \<Rightarrow> ('V,'W) state \<Rightarrow> ('V,'W) state nres" where
    "update' v \<sigma> \<equiv> do {
      ASSERT (update_pre v \<sigma>);
      let (wl,res) = \<sigma>;
      let wv = path_weight' (res v);
      let pv = res v;
      FOREACH\<^bsup>uinvar v wl res\<^esup> (succ G v) (\<lambda>(w',v') (wl,res).
        if (wv + Num w' < path_weight' (res v')) then do {
            ASSERT (v'\<in>wl \<and> pv\<noteq>None);
            RETURN (wl,res(v' \<mapsto> the pv@[(v,w',v')]))
        } else RETURN (wl,res)
      ) (wl,res)}"

  lemma update'_refines:
    assumes "v'=v" and "\<sigma>'=\<sigma>"
    shows "update' v' \<sigma>' \<le> \<Down>Id (update v \<sigma>)"
    apply (simp only: assms)
    unfolding update'_def update_def
    apply (refine_rcg refine_vcg)

    (*apply (intro refine_vcg conjI)*)
    apply (simp_all only: singleton_iff)
  proof -
    fix wl res
    assume "update_pre v (wl,res)"
    thus "uinvar v wl res (succ G v) (wl,res)"
      by (simp add: uinvar_def update_pre_def)
  next

    fix wl res it wl' res' v' w'
    assume PRE: "update_pre v (wl,res)"
    assume INV: "uinvar v wl res it (wl',res')"
    assume MEM: "(w',v')\<in>it"
    assume IT_SS: "it\<subseteq> succ G v"
    assume LESS: "path_weight' (res v) + Num w' < path_weight' (res' v')"

    from PRE have [simp, intro!]: "v\<in>V" by (simp add: update_pre_def)

    from MEM IT_SS have [simp,intro!]: "v'\<in>V" using succ_subset
      by auto

    from LESS obtain pv where [simp]: "res v = Some pv"
      by (cases "res v") auto

    thus "res v \<noteq> None" by simp

    have [simp]: "wl'=wl" and [simp]: "res' v = res v"
      using INV unfolding uinvar_def by auto

    from MEM IT_SS have EDGE[simp]: "(v,w',v')\<in>E"
      unfolding succ_def by auto
    with INV have [simp]: "is_path v0 pv v"
      unfolding uinvar_def by auto

    have "0\<le>w'" by (rule nonneg_weights[OF EDGE])
    hence [simp]: "v'\<noteq>v" using LESS
      by auto
    hence [simp]: "v\<noteq>v'" by blast

    show [simp]: "v'\<in>wl'" proof (rule ccontr)
      assume [simp]: "v'\<notin>wl'"
      hence [simp]: "v'\<in>V-wl" and [simp]: "v'\<notin>wl" by auto
      note LESS
      also
      from INV have "path_weight' (res' v') \<le> path_weight' (res v')"
        unfolding uinvar_def by (auto dest: least_map_leD)
      also
      from PRE have PW: "\<And>p. is_path v0 p v' \<Longrightarrow>
        path_weight' (res v') \<le> path_weight' (Some p)"
        unfolding update_pre_def
        by auto
      have P: "is_path v0 (pv@[(v,w',v')]) v'" by simp
      from PW[OF P] have
        "path_weight' (res v') \<le> Num (path_weight (pv@[(v,w',v')]))"
        by auto
      finally show False by (simp add: infty_unbox)
    qed

    show "uinvar v wl res (it-{(w',v')}) (wl',res'(v'\<mapsto>the (res v)@[(v,w',v')]))"
    proof -
      have "(res'(v'\<mapsto>the (res v)@[(v,w',v')])) v = res' v" by simp
      moreover {
        fix v'' assume VMEM: "v''\<in>V"
        have "(res'(v'\<mapsto>the (res v)@[(v,w',v')])) v'' \<in> least_map path_weight' (
          { res v'' } \<union> { Some (p@[(v,w,v'')]) | p w. res v = Some p
          \<and> (w,v'') \<in> succ G v - (it - {(w',v')}) }
          ) \<and> (\<forall>p. (res'(v'\<mapsto>the (res v)@[(v,w',v')])) v'' = Some p
                \<longrightarrow> is_path v0 p v'')"
        proof (cases "v''=v'")
          case False[simp]
          have "{ Some (p@[(v,w,v'')]) | p w. res v = Some p
          \<and> (w,v'') \<in> succ G v - (it - {(w',v')}) } =
            { Some (p@[(v,w,v'')]) | p w. res v = Some p
          \<and> (w,v'') \<in> succ G v - it }"
            by auto
          with INV VMEM show ?thesis unfolding uinvar_def
            by simp
        next
          case True[simp]
          have EQ: "{ res v'' } \<union> { Some (p@[(v,w,v'')]) | p w. res v = Some p
          \<and> (w,v'') \<in> succ G v - (it - {(w',v')}) } =
          insert (Some (pv@[(v,w',v')])) (
            { res v'' } \<union> { Some (p@[(v,w,v'')]) | p w. res v = Some p
          \<and> (w,v'') \<in> succ G v - it })"
            using MEM IT_SS
            by auto
          show ?thesis
            apply (subst EQ)
            apply simp
            apply (rule least_map_insert_min)
            apply (rule ballI)
          proof -
            fix r'
            assume A:
              "r' \<in> insert (res v')
               {Some (pv @ [(v, w, v')]) |w. (w, v') \<in> succ G v \<and> (w, v') \<notin> it}"

            from LESS have
              "path_weight' (Some (pv @ [(v, w', v')])) < path_weight' (res' v')"
              by (auto simp: infty_unbox)
            also from INV[unfolded uinvar_def] have
              "res' v' \<in> least_map path_weight' (
                insert (res v')
                {Some (pv @ [(v, w, v')]) |w. (w, v') \<in> succ G v \<and> (w, v') \<notin> it}
              )"
              by auto
            with A have "path_weight' (res' v') \<le> path_weight' r'"
              by (auto dest: least_map_leD)
            finally show
              "path_weight' (Some (pv @ [(v, w', v')])) \<le> path_weight' r'"
              by simp
          qed
        qed
      }
      ultimately show ?thesis
        unfolding uinvar_def Let_def
        by auto
    qed
  next
    fix wl res it w' v' wl' res'
    assume INV: "uinvar v wl res it (wl',res')"
    and NLESS: "\<not> path_weight' (res v) + Num w' < path_weight' (res' v')"
    and IN_IT: "(w',v')\<in>it"
    and IT_SS: "it \<subseteq> succ G v"

    from IN_IT IT_SS have [simp, intro!]: "(w',v')\<in>succ G v" by auto
    hence [simp,intro!]: "v'\<in>V" using succ_subset
      by auto

    show "uinvar v wl res (it - {(w',v')}) (wl',res')"
    proof (cases "res v")
      case None [simp]
      from INV show ?thesis
        unfolding uinvar_def by auto
    next
      case (Some p) [simp]
      {
        fix v''
        assume [simp, intro!]: "v''\<in>V"
        have "res' v'' \<in> least_map path_weight' (
          { res v'' } \<union> { Some (p@[(v,w,v'')]) | p w. res v = Some p
          \<and> (w,v'') \<in> succ G v - (it - {(w',v')}) }
          )" (is "_ \<in> least_map path_weight' ?S")
        proof (cases "v''=v'")
          case False with INV show ?thesis
            unfolding uinvar_def by auto
        next
          case True[simp]

          have EQ: "?S = insert (Some (p@[(v,w',v')])) (
            { res v' } \<union> { Some (p@[(v,w,v'')]) | p w. res v = Some p
                            \<and> (w,v'') \<in> succ G v - it }
            )"
            by auto
          from NLESS have
            "path_weight' (res' v') \<le> path_weight' (Some (p@[(v,w',v')]))"
            by (auto simp: infty_unbox)
          thus ?thesis
            apply (subst EQ)
            apply (rule least_map_insert_nmin)
            using INV unfolding uinvar_def apply auto []
            apply simp
            done
        qed
      } with INV
      show ?thesis
        unfolding uinvar_def by auto
    qed
  next
    fix wl res \<sigma>'

    assume "uinvar v wl res {} \<sigma>'"
    thus "update_spec v (wl,res) \<sigma>'"
      unfolding uinvar_def
      apply (cases \<sigma>')
      apply (auto intro: update_spec.intros simp: succ_def)
      done
  next
    show "finite (succ G v)" by simp
  qed

  text {* We integrate the new update function into the main algorithm: *}
  definition dijkstra' where
    "dijkstra' \<equiv> do {
      \<sigma>0 \<leftarrow> dinit;
      (_,res) \<leftarrow> WHILE\<^sub>T\<^bsup>dinvar\<^esup> (\<lambda>(wl,_). wl\<noteq>{})
            (\<lambda>\<sigma>. do {(v,\<sigma>') \<leftarrow> pop_min \<sigma>; update' v \<sigma>'})
            \<sigma>0;
      RETURN res
    }"

  lemma dijkstra'_refines: "dijkstra' \<le> \<Down>Id dijkstra"
  proof -
    note [refine] = update'_refines
    have [refine]: "\<And>\<sigma> \<sigma>'. \<sigma>=\<sigma>' \<Longrightarrow> pop_min \<sigma> \<le> \<Down>Id (pop_min \<sigma>')" by simp
    show ?thesis
      unfolding dijkstra_def dijkstra'_def
      apply (refine_rcg)
      apply simp_all
      done
  qed
end

subsection {* Refinement to Cached Weights *}
text {*
  Next, we refine the data types of the workset and the result map.
  The workset becomes a map from nodes to their current weights.
  The result map stores, in addition to the shortest path, also the
  weight of the shortest path. Moreover, we store the shortest paths
  in reversed order, which makes appending new edges more effcient.

  These refinements allow to implement the workset as a priority queue,
  and save recomputation of the path weights in the inner loop of the
  algorithm.
*}

type_synonym ('V,'W) mwl = "('V \<rightharpoonup> 'W infty)"
type_synonym ('V,'W) mres = "('V \<rightharpoonup> (('V,'W) path \<times> 'W))"
type_synonym ('V,'W) mstate = "('V,'W) mwl \<times> ('V,'W) mres"

text {*
  Map a path with cached weight to one without cached weight.
*}
fun mpath' :: "(('V,'W) path \<times> 'W) option \<rightharpoonup> ('V,'W) path" where
  "mpath' None = None" |
  "mpath' (Some (p,w)) = Some p"

fun mpath_weight' :: "(('V,'W) path \<times> 'W) option \<Rightarrow> ('W::weight) infty" where
  "mpath_weight' None = top" |
  "mpath_weight' (Some (p,w)) = Num w"

context Dijkstra
begin
  definition \<alpha>w::"('V,'W) mwl \<Rightarrow> 'V set" where "\<alpha>w \<equiv> dom"
  definition \<alpha>r::"('V,'W) mres \<Rightarrow> 'V \<rightharpoonup> ('V,'W) path" where
    "\<alpha>r \<equiv> \<lambda>res v. case res v of None \<Rightarrow> None | Some (p,w) \<Rightarrow> Some (rev p)"
  definition \<alpha>s:: "('V,'W) mstate \<Rightarrow> ('V,'W) state" where
    "\<alpha>s \<equiv> map_prod \<alpha>w \<alpha>r"

  text {* Additional invariants for the new state. They guarantee that
    the cached weights are consistent.*}
  definition res_invarm :: "('V \<rightharpoonup> (('V,'W) path\<times>'W)) \<Rightarrow> bool" where
    "res_invarm res \<equiv> (\<forall>v. case res v of
        None \<Rightarrow> True |
        Some (p,w) \<Rightarrow> w = path_weight (rev p))"
  definition dinvarm :: "('V,'W) mstate \<Rightarrow> bool" where
    "dinvarm \<sigma> \<equiv> let (wl,res) = \<sigma> in
      (\<forall>v\<in>dom wl. the (wl v) = mpath_weight' (res v)) \<and> res_invarm res
    "
  lemma mpath_weight'_correct: "\<lbrakk>dinvarm (wl,res)\<rbrakk> \<Longrightarrow>
    mpath_weight' (res v) = path_weight' (\<alpha>r res v)
    "
    unfolding dinvarm_def res_invarm_def \<alpha>r_def
    by (auto split: option.split option.split_asm)

  lemma mpath'_correct: "\<lbrakk>dinvarm (wl,res)\<rbrakk> \<Longrightarrow>
    mpath' (res v) = map_option rev (\<alpha>r res v)"
    unfolding dinvarm_def \<alpha>r_def
    by (auto split: option.split option.split_asm)

  lemma wl_weight_correct:
    assumes INV: "dinvarm (wl,res)"
    assumes WLV: "wl v = Some w"
    shows "path_weight' (\<alpha>r res v) = w"
  proof -
    from INV WLV have "w = mpath_weight' (res v)"
      unfolding dinvarm_def by force
    also from mpath_weight'_correct[OF INV] have
      "\<dots> = path_weight' (\<alpha>r res v)" .
    finally show ?thesis by simp
  qed

  text {* The initial state is constructed using an iterator: *}
  definition mdinit :: "('V,'W) mstate nres" where
    "mdinit \<equiv> do {
      wl \<leftarrow> FOREACH V (\<lambda>v wl. RETURN (wl(v\<mapsto>Infty))) Map.empty;
      RETURN (wl(v0\<mapsto>Num 0),[v0 \<mapsto> ([],0)])
    }"

  lemma mdinit_refines: "mdinit \<le> \<Down>(build_rel \<alpha>s dinvarm) dinit"
    unfolding mdinit_def dinit_def
    apply (rule build_rel_SPEC)
    apply (intro FOREACH_rule[where I="\<lambda>it wl. (\<forall>v\<in>V-it. wl v = Some Infty) \<and>
      dom wl = V-it"]
           refine_vcg)
    apply (auto
      simp: \<alpha>s_def \<alpha>w_def \<alpha>r_def dinvarm_def res_invarm_def infty_unbox
      split: split_if_asm
    )
    done

  text {* The new pop function: *}
  definition
    mpop_min :: "('V,'W) mstate \<Rightarrow> ('V \<times> 'W infty \<times> ('V,'W) mstate) nres"
    where
    "mpop_min \<sigma> \<equiv> do {
      let (wl,res) = \<sigma>;
      (v,w,wl')\<leftarrow>prio_pop_min wl;
      RETURN (v,w,(wl',res))
    }"

  lemma mpop_min_refines:
    "\<lbrakk> (\<sigma>,\<sigma>') \<in> build_rel \<alpha>s dinvarm \<rbrakk> \<Longrightarrow>
      mpop_min \<sigma> \<le>
       \<Down>(build_rel
          (\<lambda>(v,w,\<sigma>). (v,\<alpha>s \<sigma>))
          (\<lambda>(v,w,\<sigma>). dinvarm \<sigma> \<and> w = mpath_weight' (snd \<sigma> v)))
      (pop_min \<sigma>')"
    -- "The two algorithms are structurally different, so we use the
      nofail/inres method to prove refinement."
    unfolding mpop_min_def pop_min_def prio_pop_min_def

    apply (rule pw_ref_svI)
    apply rule
    apply (auto simp add: refine_pw_simps \<alpha>s_def \<alpha>w_def refine_rel_defs
      split: prod.split prod.split_asm)

    apply (auto simp: dinvarm_def) []

    apply (auto simp: mpath_weight'_correct wl_weight_correct) []

    apply (auto
      simp: wl_weight_correct
      intro!: least_map.intros
    ) []
    done

  text {* The new update function: *}
  definition "uinvarm v wl res it \<sigma> \<equiv>
    uinvar v wl res it (\<alpha>s \<sigma>) \<and> dinvarm \<sigma>"

  definition mupdate :: "'V \<Rightarrow> 'W infty \<Rightarrow> ('V,'W) mstate \<Rightarrow> ('V,'W) mstate nres"
   where
    "mupdate v wv \<sigma> \<equiv> do {
      ASSERT (update_pre v (\<alpha>s \<sigma>) \<and> wv=mpath_weight' (snd \<sigma> v));
      let (wl,res) = \<sigma>;
      let pv = mpath' (res v);
      FOREACH\<^bsup>uinvarm v (\<alpha>w wl) (\<alpha>r res)\<^esup> (succ G v) (\<lambda>(w',v') (wl,res).
        if (wv + Num w' < mpath_weight' (res v')) then do {
          ASSERT (v'\<in>dom wl \<and> pv \<noteq> None);
          ASSERT (wv \<noteq> Infty);
          RETURN (wl(v'\<mapsto>wv + Num w'),
                    res(v' \<mapsto> ((v,w',v')#the pv,val wv + w') ))
        } else RETURN (wl,res)
        ) (wl,res)
    }"

  lemma mupdate_refines:
    assumes SREF: "(\<sigma>,\<sigma>')\<in>build_rel \<alpha>s dinvarm"
    assumes WV: "wv = mpath_weight' (snd \<sigma> v)"
    assumes VV': "v'=v"
    shows "mupdate v wv \<sigma> \<le> \<Down>(build_rel \<alpha>s dinvarm) (update' v' \<sigma>')"
  proof (simp only: VV')
    {
      txt {* Show that IF-condition is a refinement: *}
      fix wl res wl' res' it w' v'
      assume "uinvarm v (\<alpha>w wl) (\<alpha>r res) it (wl',res')"
        and "dinvarm (wl,res)"
      hence "mpath_weight' (res v) + Num w' < mpath_weight' (res' v') \<longleftrightarrow>
        path_weight' (\<alpha>r res v) + Num w' < path_weight' (\<alpha>r res' v')"
        unfolding uinvarm_def
        by (auto simp add: mpath_weight'_correct)
    } note COND_refine=this

    {
      txt {* THEN-case: *}
      fix wl res wl' res' it w' v'
      assume UINV: "uinvarm v (\<alpha>w wl) (\<alpha>r res) it (wl',res')"
        and DINV: "dinvarm (wl,res)"
        and "mpath_weight' (res v) + Num w' < mpath_weight' (res' v')"
        and "path_weight' (\<alpha>r res v) + Num w' < path_weight' (\<alpha>r res' v')"
        and V'MEM: "v'\<in>\<alpha>w wl'"
        and NN: "\<alpha>r res v \<noteq> None"

      from NN obtain pv wv where
        ARV: "\<alpha>r res v = Some (rev pv)" and
        RV: "res v = Some (pv,wv)"
        unfolding \<alpha>r_def by (auto split: option.split_asm)

      with DINV have [simp]: "wv = path_weight (rev pv)"
        unfolding dinvarm_def res_invarm_def by (auto split: option.split_asm)

      note [simp] = ARV RV

      from V'MEM NN have "v'\<in>dom wl'" (is "?G1")
        and "mpath' (res v) \<noteq> None" (is "?G2")
        unfolding \<alpha>w_def \<alpha>r_def by (auto split: option.split_asm)

      hence "\<And>x. \<alpha>w wl' = \<alpha>w (wl'(v'\<mapsto>x))" by (auto simp: \<alpha>w_def)
      moreover have "mpath' (res v) = map_option rev (\<alpha>r res v)" using DINV
        by (simp add: mpath'_correct)
      ultimately have
        "\<alpha>w wl' = \<alpha>w (wl'(v' \<mapsto> mpath_weight' (res v) + Num w'))
        \<and> (\<alpha>r res')(v' \<mapsto> the (\<alpha>r res v)@[(v, w', v')])
           = \<alpha>r (res'(v' \<mapsto> ((v, w', v')#the (mpath' (res v)),
                 val (mpath_weight' (res v)) + w')))" (is ?G3)
        by (auto simp add: \<alpha>r_def intro!: ext)
      have
        "(dinvarm (wl'(v'\<mapsto>mpath_weight' (res v) + Num w'),
                           res'(v' \<mapsto> ((v,w',v') # the (mpath' (res v)),
                                       val (mpath_weight' (res v)) + w'
                                      ))))" (is ?G4)
        using UINV unfolding uinvarm_def dinvarm_def res_invarm_def
        by (auto simp: infty_unbox split: option.split option.split_asm)
      note `?G1` `?G2` `?G3` `?G4`
    } note THEN_refine=this

    note [refine2] = inj_on_id

    note [simp] = refine_rel_defs

    show "mupdate v wv \<sigma> \<le> \<Down>(build_rel \<alpha>s dinvarm) (update' v \<sigma>')"
      using SREF WV
      unfolding mupdate_def update'_def
      apply -

      apply (refine_rcg)

      apply simp_all [3]
      apply (simp add: \<alpha>s_def uinvarm_def)
      apply (simp_all add: \<alpha>s_def COND_refine THEN_refine(1-2)) [3]
      apply (rule ccontr,simp)
      using THEN_refine(3,4)
      apply (auto simp: \<alpha>s_def) []
      txt {*The ELSE-case is trivial:*}
      apply simp
      done
  qed

  text {* Finally, we assemble the refined algorithm: *}
  definition mdijkstra where
    "mdijkstra \<equiv> do {
      \<sigma>0 \<leftarrow> mdinit;
      (_,res) \<leftarrow> WHILE\<^sub>T\<^bsup>dinvarm\<^esup> (\<lambda>(wl,_). dom wl\<noteq>{})
            (\<lambda>\<sigma>. do { (v,wv,\<sigma>') \<leftarrow> mpop_min \<sigma>; mupdate v wv \<sigma>' } )
            \<sigma>0;
      RETURN res
    }"

  lemma mdijkstra_refines: "mdijkstra \<le> \<Down>(build_rel \<alpha>r res_invarm) dijkstra'"
  proof -
    note [refine] = mdinit_refines mpop_min_refines mupdate_refines
    show ?thesis
      unfolding mdijkstra_def dijkstra'_def
      apply (refine_rcg)
      apply (simp_all split: prod.split
        add: \<alpha>s_def \<alpha>w_def dinvarm_def refine_rel_defs)
      done
  qed

end

end


(* Title:  Rtrancl_On.thy
   Author: Lars Noschinski, TU München
   Author: René Neumann, TU München
*)

theory Rtrancl_On
imports Main
begin

section \<open>Reflexive-Transitive Closure on a Domain\<close>

text \<open>
  In this section we introduce a variant of the reflexive-transitive closure
  of a relation which is useful to formalize the reachability relation on
  digraphs.
\<close>

inductive_set
  rtrancl_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> 'a rel"
  for F :: "'a set" and r :: "'a rel"
where
    rtrancl_on_refl [intro!, Pure.intro!, simp]: "a \<in> F \<Longrightarrow> (a, a) \<in> rtrancl_on F r"
  | rtrancl_on_into_rtrancl_on [Pure.intro]:
      "(a, b) \<in> rtrancl_on F r  \<Longrightarrow> (b, c) \<in> r \<Longrightarrow> c \<in> F
      \<Longrightarrow> (a, c) \<in> rtrancl_on F r"

definition symcl :: "'a rel \<Rightarrow> 'a rel" ("(_\<^sup>s)" [1000] 999) where
  "symcl R = R \<union> (\<lambda>(a,b). (b,a)) ` R"

lemma in_rtrancl_on_in_F:
  assumes "(a,b) \<in> rtrancl_on F r" shows "a \<in> F" "b \<in> F"
  using assms by induct auto

lemma rtrancl_on_induct[consumes 1, case_names base step, induct set: rtrancl_on]:
  assumes "(a, b) \<in> rtrancl_on F r"
    and "a \<in> F \<Longrightarrow> P a"
        "\<And>y z. \<lbrakk>(a, y) \<in> rtrancl_on F r; (y,z) \<in> r; y \<in> F; z \<in> F; P y\<rbrakk> \<Longrightarrow> P z"
  shows "P b"
  using assms by (induct a b) (auto dest: in_rtrancl_on_in_F)

lemma rtrancl_on_trans:
  assumes "(a,b) \<in> rtrancl_on F r" "(b,c) \<in> rtrancl_on F r" shows "(a,c) \<in> rtrancl_on F r"
  using assms(2,1)
  by induct (auto intro: rtrancl_on_into_rtrancl_on)

lemma converse_rtrancl_on_into_rtrancl_on:
  assumes "(a,b) \<in> r" "(b, c) \<in> rtrancl_on F r" "a \<in> F"
  shows "(a, c) \<in> rtrancl_on F r"
proof -
  have "b \<in> F" using \<open>(b,c) \<in> _\<close> by (rule in_rtrancl_on_in_F)
  show ?thesis
    apply (rule rtrancl_on_trans)
    apply (rule rtrancl_on_into_rtrancl_on)
    apply (rule rtrancl_on_refl)
    by fact+
qed

lemma rtrancl_on_converseI:
  assumes "(y, x) \<in> rtrancl_on F r" shows "(x, y) \<in> rtrancl_on F (r\<inverse>)"
  using assms
proof induct
  case (step a b)
  then have "(b,b) \<in> rtrancl_on F (r\<inverse>)" "(b,a) \<in> r\<inverse>" by auto
  then show ?case using step
    by (metis rtrancl_on_trans rtrancl_on_into_rtrancl_on)
qed auto

theorem rtrancl_on_converseD:
  assumes "(y, x) \<in> rtrancl_on F (r\<inverse>)" shows "(x, y) \<in> rtrancl_on F r"
  using assms by - (drule rtrancl_on_converseI, simp)

lemma converse_rtrancl_on_induct[consumes 1, case_names base step, induct set: rtrancl_on]:
  assumes major: "(a, b) \<in> rtrancl_on F r"
    and cases: "b \<in> F \<Longrightarrow> P b"
       "\<And>x y. \<lbrakk>(x,y) \<in> r; (y,b) \<in> rtrancl_on F r; x \<in> F; y \<in> F; P y\<rbrakk> \<Longrightarrow> P x"
  shows "P a"
  using rtrancl_on_converseI[OF major] cases
  by induct (auto intro: rtrancl_on_converseD)

lemma converse_rtrancl_on_cases:
  assumes "(a, b) \<in> rtrancl_on F r"
  obtains (base) "a = b" "b \<in> F"
    | (step) c where "(a,c) \<in> r" "(c,b) \<in> rtrancl_on F r"
  using assms by induct auto

lemma rtrancl_on_sym:
  assumes "sym r" shows "sym (rtrancl_on F r)"
using assms by (auto simp: sym_conv_converse_eq intro: symI dest: rtrancl_on_converseI)

lemma rtrancl_on_mono:
  assumes "s \<subseteq> r" "F \<subseteq> G" "(a,b) \<in> rtrancl_on F s" shows "(a,b) \<in> rtrancl_on G r"
  using assms(3,1,2)
proof induct
  case (step x y) show ?case
    using step assms by (intro converse_rtrancl_on_into_rtrancl_on[OF _ step(5)]) auto
qed auto

lemma rtrancl_consistent_rtrancl_on:
  assumes "(a,b) \<in> r\<^sup>*"
  and "a \<in> F" "b \<in> F"
  and consistent: "\<And>a b. \<lbrakk> a \<in> F; (a,b) \<in> r \<rbrakk> \<Longrightarrow> b \<in> F"
  shows "(a,b) \<in> rtrancl_on F r"
  using assms(1-3)
proof (induction rule: converse_rtrancl_induct)
  case (step y z) then have "z \<in> F" by (rule_tac consistent) simp
  with step have "(z,b) \<in> rtrancl_on F r" by simp
  with step.prems \<open>(y,z) \<in> r\<close> \<open>z \<in> F\<close> show ?case
    using converse_rtrancl_on_into_rtrancl_on
    by metis
qed simp

lemma rtrancl_on_rtranclI:
  "(a,b) \<in> rtrancl_on F r \<Longrightarrow> (a,b) \<in> r\<^sup>*"
  by (induct rule: rtrancl_on_induct) simp_all

lemma rtrancl_on_sub_rtrancl:
  "rtrancl_on F r \<subseteq> r^*"
  using rtrancl_on_rtranclI
  by auto

end