(*
Theory: Set_Integral.thy
Authors: Jeremy Avigad, Johannes Hölzl, Luke Serafin

Notation and useful facts for working with integrals over a set.

TODO: keep all these? Need unicode translations as well.
*)

theory Set_Integral
  imports Probability Library_Misc
begin

(*
    Notation
*)

syntax
"_ascii_lebesgue_integral" :: "pttrn \<Rightarrow> 'a measure \<Rightarrow> real \<Rightarrow> real"
("(3LINT _|_. _)" [0,110,60] 60)

translations
"LINT x|M. f" == "CONST lebesgue_integral M (\<lambda>x. f)"

abbreviation "set_borel_measurable M A f \<equiv> (\<lambda>x. indicator A x *\<^sub>R f x) \<in> borel_measurable M"

abbreviation "set_integrable M A f \<equiv> integrable M (\<lambda>x. indicator A x *\<^sub>R f x)"

abbreviation "set_lebesgue_integral M A f \<equiv> lebesgue_integral M (\<lambda>x. indicator A x *\<^sub>R f x)"

syntax
"_ascii_set_lebesgue_integral" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'a measure \<Rightarrow> real \<Rightarrow> real"
("(4LINT _:_|_. _)" [0,60,110,61] 60)

translations
"LINT x:A|M. f" == "CONST set_lebesgue_integral M A (\<lambda>x. f)"

abbreviation
  "set_almost_everywhere A M P \<equiv> AE x in M. x \<in> A \<longrightarrow> P x"

syntax
  "_set_almost_everywhere" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> bool"
("AE _\<in>_ in _. _" [0,0,0,10] 10)

translations
  "AE x\<in>A in M. P" == "CONST set_almost_everywhere A M (\<lambda>x. P)"

(*
    Notation for integration wrt lebesgue measure on the reals:

      LBINT x. f
      LBINT x : A. f

    TODO: keep all these? Need unicode.
*)

syntax
"_lebesgue_borel_integral" :: "pttrn \<Rightarrow> real \<Rightarrow> real"
("(2LBINT _. _)" [0,60] 60)

translations
"LBINT x. f" == "CONST lebesgue_integral CONST lborel (\<lambda>x. f)"

syntax
"_set_lebesgue_borel_integral" :: "pttrn \<Rightarrow> real set \<Rightarrow> real \<Rightarrow> real"
("(3LBINT _:_. _)" [0,60,61] 60)

translations
"LBINT x:A. f" == "CONST set_lebesgue_integral CONST lborel A (\<lambda>x. f)"

(*
    Basic properties
*)

(*
lemma indicator_abs_eq: "\<And>A x. abs (indicator A x) = ((indicator A x) :: real)"
  by (auto simp add: indicator_def)
*)

lemma set_lebesgue_integral_cong:
  assumes "A \<in> sets M" and "\<forall>x. x \<in> A \<longrightarrow> f x = g x"
  shows "(LINT x:A|M. f x) = (LINT x:A|M. g x)"
  using assms by (auto intro!: integral_cong split: split_indicator simp add: sets.sets_into_space)

lemma set_lebesgue_integral_cong_AE:
  assumes [measurable]: "A \<in> sets M" "f \<in> borel_measurable M" "g \<in> borel_measurable M"
  assumes "AE x \<in> A in M. f x = g x"
  shows "LINT x:A|M. f x = LINT x:A|M. g x"
proof-
  have "AE x in M. indicator A x *\<^sub>R f x = indicator A x *\<^sub>R g x"
    using assms by auto
  thus ?thesis by (intro integral_cong_AE) auto
qed

lemma set_integrable_cong_AE:
    "f \<in> borel_measurable M \<Longrightarrow> g \<in> borel_measurable M \<Longrightarrow>
    AE x \<in> A in M. f x = g x \<Longrightarrow> A \<in> sets M \<Longrightarrow>
    set_integrable M A f = set_integrable M A g"
  by (rule integrable_cong_AE) auto

lemma set_integrable_subset:
  fixes M A B and f :: "_ \<Rightarrow> _ :: {banach, second_countable_topology}"
  assumes "set_integrable M A f" "B \<in> sets M" "B \<subseteq> A"
  shows "set_integrable M B f"
proof -
  have "set_integrable M B (\<lambda>x. indicator A x *\<^sub>R f x)"
    by (rule integrable_mult_indicator) fact+
  with `B \<subseteq> A` show ?thesis
    by (simp add: indicator_inter_arith[symmetric] Int_absorb2)
qed

(* TODO: integral_cmul_indicator should be named set_integral_const *)
(* TODO: borel_integrable_atLeastAtMost should be named something like set_integrable_Icc_isCont *)

lemma set_integral_scaleR_right [simp]: "LINT t:A|M. a *\<^sub>R f t = a *\<^sub>R (LINT t:A|M. f t)"
  by (subst integral_scaleR_right[symmetric]) (auto intro!: integral_cong)

lemma set_integral_mult_right [simp]:
  fixes a :: "'a::{real_normed_field, second_countable_topology}"
  shows "LINT t:A|M. a * f t = a * (LINT t:A|M. f t)"
  by (subst integral_mult_right_zero[symmetric]) (auto intro!: integral_cong)

lemma set_integral_mult_left [simp]:
  fixes a :: "'a::{real_normed_field, second_countable_topology}"
  shows "LINT t:A|M. f t * a = (LINT t:A|M. f t) * a"
  by (subst integral_mult_left_zero[symmetric]) (auto intro!: integral_cong)

lemma set_integral_divide_zero [simp]:
  fixes a :: "'a::{real_normed_field, field_inverse_zero, second_countable_topology}"
  shows "LINT t:A|M. f t / a = (LINT t:A|M. f t) / a"
  by (subst integral_divide_zero[symmetric], intro integral_cong)
     (auto split: split_indicator)

lemma set_integrable_scaleR_right [simp, intro]:
  shows "(a \<noteq> 0 \<Longrightarrow> set_integrable M A f) \<Longrightarrow> set_integrable M A (\<lambda>t. a *\<^sub>R f t)"
  unfolding scaleR_left_commute by (rule integrable_scaleR_right)

lemma set_integrable_scaleR_left [simp, intro]:
  fixes a :: "_ :: {banach, second_countable_topology}"
  shows "(a \<noteq> 0 \<Longrightarrow> set_integrable M A f) \<Longrightarrow> set_integrable M A (\<lambda>t. f t *\<^sub>R a)"
  using integrable_scaleR_left[of a M "\<lambda>x. indicator A x *\<^sub>R f x"] by simp

lemma set_integrable_mult_right [simp, intro]:
  fixes a :: "'a::{real_normed_field, second_countable_topology}"
  shows "(a \<noteq> 0 \<Longrightarrow> set_integrable M A f) \<Longrightarrow> set_integrable M A (\<lambda>t. a * f t)"
  using integrable_mult_right[of a M "\<lambda>x. indicator A x *\<^sub>R f x"] by simp

lemma set_integrable_mult_left [simp, intro]:
  fixes a :: "'a::{real_normed_field, second_countable_topology}"
  shows "(a \<noteq> 0 \<Longrightarrow> set_integrable M A f) \<Longrightarrow> set_integrable M A (\<lambda>t. f t * a)"
  using integrable_mult_left[of a M "\<lambda>x. indicator A x *\<^sub>R f x"] by simp

lemma set_integrable_divide [simp, intro]:
  fixes a :: "'a::{real_normed_field, field_inverse_zero, second_countable_topology}"
  assumes "a \<noteq> 0 \<Longrightarrow> set_integrable M A f"
  shows "set_integrable M A (\<lambda>t. f t / a)"
proof -
  have "integrable M (\<lambda>x. indicator A x *\<^sub>R f x / a)"
    using assms by (rule integrable_divide_zero)
  also have "(\<lambda>x. indicator A x *\<^sub>R f x / a) = (\<lambda>x. indicator A x *\<^sub>R (f x / a))"
    by (auto split: split_indicator)
  finally show ?thesis .
qed

lemma set_integral_add [simp, intro]:
  fixes f g :: "_ \<Rightarrow> _ :: {banach, second_countable_topology}"
  assumes "set_integrable M A f" "set_integrable M A g"
  shows "set_integrable M A (\<lambda>x. f x + g x)"
    and "LINT x:A|M. f x + g x = (LINT x:A|M. f x) + (LINT x:A|M. g x)"
  using assms by (simp_all add: scaleR_add_right)

lemma set_integral_diff [simp, intro]:
  assumes "set_integrable M A f" "set_integrable M A g"
  shows "set_integrable M A (\<lambda>x. f x - g x)" and "LINT x:A|M. f x - g x =
    (LINT x:A|M. f x) - (LINT x:A|M. g x)"
  using assms by (simp_all add: scaleR_diff_right)

lemma set_integral_reflect:
  fixes S and f :: "real \<Rightarrow> 'a :: {banach, second_countable_topology}"
  shows "(LBINT x : S. f x) = (LBINT x : {x. - x \<in> S}. f (- x))"
  using assms
  by (subst lborel_integral_real_affine[where c="-1" and t=0])
     (auto intro!: integral_cong split: split_indicator)

(* question: why do we have this for negation, but multiplication by a constant
   requires an integrability assumption? *)
lemma set_integral_uminus: "set_integrable M A f \<Longrightarrow> LINT x:A|M. - f x = - (LINT x:A|M. f x)"
  by (subst integral_minus[symmetric]) simp_all

lemma set_integral_complex_of_real:
  "LINT x:A|M. complex_of_real (f x) = of_real (LINT x:A|M. f x)"
  by (subst integral_complex_of_real[symmetric])
     (auto intro!: integral_cong split: split_indicator)

lemma set_integral_mono:
  fixes f g :: "_ \<Rightarrow> real"
  assumes "set_integrable M A f" "set_integrable M A g"
    "\<And>x. x \<in> A \<Longrightarrow> f x \<le> g x"
  shows "(LINT x:A|M. f x) \<le> (LINT x:A|M. g x)"
using assms by (auto intro: integral_mono split: split_indicator)

lemma set_integral_mono_AE:
  fixes f g :: "_ \<Rightarrow> real"
  assumes "set_integrable M A f" "set_integrable M A g"
    "AE x \<in> A in M. f x \<le> g x"
  shows "(LINT x:A|M. f x) \<le> (LINT x:A|M. g x)"
using assms by (auto intro: integral_mono_AE split: split_indicator)

lemma set_integrable_abs: "set_integrable M A f \<Longrightarrow> set_integrable M A (\<lambda>x. \<bar>f x\<bar> :: real)"
  using integrable_abs[of M "\<lambda>x. f x * indicator A x"] by (simp add: abs_mult ac_simps)

lemma set_integrable_abs_iff:
  fixes f :: "_ \<Rightarrow> real"
  shows "set_borel_measurable M A f \<Longrightarrow> set_integrable M A (\<lambda>x. \<bar>f x\<bar>) = set_integrable M A f"
  by (subst (2) integrable_abs_iff[symmetric]) (simp_all add: abs_mult ac_simps)

lemma set_integrable_abs_iff':
  fixes f :: "_ \<Rightarrow> real"
  shows "f \<in> borel_measurable M \<Longrightarrow> A \<in> sets M \<Longrightarrow>
    set_integrable M A (\<lambda>x. \<bar>f x\<bar>) = set_integrable M A f"
by (intro set_integrable_abs_iff) auto

lemma set_integrable_discrete_difference:
  fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
  assumes "countable X"
  assumes diff: "(A - B) \<union> (B - A) \<subseteq> X"
  assumes "\<And>x. x \<in> X \<Longrightarrow> emeasure M {x} = 0" "\<And>x. x \<in> X \<Longrightarrow> {x} \<in> sets M"
  shows "set_integrable M A f \<longleftrightarrow> set_integrable M B f"
proof (rule integrable_discrete_difference[where X=X])
  show "\<And>x. x \<in> space M \<Longrightarrow> x \<notin> X \<Longrightarrow> indicator A x *\<^sub>R f x = indicator B x *\<^sub>R f x"
    using diff by (auto split: split_indicator)
qed fact+

lemma set_integral_discrete_difference:
  fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
  assumes "countable X"
  assumes diff: "(A - B) \<union> (B - A) \<subseteq> X"
  assumes "\<And>x. x \<in> X \<Longrightarrow> emeasure M {x} = 0" "\<And>x. x \<in> X \<Longrightarrow> {x} \<in> sets M"
  shows "set_lebesgue_integral M A f = set_lebesgue_integral M B f"
proof (rule integral_discrete_difference[where X=X])
  show "\<And>x. x \<in> space M \<Longrightarrow> x \<notin> X \<Longrightarrow> indicator A x *\<^sub>R f x = indicator B x *\<^sub>R f x"
    using diff by (auto split: split_indicator)
qed fact+

lemma set_integrable_Un:
  fixes f g :: "_ \<Rightarrow> _ :: {banach, second_countable_topology}"
  assumes f_A: "set_integrable M A f" and f_B:  "set_integrable M B f"
    and [measurable]: "A \<in> sets M" "B \<in> sets M"
  shows "set_integrable M (A \<union> B) f"
proof -
  have "set_integrable M (A - B) f"
    using f_A by (rule set_integrable_subset) auto
  from integrable_add[OF this f_B] show ?thesis
    by (rule integrable_cong[THEN iffD1, rotated 2]) (auto split: split_indicator)
qed

lemma set_integrable_UN:
  fixes f :: "_ \<Rightarrow> _ :: {banach, second_countable_topology}"
  assumes "finite I" "\<And>i. i\<in>I \<Longrightarrow> set_integrable M (A i) f"
    "\<And>i. i\<in>I \<Longrightarrow> A i \<in> sets M"
  shows "set_integrable M (\<Union>i\<in>I. A i) f"
using assms by (induct I) (auto intro!: set_integrable_Un)

lemma set_integral_Un:
  fixes f :: "_ \<Rightarrow> _ :: {banach, second_countable_topology}"
  assumes "A \<inter> B = {}"
  and "set_integrable M A f"
  and "set_integrable M B f"
  shows "LINT x:A\<union>B|M. f x = (LINT x:A|M. f x) + (LINT x:B|M. f x)"
by (auto simp add: indicator_union_arith indicator_inter_arith[symmetric]
      scaleR_add_left assms)

lemma set_integral_cong_set:
  fixes f :: "_ \<Rightarrow> _ :: {banach, second_countable_topology}"
  assumes [measurable]: "set_borel_measurable M A f" "set_borel_measurable M B f"
    and ae: "AE x in M. x \<in> A \<longleftrightarrow> x \<in> B"
  shows "LINT x:B|M. f x = LINT x:A|M. f x"
proof (rule integral_cong_AE)
  show "AE x in M. indicator B x *\<^sub>R f x = indicator A x *\<^sub>R f x"
    using ae by (auto simp: subset_eq split: split_indicator)
qed fact+

lemma set_borel_measurable_subset:
  fixes f :: "_ \<Rightarrow> _ :: {banach, second_countable_topology}"
  assumes [measurable]: "set_borel_measurable M A f" "B \<in> sets M" and "B \<subseteq> A"
  shows "set_borel_measurable M B f"
proof -
  have "set_borel_measurable M B (\<lambda>x. indicator A x *\<^sub>R f x)"
    by measurable
  also have "(\<lambda>x. indicator B x *\<^sub>R indicator A x *\<^sub>R f x) = (\<lambda>x. indicator B x *\<^sub>R f x)"
    using `B \<subseteq> A` by (auto simp: fun_eq_iff split: split_indicator)
  finally show ?thesis .
qed

lemma set_integral_Un_AE:
  fixes f :: "_ \<Rightarrow> _ :: {banach, second_countable_topology}"
  assumes ae: "AE x in M. \<not> (x \<in> A \<and> x \<in> B)" and [measurable]: "A \<in> sets M" "B \<in> sets M"
  and "set_integrable M A f"
  and "set_integrable M B f"
  shows "LINT x:A\<union>B|M. f x = (LINT x:A|M. f x) + (LINT x:B|M. f x)"
proof -
  have f: "set_integrable M (A \<union> B) f"
    by (intro set_integrable_Un assms)
  then have f': "set_borel_measurable M (A \<union> B) f"
    by (rule borel_measurable_integrable)
  have "LINT x:A\<union>B|M. f x = LINT x:(A - A \<inter> B) \<union> (B - A \<inter> B)|M. f x"
  proof (rule set_integral_cong_set)
    show "AE x in M. (x \<in> A - A \<inter> B \<union> (B - A \<inter> B)) = (x \<in> A \<union> B)"
      using ae by auto
    show "set_borel_measurable M (A - A \<inter> B \<union> (B - A \<inter> B)) f"
      using f' by (rule set_borel_measurable_subset) auto
  qed fact
  also have "\<dots> = (LINT x:(A - A \<inter> B)|M. f x) + (LINT x:(B - A \<inter> B)|M. f x)"
    by (auto intro!: set_integral_Un set_integrable_subset[OF f])
  also have "\<dots> = (LINT x:A|M. f x) + (LINT x:B|M. f x)"
    using ae
    by (intro arg_cong2[where f="op+"] set_integral_cong_set)
       (auto intro!: set_borel_measurable_subset[OF f'])
  finally show ?thesis .
qed

lemma set_integral_finite_Union:
  fixes f :: "_ \<Rightarrow> _ :: {banach, second_countable_topology}"
  assumes "finite I" "disjoint_family_on A I"
    and "\<And>i. i \<in> I \<Longrightarrow> set_integrable M (A i) f" "\<And>i. i \<in> I \<Longrightarrow> A i \<in> sets M"
  shows "(LINT x:(\<Union>i\<in>I. A i)|M. f x) = (\<Sum>i\<in>I. LINT x:A i|M. f x)"
  using assms
  apply induct
  apply (auto intro!: set_integral_Un set_integrable_Un set_integrable_UN simp: disjoint_family_on_def)
by (subst set_integral_Un, auto intro: set_integrable_UN)

(* TODO: find a better name? *)
lemma pos_integrable_to_top:
  fixes l::real
  assumes "\<And>i. A i \<in> sets M" "mono A"
  assumes nneg: "\<And>x i. x \<in> A i \<Longrightarrow> 0 \<le> f x"
  and intgbl: "\<And>i::nat. set_integrable M (A i) f"
  and lim: "(\<lambda>i::nat. LINT x:A i|M. f x) ----> l"
  shows "set_integrable M (\<Union>i. A i) f"
  apply (rule integrable_monotone_convergence[where f = "\<lambda>i::nat. \<lambda>x. indicator (A i) x *\<^sub>R f x" and x = l])
  apply (rule intgbl)
  prefer 3 apply (rule lim)
  apply (rule AE_I2)
  using `mono A` apply (auto simp: mono_def nneg split: split_indicator) []
proof (rule AE_I2)
  { fix x assume "x \<in> space M"
    show "(\<lambda>i. indicator (A i) x *\<^sub>R f x) ----> indicator (\<Union>i. A i) x *\<^sub>R f x"
    proof cases
      assume "\<exists>i. x \<in> A i"
      then guess i ..
      then have *: "eventually (\<lambda>i. x \<in> A i) sequentially"
        using `x \<in> A i` `mono A` by (auto simp: eventually_sequentially mono_def)
      show ?thesis
        apply (intro Lim_eventually)
        using *
        apply eventually_elim
        apply (auto split: split_indicator)
        done
    qed auto }
  then show "(\<lambda>x. indicator (\<Union>i. A i) x *\<^sub>R f x) \<in> borel_measurable M"
    apply (rule borel_measurable_LIMSEQ)
    apply assumption
    apply (intro borel_measurable_integrable intgbl)
    done
qed

(* Proof from Royden Real Analysis, p. 91. *)
lemma lebesgue_integral_countable_add:
  fixes f :: "_ \<Rightarrow> 'a :: {banach, second_countable_topology}"
  assumes meas[intro]: "\<And>i::nat. A i \<in> sets M"
    and disj: "\<And>i j. i \<noteq> j \<Longrightarrow> A i \<inter> A j = {}"
    and intgbl: "set_integrable M (\<Union>i. A i) f"
  shows "LINT x:(\<Union>i. A i)|M. f x = (\<Sum>i. (LINT x:(A i)|M. f x))"
proof (subst integral_suminf[symmetric])
  show int_A: "\<And>i. set_integrable M (A i) f"
    using intgbl by (rule set_integrable_subset) auto
  { fix x assume "x \<in> space M"
    have "(\<lambda>i. indicator (A i) x *\<^sub>R f x) sums (indicator (\<Union>i. A i) x *\<^sub>R f x)"
      by (intro sums_scaleR_left indicator_sums) fact }
  note sums = this

  have norm_f: "\<And>i. set_integrable M (A i) (\<lambda>x. norm (f x))"
    using int_A[THEN integrable_norm] by auto

  show "AE x in M. summable (\<lambda>i. norm (indicator (A i) x *\<^sub>R f x))"
    using disj by (intro AE_I2) (auto intro!: summable_mult2 sums_summable[OF indicator_sums])

  show "summable (\<lambda>i. LINT x|M. norm (indicator (A i) x *\<^sub>R f x))"
  proof (rule summableI_nonneg_bounded)
    fix n
    show "0 \<le> LINT x|M. norm (indicator (A n) x *\<^sub>R f x)"
      using norm_f by (auto intro!: integral_nonneg_AE)

    have "(\<Sum>i<n. LINT x|M. norm (indicator (A i) x *\<^sub>R f x)) =
      (\<Sum>i<n. set_lebesgue_integral M (A i) (\<lambda>x. norm (f x)))"
      by (simp add: abs_mult)
    also have "\<dots> = set_lebesgue_integral M (\<Union>i<n. A i) (\<lambda>x. norm (f x))"
      using norm_f
      by (subst set_integral_finite_Union) (auto simp: disjoint_family_on_def disj)
    also have "\<dots> \<le> set_lebesgue_integral M (\<Union>i. A i) (\<lambda>x. norm (f x))"
      using intgbl[THEN integrable_norm]
      by (intro integral_mono set_integrable_UN[of "{..<n}"] norm_f)
         (auto split: split_indicator)
    finally show "(\<Sum>i<n. LINT x|M. norm (indicator (A i) x *\<^sub>R f x)) \<le>
      set_lebesgue_integral M (\<Union>i. A i) (\<lambda>x. norm (f x))"
      by simp
  qed
  show "set_lebesgue_integral M (UNION UNIV A) f = LINT x|M. (\<Sum>i. indicator (A i) x *\<^sub>R f x)"
    apply (rule integral_cong[OF refl])
    apply (subst suminf_scaleR_left[OF sums_summable[OF indicator_sums, OF disj], symmetric])
    using sums_unique[OF indicator_sums[OF disj]]
    apply auto
    done
qed

lemma set_integral_cont_up:
  fixes f :: "_ \<Rightarrow> 'a :: {banach, second_countable_topology}"
  assumes [measurable]: "\<And>i. A i \<in> sets M" and A: "incseq A"
  and intgbl: "set_integrable M (\<Union>i. A i) f"
  shows "(\<lambda>i. LINT x:(A i)|M. f x) ----> LINT x:(\<Union>i. A i)|M. f x"
proof (intro integral_dominated_convergence[where w="\<lambda>x. indicator (\<Union>i. A i) x *\<^sub>R norm (f x)"])
  have int_A: "\<And>i. set_integrable M (A i) f"
    using intgbl by (rule set_integrable_subset) auto
  then show "\<And>i. set_borel_measurable M (A i) f" "set_borel_measurable M (\<Union>i. A i) f"
    "set_integrable M (\<Union>i. A i) (\<lambda>x. norm (f x))"
    using intgbl integrable_norm[OF intgbl] by auto

  { fix x i assume "x \<in> A i"
    with A have "(\<lambda>xa. indicator (A xa) x::real) ----> 1 \<longleftrightarrow> (\<lambda>xa. 1::real) ----> 1"
      by (intro filterlim_cong refl)
         (fastforce simp: eventually_sequentially incseq_def subset_eq intro!: exI[of _ i]) }
  then show "AE x in M. (\<lambda>i. indicator (A i) x *\<^sub>R f x) ----> indicator (\<Union>i. A i) x *\<^sub>R f x"
    by (intro AE_I2 tendsto_intros) (auto split: split_indicator)
qed (auto split: split_indicator)

(* Can the int0 hypothesis be dropped? *)
lemma set_integral_cont_down:
  fixes f :: "_ \<Rightarrow> 'a :: {banach, second_countable_topology}"
  assumes [measurable]: "\<And>i. A i \<in> sets M" and A: "decseq A"
  and int0: "set_integrable M (A 0) f"
  shows "(\<lambda>i::nat. LINT x:(A i)|M. f x) ----> LINT x:(\<Inter>i. A i)|M. f x"
proof (rule integral_dominated_convergence)
  have int_A: "\<And>i. set_integrable M (A i) f"
    using int0 by (rule set_integrable_subset) (insert A, auto simp: decseq_def)
  show "set_integrable M (A 0) (\<lambda>x. norm (f x))"
    using int0[THEN integrable_norm] by simp
  have "set_integrable M (\<Inter>i. A i) f"
    using int0 by (rule set_integrable_subset) (insert A, auto simp: decseq_def)
  with int_A show "set_borel_measurable M (\<Inter>i. A i) f" "\<And>i. set_borel_measurable M (A i) f"
    by auto
  show "\<And>i. AE x in M. norm (indicator (A i) x *\<^sub>R f x) \<le> indicator (A 0) x *\<^sub>R norm (f x)"
    using A by (auto split: split_indicator simp: decseq_def)
  { fix x i assume "x \<in> space M" "x \<notin> A i"
    with A have "(\<lambda>i. indicator (A i) x::real) ----> 0 \<longleftrightarrow> (\<lambda>i. 0::real) ----> 0"
      by (intro filterlim_cong refl)
         (auto split: split_indicator simp: eventually_sequentially decseq_def intro!: exI[of _ i]) }
  then show "AE x in M. (\<lambda>i. indicator (A i) x *\<^sub>R f x) ----> indicator (\<Inter>i. A i) x *\<^sub>R f x"
    by (intro AE_I2 tendsto_intros) (auto split: split_indicator)
qed

lemma set_integral_at_point:
  fixes a :: real
  assumes "set_integrable M {a} f"
  and [simp]: "{a} \<in> sets M" and "(emeasure M) {a} \<noteq> \<infinity>"
  shows "(LINT x:{a} | M. f x) = f a * measure M {a}"
proof-
  have "set_lebesgue_integral M {a} f = set_lebesgue_integral M {a} (%x. f a)"
    by (intro set_lebesgue_integral_cong) simp_all
  then show ?thesis using assms by simp
qed

abbreviation complex_integrable :: "'a measure \<Rightarrow> ('a \<Rightarrow> complex) \<Rightarrow> bool" where
  "complex_integrable M f \<equiv> integrable M f"

abbreviation complex_lebesgue_integral :: "'a measure \<Rightarrow> ('a \<Rightarrow> complex) \<Rightarrow> complex" ("integral\<^sup>C") where
  "integral\<^sup>C M f == integral\<^sup>L M f"

syntax
  "_complex_lebesgue_integral" :: "pttrn \<Rightarrow> complex \<Rightarrow> 'a measure \<Rightarrow> complex"
 ("\<integral>\<^sup>C _. _ \<partial>_" [60,61] 110)

translations
  "\<integral>\<^sup>Cx. f \<partial>M" == "CONST complex_lebesgue_integral M (\<lambda>x. f)"

syntax
  "_ascii_complex_lebesgue_integral" :: "pttrn \<Rightarrow> 'a measure \<Rightarrow> real \<Rightarrow> real"
  ("(3CLINT _|_. _)" [0,110,60] 60)

translations
  "CLINT x|M. f" == "CONST complex_lebesgue_integral M (\<lambda>x. f)"

lemma complex_integrable_cnj [simp]:
  "complex_integrable M (\<lambda>x. cnj (f x)) \<longleftrightarrow> complex_integrable M f"
proof
  assume "complex_integrable M (\<lambda>x. cnj (f x))"
  then have "complex_integrable M (\<lambda>x. cnj (cnj (f x)))"
    by (rule integrable_cnj)
  then show "complex_integrable M f"
    by simp
qed simp

lemma complex_of_real_integrable_eq:
  "complex_integrable M (\<lambda>x. complex_of_real (f x)) \<longleftrightarrow> integrable M f"
proof
  assume "complex_integrable M (\<lambda>x. complex_of_real (f x))"
  then have "integrable M (\<lambda>x. Re (complex_of_real (f x)))"
    by (rule integrable_Re)
  then show "integrable M f"
    by simp
qed simp

abbreviation complex_set_integrable :: "'a measure \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> complex) \<Rightarrow> bool" where
  "complex_set_integrable M A f \<equiv> set_integrable M A f"

abbreviation complex_set_lebesgue_integral :: "'a measure \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> complex) \<Rightarrow> complex" where
  "complex_set_lebesgue_integral M A f \<equiv> set_lebesgue_integral M A f"

syntax
"_ascii_complex_set_lebesgue_integral" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'a measure \<Rightarrow> real \<Rightarrow> real"
("(4CLINT _:_|_. _)" [0,60,110,61] 60)

translations
"CLINT x:A|M. f" == "CONST complex_set_lebesgue_integral M A (\<lambda>x. f)"

(*
lemma cmod_mult: "cmod ((a :: real) * (x :: complex)) = abs a * cmod x"
  apply (simp add: norm_mult)
  by (subst norm_mult, auto)
*)

lemma borel_integrable_atLeastAtMost':
  fixes f :: "real \<Rightarrow> 'a::{banach, second_countable_topology}"
  assumes f: "continuous_on {a..b} f"
  shows "set_integrable lborel {a..b} f" (is "integrable _ ?f")
  by (intro borel_integrable_compact compact_Icc f)

lemma integral_FTC_atLeastAtMost:
  fixes f :: "real \<Rightarrow> 'a :: euclidean_space"
  assumes "a \<le> b"
    and F: "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> (F has_vector_derivative f x) (at x within {a .. b})"
    and f: "continuous_on {a .. b} f"
  shows "integral\<^sup>L lborel (\<lambda>x. indicator {a .. b} x *\<^sub>R f x) = F b - F a"
proof -
  let ?f = "\<lambda>x. indicator {a .. b} x *\<^sub>R f x"
  have "(?f has_integral (\<integral>x. ?f x \<partial>lborel)) UNIV"
    using borel_integrable_atLeastAtMost'[OF f] by (rule has_integral_integral_lborel)
  moreover
  have "(f has_integral F b - F a) {a .. b}"
    by (intro fundamental_theorem_of_calculus ballI assms) auto
  then have "(?f has_integral F b - F a) {a .. b}"
    by (subst has_integral_eq_eq[where g=f]) auto
  then have "(?f has_integral F b - F a) UNIV"
    by (intro has_integral_on_superset[where t=UNIV and s="{a..b}"]) auto
  ultimately show "integral\<^sup>L lborel ?f = F b - F a"
    by (rule has_integral_unique)
qed

lemma set_borel_integral_eq_integral:
  fixes f :: "real \<Rightarrow> 'a::euclidean_space"
  assumes "set_integrable lborel S f"
  shows "f integrable_on S" "LINT x : S | lborel. f x = integral S f"
proof -
  let ?f = "\<lambda>x. indicator S x *\<^sub>R f x"
  have "(?f has_integral LINT x : S | lborel. f x) UNIV"
    by (rule has_integral_integral_lborel) fact
  hence 1: "(f has_integral (set_lebesgue_integral lborel S f)) S"
    apply (subst has_integral_restrict_univ [symmetric])
    apply (rule has_integral_eq)
    by auto
  thus "f integrable_on S"
    by (auto simp add: integrable_on_def)
  with 1 have "(f has_integral (integral S f)) S"
    by (intro integrable_integral, auto simp add: integrable_on_def)
  thus "LINT x : S | lborel. f x = integral S f"
    by (intro has_integral_unique [OF 1])
qed

lemma set_borel_measurable_continuous:
  fixes f :: "_ \<Rightarrow> _::real_normed_vector"
  assumes "S \<in> sets borel" "continuous_on S f"
  shows "set_borel_measurable borel S f"
proof -
  have "(\<lambda>x. if x \<in> S then f x else 0) \<in> borel_measurable borel"
    by (intro assms borel_measurable_continuous_on_if continuous_on_const)
  also have "(\<lambda>x. if x \<in> S then f x else 0) = (\<lambda>x. indicator S x *\<^sub>R f x)"
    by auto
  finally show ?thesis .
qed

end


theory T93
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(*<*)
theory Talk
imports "../lib/Lib"
begin
(*>*)

locale hats =
  fixes spare :: "nat"
  fixes assigned :: "nat list"
  assumes assign: "set (spare # assigned) = {0 .. length assigned}"

lemma (in hats) distinct_hats: "distinct (spare # assigned)"
  proof -
    have "set (spare # assigned) = {0 .. length assigned}"
      by (rule assign)
    hence "card (set (spare # assigned)) = card {0 .. length assigned}"
      by simp
    hence "card (set (spare # assigned)) = 1 + length assigned"
      by simp
    hence "card (set (spare # assigned)) = length (spare # assigned)"
      by simp
    thus "distinct (spare # assigned)"
      by (rule card_distinct)
  qed

lemma (in hats) distinct_hats': "distinct (spare # assigned)"
  by (rule card_distinct, subst assign, simp)

locale cats = hats +
  fixes spoken :: "nat list"
  assumes length: "length spoken = length assigned"

definition (in cats) "heard k \<equiv> take k spoken"
definition (in cats) "seen k \<equiv> drop (Suc k) assigned"

text \<open>\clearpage\<close>

definition
  candidates_excluding :: "nat list \<Rightarrow> nat list \<Rightarrow> nat set"
where
  "candidates_excluding heard seen \<equiv>
    let excluded = heard @ seen in
      {0 .. 1 + length excluded} - set excluded"

definition (in cats)
  "candidates i \<equiv> candidates_excluding (heard i) (seen i)"

lemma (in cats) candidates_i:
  fixes a b i
  defines "view \<equiv> (a # heard i @ b # seen i)"
  assumes "i < length assigned"
  assumes "set view = {0..length assigned}"
  assumes "distinct view"
  shows "candidates i = {a,b}"
  proof %invisible -
    let ?excluded = "heard i @ seen i"
    have len: "1 + length ?excluded = length assigned"
      unfolding heard_def seen_def using assms length by auto
    have set: "set ?excluded = {0..length assigned} - {a,b}"
      apply (rule subset_minusI)
      using assms unfolding view_def by auto
    show ?thesis
      unfolding candidates_def candidates_excluding_def Let_def
      unfolding len set
      unfolding Diff_Diff_Int subset_absorb_r
      using assms unfolding view_def
      by auto
  qed

text \<open>\clearpage\<close>

locale cat_0 = cats +
  assumes exists_0: "0 < length assigned"

abbreviation (in cat_0) (input)
  "view_0 \<equiv> spare # assigned ! 0 # seen 0"

lemma (in cat_0) set_0: "set view_0 = {0..length assigned}"
  using %invisible assign unfolding %invisible seen_def Cons_nth_drop_Suc[OF exists_0]
  by %invisible auto
lemma (in cat_0) distinct_0: "distinct view_0"
  using %invisible distinct_hats unfolding %invisible seen_def Cons_nth_drop_Suc[OF exists_0]
  by %invisible auto

lemma (in cat_0) candidates_0:
  "candidates 0 = {spare, assigned ! 0}"
  using %invisible candidates_i[OF exists_0] distinct_0 set_0 unfolding %invisible heard_def
  by %invisible auto

definition (in cat_0)
  "rejected \<equiv> if spoken ! 0 = spare then assigned ! 0 else spare"

abbreviation (in cat_0) (input)
  "view_r \<equiv> rejected # spoken ! 0 # seen 0"

locale cat_0_spoken = cat_0 +
  assumes spoken_candidate_0: "spoken ! 0 \<in> candidates 0"

lemma (in cat_0_spoken) set_r: "set view_r = {0..length assigned}"
  using %invisible spoken_candidate_0 set_0 candidates_0 rejected_def by %invisible auto
lemma (in cat_0_spoken) distinct_r: "distinct view_r"
  using %invisible spoken_candidate_0 distinct_0 candidates_0 rejected_def by %invisible auto

text \<open>\clearpage\<close>

locale cat_k = cats +
  fixes k :: "nat"
  assumes k_min: "0 < k"
  assumes k_max: "k < length assigned"
  assumes IH: "\<forall>i \<in> {1 ..< k}. spoken ! i = assigned ! i"

lemma (in cats) cat_k_induct:
  assumes "\<And>k. cat_k spare assigned spoken k \<Longrightarrow> spoken ! k = assigned ! k"
  shows "k \<in> {1 ..< length assigned} \<Longrightarrow> spoken ! k = assigned ! k"
  apply (induct k rule: nat_less_induct)
  apply (rule assms)
  apply (unfold_locales)
  by auto

lemma (in cat_k) heard_k:
  "heard k = spoken ! 0 # map (op ! assigned) [Suc 0 ..< k]"
  using %invisible heard_def[of k] IH take_map_nth[of k spoken] k_max length
        range_extract_head[OF k_min]
  by %invisible auto

sublocale cat_k < cat_0
  using k_max by unfold_locales auto

abbreviation (in cat_k) (input)
  "view_k \<equiv> rejected # heard k @ assigned ! k # seen k"

lemmas %invisible (in cat_k) drop_maps =
  drop_map_nth[OF less_imp_le_nat, OF k_max]
  drop_map_nth[OF Suc_leI[OF exists_0]]

lemma (in cat_k) view_eq: "view_k = view_r"
  unfolding %invisible heard_k seen_def
  apply %invisible (simp add: k_max Cons_nth_drop_Suc drop_maps)
  apply %invisible (subst map_append[symmetric])
  apply %invisible (rule arg_cong[where f="map _"])
  apply %invisible (rule range_app)
  using %invisible k_max k_min less_imp_le Suc_le_eq
  by %invisible auto

locale cat_k_view = cat_k + cat_0_spoken

lemma (in cat_k_view) set_k: "set view_k = {0..length assigned}"
  using %invisible view_eq set_r by %invisible simp
lemma (in cat_k_view) distinct_k: "distinct view_k"
  using %invisible view_eq distinct_r by %invisible simp

lemma (in cat_k_view) candidates_k:
  "candidates k = {rejected, assigned ! k}"
  using %invisible candidates_i[OF k_max] distinct_k set_k by %invisible simp

text \<open>\clearpage\<close>

locale classifier =
  fixes parity :: "nat list \<Rightarrow> bool"
  assumes parity_swap_first:
    "\<And>a heard b seen. distinct (a # heard @ b # seen) \<Longrightarrow>
      parity (a # heard @ b # seen) \<longleftrightarrow> \<not> parity (b # heard @ a # seen)"

definition (in classifier)
  choice :: "nat list \<Rightarrow> nat list \<Rightarrow> nat"
where
  "choice heard seen \<equiv>
    case sorted_list_of_set (candidates_excluding heard seen) of
      [a,b] \<Rightarrow> if parity (a # heard @ b # seen) then b else a"

primrec (in classifier)
  choices' :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list"
where
  "choices' heard [] = []"
| "choices' heard (_ # seen)
    = (let c = choice heard seen in c # choices' (heard @ [c]) seen)"

definition (in classifier) "choices \<equiv> choices' []"

lemma %invisible (in classifier) choices'_length: "length (choices' heard assigned) = length assigned"
  by (induct assigned arbitrary: heard) (auto simp: Let_def)

lemma %invisible (in classifier) choices_length: "length (choices assigned) = length assigned"
  by (simp add: choices_def choices'_length)

lemma %invisible (in classifier) choices':
  assumes "i < length assigned"
  assumes "spoken = choices' heard assigned"
  shows "spoken ! i = choice (heard @ take i spoken) (drop (Suc i) assigned)"
  using assms proof (induct assigned arbitrary: i spoken heard)
    case Cons thus ?case by (cases i) (auto simp: Let_def)
  qed simp

lemma (in classifier) choices:
  assumes "i < length assigned"
  assumes "spoken = choices assigned"
  shows "spoken ! i = choice (take i spoken) (drop (Suc i) assigned)"
  using %invisible assms choices' by %invisible (simp add: choices_def)

text \<open>\clearpage\<close>

locale hats_parity = hats + classifier

sublocale hats_parity < cats spare assigned "choices assigned"
  using %invisible choices_length by %invisible unfold_locales

locale cat_0_parity = hats_parity spare assigned parity
  + cat_0 spare assigned "choices assigned"
  for spare assigned parity

locale cat_k_parity = cat_0_parity spare assigned parity
  + cat_k spare assigned "choices assigned" k
  for spare assigned parity k

lemma %invisible (in cat_0) candidates_excluding_0:
  "candidates_excluding [] (seen 0) = {spare, assigned ! 0}"
  using candidates_0 unfolding candidates_def heard_def take_0 by simp

lemma %invisible (in cat_k_view) candidates_excluding_k:
  "candidates_excluding (heard k) (seen k) = {rejected, assigned ! k}"
  using candidates_k unfolding candidates_def by simp

lemma %invisible (in cat_0_parity) parity_swap_0:
  "parity (spare # assigned ! 0 # seen 0) \<longleftrightarrow> \<not> parity (assigned ! 0 # spare # seen 0)"
  using parity_swap_first[of spare "[]"] distinct_0 by simp

lemma %invisible (in cat_0_parity) choices_0: "choices assigned ! 0 = choice [] (seen 0)"
  using choices[OF exists_0] unfolding seen_def by simp

lemma %invisible (in cat_k_parity) choices_k:
  "choices assigned ! k = choice (heard k) (seen k)"
  unfolding heard_def seen_def using choices[OF k_max] by simp

lemma (in cat_0_parity) choice_0:
  "choices assigned ! 0 = (if parity view_0 then assigned ! 0 else spare)"
  using %invisible distinct_0 parity_swap_0
  unfolding %invisible choices_0 choice_def candidates_excluding_0
  by %invisible (subst sorted_list_of_set_distinct_pair) auto

lemma (in cat_0_parity) parity_r: "parity view_r"
  using %invisible distinct_0 parity_swap_0
  unfolding %invisible choices_0 choice_def candidates_excluding_0 rejected_def
  by %invisible auto
lemma (in cat_k_parity) parity_k: "parity view_k"
  using %invisible parity_r view_eq by %invisible simp

sublocale cat_k_parity < cat_k_view spare assigned "choices assigned" k
  using %invisible choice_0 candidates_0 by %invisible unfold_locales simp

lemma (in cat_k_parity) choice_k: "choices assigned ! k = assigned ! k"
  using %invisible parity_swap_first[OF distinct_k] distinct_k parity_k
  unfolding %invisible choices_k choice_def candidates_excluding_k
  by %invisible (subst sorted_list_of_set_distinct_pair) auto

lemma %invisible (in hats_parity) cat_k_parity:
  assumes "cat_k spare assigned (choices assigned) k"
  shows "cat_k_parity spare assigned parity k"
  proof -
    interpret cat_k spare assigned "choices assigned" k by (rule assms)
    show ?thesis by unfold_locales
  qed

lemma (in hats_parity) choices_correct:
  "k \<in> {1..<length assigned} \<Longrightarrow> choices assigned ! k = assigned ! k"
  by %invisible (rule cat_k_induct[OF cat_k_parity.choice_k, OF cat_k_parity])

text \<open>\clearpage\<close>

-- "Do we have an even number of inversions?"
primrec
  parity :: "nat list \<Rightarrow> bool"
where
  "parity [] = True"
| "parity (x # ys) = (parity ys = even (length [y \<leftarrow> ys. x > y]))"

lemma parity_odd: "parity [1,2,0,5,4,3] = False"
  by %invisible eval
lemma parity_even: "parity [2,1,0,5,4,3] = True"
  by %invisible eval

lemma parity_swap_adj:
  "b \<noteq> c \<Longrightarrow> parity (as @ b # c # ds) \<longleftrightarrow> \<not> parity (as @ c # b # ds)"
  by (induct as) auto

lemma parity_swap:
  assumes "b \<noteq> d \<and> b \<notin> set cs \<and> d \<notin> set cs"
  shows "parity (as @ b # cs @ d # es) \<longleftrightarrow> \<not> parity (as @ d # cs @ b # es)"
  using %invisible assms
  proof %invisible (induct cs arbitrary: as)
    case Nil thus ?case using parity_swap_adj[of b d as es] by simp
  next
    case (Cons c cs')
    have " parity (as @ b # c # cs' @ d # es) \<longleftrightarrow> \<not> parity (as @ c # b # cs' @ d # es)"
      using Cons parity_swap_adj[of b c as "cs' @ d # es"] by simp
    moreover
    have "parity (as @ c # b # cs' @ d # es) \<longleftrightarrow> \<not> parity (as @ c # d # cs' @ b # es)"
      using Cons(1)[where as="as @ [c]"] Cons(2) by simp
    moreover
    have "parity (as @ c # d # cs' @ b # es) \<longleftrightarrow> \<not> parity (as @ d # c # cs' @ b # es)"
      using Cons parity_swap_adj[of c d as "cs' @ b # es"] by simp
    ultimately
    show "parity (as @ b # (c # cs') @ d # es) \<longleftrightarrow> \<not> parity (as @ d # (c # cs') @ b # es)"
      by simp
  qed

global_interpretation classifier parity
  using %invisible parity_swap[where as="[]"] by %invisible unfold_locales simp

sublocale hats < hats_parity spare assigned parity
  by %invisible unfold_locales

context hats begin
  lemma example_odd: "choices [2,0,5,4,3] = [1,0,5,4,3]"
    unfolding %invisible choices_def choices'_def Let_def choice_def
    by %invisible eval
  lemma example_even: "choices [1,0,5,4,3] = [1,0,5,4,3]"
    unfolding %invisible choices_def choices'_def Let_def choice_def
    by %invisible eval
end

(*<*)
end
(*>*)


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   June 2005  (modified)   |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Infra_prog
imports Infra_real
begin

(*****************************************************
                    Progression
 *****************************************************)

primrec
  prog_sum0 :: "nat => (nat => real) => real"
where
  "prog_sum0 (Suc n) f = (prog_sum0 n f) + f (Suc n)"
 |"prog_sum0 0 f = 0"

(* Isabelle 2013
consts
  prog_sum  :: "nat => nat => (nat => real) => real"
  geo_prop  :: "real => real => nat => real"

defs
  prog_sum_def :
    "prog_sum m n f == (prog_sum0 n f) - (prog_sum0 m f)"

  geo_prop_def :
    "geo_prop K alpha == (%n. (alpha^(n - (Suc 0))) * K)"
*)

definition
  prog_sum  :: "nat => nat => (nat => real) => real"
  where
  "prog_sum m n f == (prog_sum0 n f) - (prog_sum0 m f)"

definition
  geo_prop  :: "real => real => nat => real"
  where
    "geo_prop K alpha == (%n. (alpha^(n - (Suc 0))) * K)"

lemma geo_prog_sum0:
  "prog_sum0 n (geo_prop K alpha) * ((1::real) - alpha)
       = K*((1::real)-(alpha^n))"
apply (induct_tac n)
apply (simp)
apply (simp add: geo_prop_def)
apply (simp add: distrib_right)
apply (simp add: right_diff_distrib)
done

lemma geo_prog_sum:
  "prog_sum m n (geo_prop K alpha) * ((1::real) - alpha)
       = K*((alpha^m)-(alpha^n))"
apply (unfold prog_sum_def)
apply (simp add: left_diff_distrib)
apply (simp add: geo_prog_sum0)
apply (simp add: right_diff_distrib)
done

lemmas geo_prog_sum_sym = geo_prog_sum[THEN sym]

lemma geo_prog_sum_div:
  "alpha < (1::real)
    ==> prog_sum m n (geo_prop K alpha)
      = K*((alpha^m)-(alpha^n)) / ((1::real)-alpha)"
by (simp add: geo_prog_sum_sym)

lemma geo_prog_sum_infinite:
  "[| (0::real) <= K ; (0::real) <= alpha |]
   ==>  prog_sum m n (geo_prop K alpha) * ((1::real)-alpha)
       <= K*(alpha^m)"
apply (simp add: geo_prog_sum)
apply (simp add: right_diff_distrib)
(*
apply (simp add: real_mult_order_eq)
for Isabelle 2013
apply (simp add: zero_le_power real_mult_order_eq)
for Isabelle 2007
*)
done

lemma geo_prog_sum_infinite_div:
  "[| (0::real) <= K ; (0::real) <= alpha ; alpha < (1::real) |]
   ==> prog_sum m n (geo_prop K alpha) <= K*(alpha^m)/((1::real)-alpha)"
apply (simp add: real_div_le_eq)
apply (simp_all add: geo_prog_sum_infinite)
done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_int_add_inv_left
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

definition(*fun*) zero :: "Integer" where
  "zero = P Z"

fun pred :: "Nat => Nat" where
  "pred (S y) = y"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun neg :: "Integer => Integer" where
  "neg (P (Z)) = P Z"
| "neg (P (S z)) = N z"
| "neg (N n) = P (plus (S Z) n)"

fun t2 :: "Nat => Nat => Integer" where
  "t2 x y =
   (let fail :: Integer =
     (case y of
        Z => P x
        | S z =>
            (case x of
               Z => N y
               | S x2 => t2 x2 z))
   in (case x of
         Z =>
           (case y of
              Z => P Z
              | S x4 => fail)
         | S x3 => fail))"

fun plus2 :: "Integer => Integer => Integer" where
  "plus2 (P m) (P n) = P (plus m n)"
| "plus2 (P m) (N o2) = t2 m (plus (S Z) o2)"
| "plus2 (N m2) (P n2) = t2 n2 (plus (S Z) m2)"
| "plus2 (N m2) (N n3) = N (plus (plus (S Z) m2) n3)"

theorem property0 :
  "((plus2 (neg x) x) = zero)"
  oops

end


(*
  Correctness of BFS

  Isabelle 2014

  Copyright (c) 2020 Hisabumi Hatsugai
*)

theory CorrectnessBFS
imports "~~/src/HOL/Hoare/Hoare_Logic"
begin

lemma l0 [rule_format]:
  "[| (a, x) : r^*; r `` s <= s Un f |] ==>
   (a : s | a : f) -->
   x : s Un f Un r^* `` (r `` f - (s Un f))"
apply(erule converse_rtrancl_induct)
apply(auto)
done

(*
  R: directed edges
  a: initial node
  s: set of nodes visited
  f: frontier
*)
theorem
  "VARS s f
  {True}
  s := {};
  f := {a};
  WHILE f ~= {}
  INV {
    s Un R^* `` f = R^* `` {a} &
    R `` s <= s Un f &
    a : s Un f
  }
  DO
    s := s Un f;
    f := R `` f - s
  OD
  {s = R^* `` {a}}"

apply(vcg)
apply(auto intro: transitive_closure_trans)
apply(drule_tac x=xa and s=s and f=f in l0)
apply(auto)
apply(drule_tac x=xa and s=s and f=f in l0)
apply(auto)
done

end


header{* Untyped (Unsorted) First-Order Logic *}
theory U
imports TermsAndClauses
begin

text{* Even though untyped FOL is a particular case of many-typed FOL, we find
it convenient to represent it separately.  *}

subsection {* Signatures *}

locale Signature =
fixes
    wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> nat"
and parOf :: "'psym \<Rightarrow> nat"
assumes countable_wtFsym: "countable {f::'fsym. wtFsym f}"
and countable_wtPsym: "countable {p::'psym. wtPsym p}"
begin

(* Well-typed terms *)
fun wt where
"wt (Var x) \<longleftrightarrow> True"
|
"wt (Fn f Tl) \<longleftrightarrow> wtFsym f \<and> list_all wt Tl \<and> arOf f = length Tl"

lemma wt_induct[elim, consumes 1, case_names Var Fn, induct pred: wt]:
assumes T: "wt T"
and Var: "\<And> x. \<phi> (Var x)"
and Fn:
"\<And> f Tl.
   \<lbrakk>wtFsym f; list_all wt Tl; arOf f = length Tl; list_all \<phi> Tl\<rbrakk>
 \<Longrightarrow> \<phi> (Fn f Tl)"
shows "\<phi> T"
proof-
  have "wt T \<longrightarrow> \<phi> T"
  apply (induct T) using Var Fn by (auto simp: list_all_iff)
  thus ?thesis using T by auto
qed

(* Well-typed substitutions *)
definition "wtSB \<pi> \<equiv> \<forall> x. wt (\<pi> x)"

lemma wtSB_wt[simp]: "wtSB \<pi> \<Longrightarrow> wt (\<pi> x)"
unfolding wtSB_def by auto

lemma wt_subst[simp]:
assumes "wtSB \<pi>" and "wt T"
shows "wt (subst \<pi> T)"
using assms by (induct T) (auto simp: list_all_length)

lemma wtSB_o:
assumes 1: "wtSB \<pi>1" and 2: "wtSB \<pi>2"
shows "wtSB (subst \<pi>1 o \<pi>2)"
using 2 unfolding wtSB_def using 1 by auto

end (* context Signature *)

subsection {* Structures *}

(* Environment *)
type_synonym 'univ env = "var \<Rightarrow> 'univ"

(* Structure *)
locale Struct = Signature wtFsym wtPsym arOf parOf
for wtFsym and wtPsym
and arOf :: "'fsym \<Rightarrow> nat"
and parOf :: "'psym \<Rightarrow> nat"
+
fixes
    D :: "'univ \<Rightarrow> bool"
and intF :: "'fsym \<Rightarrow> 'univ list \<Rightarrow> 'univ"
and intP :: "'psym \<Rightarrow> 'univ list \<Rightarrow> bool"
assumes
NE_D: "NE D" and
intF: "\<lbrakk>wtFsym f; length al = arOf f; list_all D al\<rbrakk> \<Longrightarrow> D (intF f al)"
and
dummy: "parOf = parOf \<and> intF = intF \<and> intP = intP"
begin

(* Well-typed environment *)
definition "wtE \<xi> \<equiv> \<forall> x. D (\<xi> x)"

lemma wtTE_D[simp]: "wtE \<xi> \<Longrightarrow> D (\<xi> x)"
unfolding wtE_def by simp

(* Interpretation of terms: *)
fun int where
"int \<xi> (Var x) = \<xi> x"
|
"int \<xi> (Fn f Tl) = intF f (map (int \<xi>) Tl)"

(* Soundness of typing w.r.t. interpretation: *)
lemma wt_int:
assumes wtE: "wtE \<xi>" and wt_T: "wt T"
shows "D (int \<xi> T)"
using wt_T apply(induct T)
apply (metis int.simps(1) wtE wtE_def)
unfolding int.simps apply(rule intF)
unfolding list_all_map comp_def by auto

lemma int_o:
"int (int \<xi> o \<rho>) T = int \<xi> (subst \<rho> T)"
apply(induct T) apply simp_all  unfolding list_all_iff o_def
using map_ext by (metis (lifting, no_types))

lemmas int_subst = int_o[symmetric]

lemma int_o_subst:
"int \<xi> o subst \<rho> = int (int \<xi> o \<rho>)"
apply(rule ext) apply(subst comp_def) unfolding int_o[symmetric] ..

lemma wtE_o:
assumes 1: "wtE \<xi>" and 2: "wtSB \<rho>"
shows "wtE (int \<xi> o \<rho>)"
unfolding wtE_def apply safe
unfolding comp_def apply(rule wt_int[OF 1]) using 2 by auto

end

context Signature begin

text{* Well-typed (i.e., well-formed) atoms, literals, caluses and problems: *}

fun wtA where
"wtA (Eq T1 T2) \<longleftrightarrow> wt T1 \<and> wt T2"
|
"wtA (Pr p Tl) \<longleftrightarrow> wtPsym p \<and> list_all wt Tl \<and> parOf p = length Tl"

fun wtL where
"wtL (Pos a) \<longleftrightarrow> wtA a"
|
"wtL (Neg a) \<longleftrightarrow> wtA a"

definition "wtC \<equiv> list_all wtL"

definition "wtPB \<Phi> \<equiv> \<forall> c \<in> \<Phi>. wtC c"

end (* context Signature *)

context Struct begin

(* Satisfaction of atoms: *)
fun satA where
"satA \<xi> (Eq T1 T2) \<longleftrightarrow> int \<xi> T1 = int \<xi> T2"
|
"satA \<xi> (Pr r Tl) \<longleftrightarrow> intP r (map (int \<xi>) Tl)"

(* Satisfaction literals: *)
fun satL where
"satL \<xi> (Pos a) \<longleftrightarrow> satA \<xi> a"
|
"satL \<xi> (Neg a) \<longleftrightarrow> \<not> satA \<xi> a"

(* Satisfaction of clauses: *)
definition "satC \<xi> \<equiv> list_ex (satL \<xi>)"

(* satisfaction of problems *)
definition "satPB \<xi> \<Phi> \<equiv> \<forall> c \<in> \<Phi>. satC \<xi> c"

definition "SAT \<Phi> \<equiv> \<forall> \<xi>. wtE \<xi> \<longrightarrow> satPB \<xi> \<Phi>"

end (* context Struct *)

subsection{* Problems *}

locale Problem = Signature wtFsym wtPsym arOf parOf
for wtFsym and wtPsym
and arOf :: "'fsym \<Rightarrow> nat"
and parOf :: "'psym \<Rightarrow> nat"
+
fixes \<Phi> :: "('fsym, 'psym) prob"
assumes wt_\<Phi>: "wtPB \<Phi>"

subsection{* Models of a problem *}

locale Model =
  Problem wtFsym wtPsym arOf parOf \<Phi> +
  Struct wtFsym wtPsym arOf parOf D intF intP
for wtFsym and wtPsym
and arOf :: "'fsym \<Rightarrow> nat"
and parOf :: "'psym \<Rightarrow> nat"
and \<Phi> :: "('fsym, 'psym) prob"
and D :: "'univ \<Rightarrow> bool"
and intF :: "'fsym \<Rightarrow> 'univ list \<Rightarrow> 'univ"
and intP :: "'psym \<Rightarrow> 'univ list \<Rightarrow> bool"
+
assumes SAT: "SAT \<Phi>"

end


(*<*)
theory How_to_Prove_it
imports Complex_Main
begin
(*>*)
text{*
\chapter{@{theory Main}}

\section{Natural numbers}

%Tobias Nipkow
\paragraph{Induction rules}~\\
In addition to structural induction there is the induction rule
@{thm[source] less_induct}:
\begin{quote}
@{thm less_induct}
\end{quote}
This is often called ``complete induction''. It is applied like this:
\begin{quote}
(@{text"induction n rule: less_induct"})
\end{quote}
In fact, it is not restricted to @{typ nat} but works for any wellfounded
order @{text"<"}.

There are many more special induction rules. You can find all of them
via the Find button (in Isabelle/jedit) with the following search criteria:
\begin{quote}
\texttt{name: Nat name: induct}
\end{quote}

\paragraph{How to convert numerals into @{const Suc} terms}~\\
Solution: simplify with the lemma @{thm[source] numeral_eq_Suc}.

\noindent
Example:
*}

lemma fixes x :: int shows "x ^ 3 = x * x * x"
by (simp add: numeral_eq_Suc)

text{* This is a typical situation: function ``@{text"^"}'' is defined
by pattern matching on @{const Suc} but is applied to a numeral.

Note: simplification with @{thm[source] numeral_eq_Suc} will convert all numerals.
One can be more specific with the lemmas @{thm [source] numeral_2_eq_2}
(@{thm numeral_2_eq_2}) and @{thm[source] numeral_3_eq_3} (@{thm numeral_3_eq_3}).

\section{Lists}

%Tobias Nipkow
\paragraph{Induction rules}~\\
In addition to structural induction there are a few more induction rules
that come in handy at times:
\begin{itemize}
\item
Structural induction where the new element is appended to the end
of the list (@{thm[source] rev_induct}):

@{thm rev_induct}

\item Induction on the length of a list (@{thm [source] length_induct}):

@{thm length_induct}

\item Simultaneous induction on two lists of the same length (@{thm [source] list_induct2}):

@{thm[display,margin=60] list_induct2}

\end{itemize}

%Tobias Nipkow
\section{Algebraic simplification}

On the numeric types @{typ nat}, @{typ int} and @{typ real},
proof method @{text simp} and friends can deal with a limited amount of linear
arithmetic (no multiplication except by numerals) and method @{text arith} can
handle full linear arithmetic (on @{typ nat}, @{typ int} including quantifiers).
But what to do when proper multiplication is involved?
At this point it can be helpful to simplify with the lemma list
@{thm [source] algebra_simps}. Examples:
*}

lemma fixes x :: int
  shows "(x + y) * (y - z) = (y - z) * x + y * (y-z)"
by(simp add: algebra_simps)

lemma fixes x :: "'a :: comm_ring"
  shows "(x + y) * (y - z) = (y - z) * x + y * (y-z)"
by(simp add: algebra_simps)

text{*
Rewriting with @{thm[source] algebra_simps} has the following effect:
terms are rewritten into a normal form by multiplying out,
rearranging sums and products into some canonical order.
In the above lemma the normal form will be something like
@{term"x*y + y*y - x*z - y*z"}.
This works for concrete types like @{typ int} as well as for classes like
@{class comm_ring} (commutative rings). For some classes (e.g.\ @{class ring}
and @{class comm_ring}) this yields a decision procedure for equality.

Additional function and predicate symbols are not a problem either:
*}

lemma fixes f :: "int \<Rightarrow> int" shows "2 * f(x*y) - f(y*x) < f(y*x) + 1"
by(simp add: algebra_simps)

text{* Here @{thm[source]algebra_simps} merely has the effect of rewriting
@{term"y*x"} to @{term"x*y"} (or the other way around). This yields
a problem of the form @{prop"2*t - t < t + (1::int)"} and we are back in the
realm of linear arithmetic.

Because @{thm[source]algebra_simps} multiplies out, terms can explode.
If one merely wants to bring sums or products into a canonical order
it suffices to rewrite with @{thm [source] ac_simps}: *}

lemma fixes f :: "int \<Rightarrow> int" shows "f(x*y*z) - f(z*x*y) = 0"
by(simp add: ac_simps)

text{* The lemmas @{thm[source]algebra_simps} take care of addition, subtraction
and multiplication (algebraic structures up to rings) but ignore division (fields).
The lemmas @{thm[source]field_simps} also deal with division:
*}

lemma fixes x :: real shows "x+z \<noteq> 0 \<Longrightarrow> 1 + y/(x+z) = (x+y+z)/(x+z)"
by(simp add: field_simps)

text{* Warning: @{thm[source]field_simps} can blow up your terms
beyond recognition. *}

(*<*)
end
(*>*)


theory Cyclic_List imports
  "HOL-Library.Confluent_Quotient"
begin

inductive cyclic1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" for xs where
  "cyclic1 xs (rotate1 xs)"

abbreviation cyclic :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "cyclic \<equiv> equivclp cyclic1"

lemma cyclic_mapI: "cyclic xs ys \<Longrightarrow> cyclic (map f xs) (map f ys)"
  by(induction rule: equivclp_induct)
    (auto 4 4 elim!: cyclic1.cases simp add: rotate1_map[symmetric] intro: equivclp_into_equivclp cyclic1.intros)

quotient_type 'a cyclic_list = "'a list" / cyclic by simp

lemma map_respect_cyclic: includes lifting_syntax shows
  "((=) ===> cyclic ===> cyclic) map map"
  by(auto simp add: rel_fun_def cyclic_mapI)

lemma confluentp_cyclic1: "confluentp cyclic1"
  by(intro strong_confluentp_imp_confluentp strong_confluentpI)(auto simp add: cyclic1.simps)

lemma cyclic_set_eq: "cyclic xs ys \<Longrightarrow> set xs = set ys"
  by(induction rule: converse_equivclp_induct)(simp_all add: cyclic1.simps, safe, simp_all)

lemma retract_cyclic1:
  assumes "cyclic1 (map f xs) ys"
  shows "\<exists>zs. cyclic xs zs \<and> ys = map f zs \<and> set zs \<subseteq> set xs"
  using assms by(force simp add: cyclic1.simps rotate1_map intro: cyclic1.intros symclpI1)

lemma confluent_quotient_cyclic1:
  "confluent_quotient cyclic1 cyclic cyclic cyclic cyclic cyclic (map fst) (map snd) (map fst) (map snd) list_all2 list_all2 list_all2 set set"
  by(unfold_locales)
    (auto dest: retract_cyclic1 cyclic_set_eq simp add: list.in_rel list.rel_compp map_respect_cyclic[THEN rel_funD, OF refl] confluentp_cyclic1 intro: rtranclp_mono[THEN predicate2D, OF symclp_greater])

lift_bnf 'a cyclic_list
  subgoal by(rule confluent_quotient.subdistributivity[OF confluent_quotient_cyclic1])
  subgoal by(force dest: cyclic_set_eq)
  done

end


(*  Title:      HOL/Algebra/Exponent.thy
    Author:     Florian Kammueller
    Author:     L C Paulson

exponent p s   yields the greatest power of p that divides s.
*)

theory Exponent
imports Main "~~/src/HOL/Number_Theory/Primes"
begin

section \<open>Sylow's Theorem\<close>

text \<open>The Combinatorial Argument Underlying the First Sylow Theorem\<close>

text\<open>needed in this form to prove Sylow's theorem\<close>
corollary (in algebraic_semidom) div_combine:
  "\<lbrakk>prime_elem p; \<not> p ^ Suc r dvd n; p ^ (a + r) dvd n * k\<rbrakk> \<Longrightarrow> p ^ a dvd k"
  by (metis add_Suc_right mult.commute prime_elem_power_dvd_cases)

lemma exponent_p_a_m_k_equation:
  fixes p :: nat
  assumes "0 < m" "0 < k" "p \<noteq> 0" "k < p^a"
    shows "multiplicity p (p^a * m - k) = multiplicity p (p^a - k)"
proof (rule multiplicity_cong [OF iffI])
  fix r
  assume *: "p ^ r dvd p ^ a * m - k"
  show "p ^ r dvd p ^ a - k"
  proof -
    have "k \<le> p ^ a * m" using assms
      by (meson nat_dvd_not_less dvd_triv_left leI mult_pos_pos order.strict_trans)
    then have "r \<le> a"
      by (meson "*" \<open>0 < k\<close> \<open>k < p^a\<close> dvd_diffD1 dvd_triv_left leI less_imp_le_nat nat_dvd_not_less power_le_dvd)
    then have "p^r dvd p^a * m" by (simp add: le_imp_power_dvd)
    thus ?thesis
      by (meson \<open>k \<le> p ^ a * m\<close> \<open>r \<le> a\<close> * dvd_diffD1 dvd_diff_nat le_imp_power_dvd)
  qed
next
  fix r
  assume *: "p ^ r dvd p ^ a - k"
  with assms have "r \<le> a"
    by (metis diff_diff_cancel less_imp_le_nat nat_dvd_not_less nat_le_linear power_le_dvd zero_less_diff)
  show "p ^ r dvd p ^ a * m - k"
  proof -
    have "p^r dvd p^a*m"
      by (simp add: \<open>r \<le> a\<close> le_imp_power_dvd)
    then show ?thesis
      by (meson assms * dvd_diffD1 dvd_diff_nat le_imp_power_dvd less_imp_le_nat \<open>r \<le> a\<close>)
  qed
qed

lemma p_not_div_choose_lemma:
  fixes p :: nat
  assumes eeq: "\<And>i. Suc i < K \<Longrightarrow> multiplicity p (Suc i) = multiplicity p (Suc (j + i))"
      and "k < K" and p: "prime p"
    shows "multiplicity p (j + k choose k) = 0"
  using \<open>k < K\<close>
proof (induction k)
  case 0 then show ?case by simp
next
  case (Suc k)
  then have *: "(Suc (j+k) choose Suc k) > 0" by simp
  then have "multiplicity p ((Suc (j+k) choose Suc k) * Suc k) = multiplicity p (Suc k)"
    by (subst Suc_times_binomial_eq [symmetric], subst prime_elem_multiplicity_mult_distrib)
       (insert p Suc.prems, simp_all add: eeq [symmetric] Suc.IH)
  with p * show ?case
    by (subst (asm) prime_elem_multiplicity_mult_distrib) simp_all
qed

text\<open>The lemma above, with two changes of variables\<close>
lemma p_not_div_choose:
  assumes "k < K" and "k \<le> n"
      and eeq: "\<And>j. \<lbrakk>0<j; j<K\<rbrakk> \<Longrightarrow> multiplicity p (n - k + (K - j)) = multiplicity p (K - j)" "prime p"
    shows "multiplicity p (n choose k) = 0"
apply (rule p_not_div_choose_lemma [of K p "n-k" k, simplified assms nat_minus_add_max max_absorb1])
apply (metis add_Suc_right eeq diff_diff_cancel order_less_imp_le zero_less_Suc zero_less_diff)
apply (rule TrueI)+
done

proposition const_p_fac:
  assumes "m>0" and prime: "prime p"
  shows "multiplicity p (p^a * m choose p^a) = multiplicity p m"
proof-
  from assms have p: "0 < p ^ a" "0 < p^a * m" "p^a \<le> p^a * m"
    by (auto simp: prime_gt_0_nat)
  have *: "multiplicity p ((p^a * m - 1) choose (p^a - 1)) = 0"
    apply (rule p_not_div_choose [where K = "p^a"])
    using p exponent_p_a_m_k_equation by (auto simp: diff_le_mono prime)
  have "multiplicity p ((p ^ a * m choose p ^ a) * p ^ a) = a + multiplicity p m"
  proof -
    have "(p ^ a * m choose p ^ a) * p ^ a = p ^ a * m * (p ^ a * m - 1 choose (p ^ a - 1))"
      (is "_ = ?rhs") using prime
      by (subst times_binomial_minus1_eq [symmetric]) (auto simp: prime_gt_0_nat)
    also from p have "p ^ a - Suc 0 \<le> p ^ a * m - Suc 0" by linarith
    with prime * p have "multiplicity p ?rhs = multiplicity p (p ^ a * m)"
      by (subst prime_elem_multiplicity_mult_distrib) auto
    also have "\<dots> = a + multiplicity p m"
      using prime p by (subst prime_elem_multiplicity_mult_distrib) simp_all
    finally show ?thesis .
  qed
  then show ?thesis
    using prime p by (subst (asm) prime_elem_multiplicity_mult_distrib) simp_all
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_int_add_ident_left
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

definition(*fun*) zero :: "Integer" where
  "zero = P Z"

fun pred :: "Nat => Nat" where
  "pred (S y) = y"

fun plus2 :: "Nat => Nat => Nat" where
  "plus2 (Z) y = y"
| "plus2 (S z) y = S (plus2 z y)"

fun t2 :: "Nat => Nat => Integer" where
  "t2 x y =
   (let fail :: Integer =
     (case y of
        Z => P x
        | S z =>
            (case x of
               Z => N y
               | S x2 => t2 x2 z))
   in (case x of
         Z =>
           (case y of
              Z => P Z
              | S x4 => fail)
         | S x3 => fail))"

fun plus :: "Integer => Integer => Integer" where
  "plus (P m) (P n) = P (plus2 m n)"
| "plus (P m) (N o2) = t2 m (plus2 (S Z) o2)"
| "plus (N m2) (P n2) = t2 n2 (plus2 (S Z) m2)"
| "plus (N m2) (N n3) = N (plus2 (plus2 (S Z) m2) n3)"

theorem property0 :
  "(x = (plus zero x))"
  oops

end


theory PI_Code
  imports
    "../Policy_Iteration_Fin"
    "HOL-Library.Code_Target_Numeral"
    "Jordan_Normal_Form.Matrix_Impl"
    Code_Setup
begin
context MDP_Code begin

definition "policy_eval_code d =
  inverse_mat (1\<^sub>m states -
  l \<cdot>\<^sub>m (Matrix.mat states states (\<lambda>(s, s'). pmf (MDP_K (s, d_lookup' d s)) s'))) *\<^sub>v
  (vec states (\<lambda>i. MDP_r (i, d_lookup' d i)))"

lemma d_lookup'_eq_map_to_fun: "D_Map.invar d \<Longrightarrow> s \<in> D_Map.keys d \<Longrightarrow> d_lookup' d s = D_Map.map_to_fun d s"
  using D_Map.lookup_None_set_inorder
  by (auto simp: D_Map.map_to_fun_def d_lookup'_def split: option.splits)

lemma policy_eval_correct:
  assumes "D_Map.keys d = {0..<states}" "D_Map.invar d" "s < states"
  shows "policy_eval_code d $v s = MDP.\<nu>\<^sub>b (MDP.mk_stationary_det (D_Map.map_to_fun d)) s"
  unfolding policy_eval_code_def MDP.vec_\<nu>\<^sub>b''[OF assms(3)]
  using assms d_lookup'_eq_map_to_fun
  by (auto cong: vec_cong MDP.mat_cong)

definition "transition_vecs =
  Matrix.vec states (\<lambda>s. M.from_list (map (\<lambda>(a, _, ps). (a,
    Matrix.vec states (\<lambda>s'. \<Sum>x \<leftarrow> ps. if fst x = s' then snd x else 0))) (a_inorder (s_lookup mdp s))))"

lemma transition_vecs_correct:
  assumes "s < states" "a \<in> MDP_A s" "s' < states"
  shows "M.lookup' (transition_vecs $v s) a $v s' = pmf (MDP_K (s,a)) s'"
proof -
  have *: "Matrix.vec states (\<lambda>s'. \<Sum>x\<leftarrow>snd (a_lookup' (s_lookup mdp s) a). if fst x = s' then snd x else 0) $v s' = pmf (pmf_of_list (snd (a_lookup' (s_lookup mdp s) a))) s'"
    by (auto simp: pmf_pmf_of_list assms pmf_of_list_wf_mdp sum_list_map_filter')
  have **: "
  M.lookup' (M.from_list (map (\<lambda>(a, _, ps). (a, Matrix.vec states (\<lambda>s'. \<Sum>x\<leftarrow>ps. if fst x = s' then snd x else 0))) (a_inorder (s_lookup mdp s)))) a $v s' =
  pmf (pmf_of_list (snd (a_lookup' (s_lookup mdp s) a))) s'"
    unfolding *[symmetric]
    using a_map_entries_lookup[OF assms(1,2)] A_Map.distinct_inorder invar_s_lookup[OF assms(1)]
    by (subst M.lookup'_from_list_distinct) (force simp: comp_def case_prod_beta A_Map.entries_def[symmetric] intro!: imageI)+
  show ?thesis
    unfolding transition_vecs_def MDP_K_def
    using assms a_lookup_None_notin_A sa_lookup_eq(2) snd_sa_lookup'_eq
    by (auto split: option.splits simp: **)
qed

lemma policy_eval_code: "policy_eval_code d =
  the (mat_inverse ((1\<^sub>m states) -
  l \<cdot>\<^sub>m (Matrix.mat states states (\<lambda>(s, s'). pmf (MDP_K (s, d_lookup' d s)) s')))) *\<^sub>v
  (vec states (\<lambda>i. MDP_r (i, d_lookup' d i)))"
  unfolding policy_eval_code_def
  by (subst mat_inverse_eq_inverse_mat) (auto simp: MDP.invertible_\<nu>\<^sub>b_mat')

definition "one_st = 1\<^sub>m states"
definition "k_mat d = Matrix.mat states states (\<lambda>(s, y). pmf (MDP_K (s, d_lookup' d s)) y)"

definition "k_mat' d m = (
  Matrix.mat_of_row_fun states states (\<lambda>i. M.lookup' (m $v i) (d_lookup' d i)))"

lemma invertible_imp_inv_ex: "invertible_mat m \<Longrightarrow> \<exists>x\<in>carrier_mat (dim_row m) (dim_row m). x * m = 1\<^sub>m (dim_row m) \<and> m * x = 1\<^sub>m (dim_row m)"
  by (metis carrier_matD(1) inverse_mat_mult inverse_mats_def invertible_inverse_mats)

lemma policy_eval_code':
  fixes d
  defines "m \<equiv> (one_st - l \<cdot>\<^sub>m Matrix.mat states states (\<lambda>(s, y). pmf (MDP_K (s, d_lookup' d s)) y))"
  shows "policy_eval_code d = snd (gauss_jordan m (1\<^sub>m states)) *\<^sub>v (vec states (\<lambda>i. MDP_r (i, d_lookup' d i)))"
proof -
  have m: "m \<in> carrier_mat states states"
    using assms by fastforce
  hence "fst (gauss_jordan m (1\<^sub>m states)) = 1\<^sub>m states"
    using MDP.invertible_\<nu>\<^sub>b_mat'[of "d_lookup' d", unfolded m_def[symmetric] one_st_def[symmetric]]
    using m invertible_imp_inv_ex[of m]
    by (auto simp: ring_mat_simps Units_def intro!: gauss_jordan_inverse_other_direction[of _ _  states _ states])
  thus ?thesis
    unfolding policy_eval_code mat_inverse_def
    by (auto split: if_splits simp: one_st_def m_def case_prod_beta)
qed

lemma policy_eval_code''[code]:
  fixes d
  defines "m \<equiv> (one_st - l \<cdot>\<^sub>m ((k_mat d)))"
  shows "policy_eval_code d = snd (gauss_jordan m one_st) *\<^sub>v (vec states (\<lambda>i. MDP_r (i, d_lookup' d i)))"
  unfolding m_def policy_eval_code' k_mat_def one_st_def by (simp add: mat_code)

definition "policy_eval_code' d m = snd (gauss_jordan (one_st - l \<cdot>\<^sub>m ((k_mat' d m))) one_st) *\<^sub>v (vec states (\<lambda>i. MDP_r (i, d_lookup' d i)))"

lemma dim_policy_eval_code: "dim_vec (policy_eval_code d) = states"
  by (simp add: policy_eval_code_def MDP.invertible_\<nu>\<^sub>b_mat' inverse_mat_dims(2))

lemma policy_eval_correct':
  assumes "D_Map.keys d = {0..<states}" "D_Map.invar d"
  shows "vec_to_bfun (policy_eval_code d) = MDP.\<nu>\<^sub>b (MDP.mk_stationary_det (D_Map.map_to_fun d))"
  using policy_eval_correct assms dim_policy_eval_code MDP.\<nu>\<^sub>b_zero_notin
  by (auto simp: vec_to_bfun.rep_eq)

(* todo, just never go downwards when choosing new actions in case of draw *)
definition "pi_find_policy_state_code_aux' d v s = (
  let (d', v') = find_policy_state_code_aux' v s in
  if L\<^sub>a_code (a_lookup' (s_lookup mdp s) d) v = v' then d else d')"

definition "pi_find_policy_code d v =
 D_Map.from_list' (\<lambda>s. pi_find_policy_state_code_aux' (d_lookup' d s) v s) [0..<states]"

lemma vi_find_policy_code_invar: "D_Map.invar (pi_find_policy_code d v)"
  unfolding pi_find_policy_code_def by simp

lemma keys_vi_find_policy_code_aux_upt: "D_Map.keys (pi_find_policy_code d v) = {0..<states}"
  unfolding pi_find_policy_code_def by simp

lemma find_policy_state_code_aux'_in_acts:
  assumes "s < states" "v_len v = states" "v_invar v"
  shows "fst (find_policy_state_code_aux' v s) \<in> MDP_A s"
  using MDP.A_ne MDP.A_fin assms least_arg_max_prop[of "\<lambda>x. x \<in> MDP_A s"]
  by (fastforce simp: find_policy_state_code_aux'_eq')

lemma pi_find_policy_state_code_aux'_correct:
  assumes "s < states" "D_Map.invar d" "v_len v = states" "v_invar v" "D_Map.keys d = MDP.state_space" "d_lookup' d s \<in> MDP_A s"
  shows "pi_find_policy_state_code_aux' (d_lookup' d s) v s = MDP.policy_improvement (D_Map.map_to_fun d) (V_Map.map_to_bfun v) s"
proof (cases "is_arg_max (\<lambda>a. MDP.L\<^sub>a a (apply_bfun (V_Map.map_to_bfun v)) s) (\<lambda>a. a \<in> MDP_A s) (D_Map.map_to_fun d s)")
  case True
  hence aux: "L\<^sub>a_code (a_lookup' (s_lookup mdp s) (d_lookup' d s)) v = snd (find_policy_state_code_aux' v s)"
    using MDP.A_fin
    by (subst L_GS_code_correct') (fastforce intro!: Max_eqI[symmetric] simp: assms find_policy_state_code_aux'_eq' d_lookup'_eq_map_to_fun split: option.splits)+
  then show ?thesis
  proof -
    have "pi_find_policy_state_code_aux' (d_lookup' d s) v s = d_lookup' d s"
      unfolding pi_find_policy_state_code_aux'_def
      by (simp add: aux case_prod_unfold)
    thus ?thesis
      using True
      by (fastforce simp: assms MDP.policy_improvement_def d_lookup'_eq_map_to_fun  split: option.splits)
  qed
next
  case False
  hence "L\<^sub>a_code (a_lookup' (s_lookup mdp s) (d_lookup' d s)) v < (MAX a \<in> MDP_A s. MDP.L\<^sub>a a (apply_bfun (V_Map.map_to_bfun v)) s)"
    using False assms by (auto simp: L_GS_code_correct' is_arg_max_linorder not_le map_to_fun_lookup Max_gr_iff)
  thus ?thesis
    unfolding pi_find_policy_state_code_aux'_def MDP.policy_improvement_def
    using False
    by (auto simp: assms find_policy_state_code_aux'_eq' least_arg_max_def MDP.is_opt_act_def)
qed

lemma pi_find_policy_code_correct:
  assumes "v_len v = states" "D_Map.keys d = MDP.state_space" "v_invar v" "D_Map.invar d" "\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s"
  shows "D_Map.map_to_fun ((pi_find_policy_code d v)) s = MDP.policy_improvement (D_Map.map_to_fun d) (V_Map.map_to_bfun v) s"
  using assms
proof (cases "s < states")
  case True
  then show ?thesis
    unfolding pi_find_policy_code_def
    by (simp add: assms pi_find_policy_state_code_aux'_correct  D_Map.map_to_fun_def)
next
  case False
  then show ?thesis
    using keys_vi_find_policy_code_aux_upt assms vi_find_policy_code_invar is_arg_max_const MDP.A_outside
    by (auto intro!: Least_equality simp: map_to_fun_notin MDP.policy_improvement_def MDP.is_opt_act_def)
qed

definition "eq_policy d1 d2 = (\<forall>x<states. d_lookup d1 x = d_lookup d2 x)"
definition "policy_step_code d = (
let v = policy_eval_code d in
  pi_find_policy_code d (V_Map.arr_tabulate (($v) v) states))"

definition "policy_step_code' d m = (
let v = policy_eval_code' d m in
  pi_find_policy_code d (V_Map.arr_tabulate (($v) v) states))"

partial_function (tailrec) PI_code_aux' where
  "PI_code_aux' d m = (
  let d' = policy_step_code' d m in
    if eq_policy d d'
    then d
    else PI_code_aux' d' m)"

partial_function (tailrec) PI_code_aux where
  "PI_code_aux d = (
  let d' = policy_step_code d in
    if eq_policy d d'
    then d
    else PI_code_aux d')"

lemma fold_policy_eval_update_eq:
  assumes "s < states"  "D_Map.keys d = MDP.state_space" "D_Map.invar d"
  shows "v_lookup (V_Map.arr_tabulate (\<lambda>x. policy_eval_code d $v x) states) s = (MDP.policy_eval (D_Map.map_to_fun d) s)"
  using assms
  by (auto simp: v_lookup_fold policy_eval_correct MDP.policy_eval_def)

lemma fold_policy_eval_update_eq':
  assumes "D_Map.keys d = MDP.state_space" "D_Map.invar d"
  shows "V_Map.map_to_bfun (V_Map.arr_tabulate (\<lambda>x. (policy_eval_code d $v x)) states) =
  (MDP.policy_eval (D_Map.map_to_fun d))"
proof (rule bfun_eqI)
  fix s
  show "(V_Map.map_to_bfun (V_Map.arr_tabulate (($v) (policy_eval_code d)) states)) s =
  (MDP.policy_eval (D_Map.map_to_fun d)) s"
  proof (cases "s < states")
    case True
    then show ?thesis
      by (auto simp: V_Map.map_to_bfun.rep_eq assms policy_eval_correct MDP.policy_eval_def)
  next
    case False
    then show ?thesis
      by (auto simp: MDP.policy_eval_def V_Map.map_to_bfun.rep_eq MDP.\<nu>\<^sub>b_zero_notin)
  qed
qed

lemmas PI_code_aux.simps[code]
lemmas PI_code_aux'.simps[code]

lemmas MDP.policy_iteration.simps[simp del]

definition "is_dec_det_code d \<longleftrightarrow>
  D_Map.keys d = {0..<states} \<and> D_Map.invar d \<and> (\<forall>s \<in> set [0..<states]. a_lookup (s_lookup mdp s) (d_lookup' d s) \<noteq> None)"

definition "PI_code d0 = (if \<not> is_dec_det_code d0 then d0 else PI_code_aux d0)"

lemma k_mat_eq': "is_dec_det_code d \<Longrightarrow> k_mat d = k_mat' d transition_vecs"
  unfolding k_mat_def k_mat'_def Matrix.mat_eq_iff
  by (auto simp:  is_dec_det_code_def intro!: transition_vecs_correct[symmetric] intro: a_lookup_some_in_A)

lemma policy_eval_code_eq': "is_dec_det_code d \<Longrightarrow> policy_eval_code d = policy_eval_code' d transition_vecs"
  unfolding policy_eval_code'' policy_eval_code'_def
  using k_mat_eq'
  by force

lemma policy_step_code_eq': "is_dec_det_code d \<Longrightarrow> policy_step_code d = policy_step_code' d transition_vecs"
  unfolding policy_step_code_def policy_step_code'_def
  using policy_eval_code_eq' by presburger

lemma policy_step_code_correct:
  assumes "D_Map.keys d = MDP.state_space" "D_Map.invar d" "(\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s)"
  shows "D_Map.map_to_fun (policy_step_code d) = (MDP.policy_step (D_Map.map_to_fun d))"
  unfolding policy_step_code_def MDP.policy_step_def
  by (auto simp: fold_policy_eval_update_eq'  pi_find_policy_code_correct assms)

lemma PI_code_aux_correct_aux:
  assumes "D_Map.invar d" "D_Map.keys d = {0..<states}" "(\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s)"
  shows "D_Map.map_to_fun (PI_code_aux d) = MDP.policy_iteration (D_Map.map_to_fun d)
    \<and> (is_dec_det_code d \<longrightarrow> PI_code_aux d = PI_code_aux' d transition_vecs)"
  using assms
proof (induction "(D_Map.map_to_fun d)" arbitrary: d rule: MDP.policy_iteration.induct)
  case 1
  show ?case
  proof (cases "eq_policy d (policy_step_code d)")
    case True
    hence *: "D_Map.map_to_fun d s = (MDP.policy_step (D_Map.map_to_fun d)) s" for s
    proof (cases "s < states")
      case True
      then show ?thesis
        using True vi_find_policy_code_invar 1 \<open>eq_policy d (policy_step_code d)\<close>
        by (auto simp: D_Map.map_to_fun_def eq_policy_def policy_step_code_correct[symmetric] policy_step_code_def)
    next
      case False
      hence "MDP.policy_step (D_Map.map_to_fun d) s = 0"
        by (auto simp: 1 MDP.policy_improvement_def is_arg_max_linorder MDP.policy_step_def MDP_A_def map_to_fun_notin)
      then show ?thesis
        using 1 D_Map.lookup_some_set_key False
        by (auto simp: D_Map.map_to_fun_def split: option.splits)
    qed
    have "D_Map.map_to_fun (PI_code_aux d) = D_Map.map_to_fun d"
      by (simp add: PI_code_aux.simps policy_step_code_correct True)
    thus ?thesis
      using * MDP.policy_iteration.simps[of "D_Map.map_to_fun d"] True
      by (fastforce simp: policy_step_code_eq' PI_code_aux'.simps[of d] PI_code_aux.simps[of d])
  next
    case False
    then obtain s where s: "s < states" "d_lookup d s \<noteq> d_lookup (policy_step_code d) s"
      unfolding eq_policy_def policy_step_code_def
      using 1(2,3) D_Map.lookup_notin_keys keys_vi_find_policy_code_aux_upt vi_find_policy_code_invar
      by (auto simp: d_lookup'_def)
    have invar_step: "D_Map.invar (policy_step_code d)"
      by (simp add: policy_step_code_def vi_find_policy_code_invar)
    have keys_step: "D_Map.keys (policy_step_code d) = D_Map.keys d"
      by (simp add: 1 keys_vi_find_policy_code_aux_upt policy_step_code_def)
    have *: "D_Map.map_to_fun d s \<noteq> (MDP.policy_step (D_Map.map_to_fun d)) s"
      using D_Map.lookup_in_keys[OF invar_step] D_Map.lookup_notin_keys[OF invar_step] s(2) keys_step invar_step 1(2-4)
      by (fastforce dest: D_Map.lookup_None_set_inorder[OF \<open>D_Map.invar d\<close>] D_Map.lookup_some_set_key[OF \<open>D_Map.invar d\<close>]
          split: option.splits simp: policy_step_code_correct[symmetric] D_Map.map_to_fun_def)
    have **: "MDP.is_dec_det (D_Map.map_to_fun d)"
      using 1 by (auto simp: MDP.is_dec_det_def MDP_A_def map_to_fun_lookup map_to_fun_notin)
    have lookup': "s < states \<Longrightarrow> d_lookup' (policy_step_code d) s \<in> MDP_A s" for s
      using 1(2-4) keys_step invar_step MDP.is_dec_det_pi
      by (force simp: MDP.is_dec_det_def policy_step_code_correct d_lookup'_eq_map_to_fun MDP.policy_step_def)
    have "D_Map.map_to_fun (PI_code_aux d) = D_Map.map_to_fun (PI_code_aux (policy_step_code d))"
      by (simp add: PI_code_aux.simps policy_step_code_correct False)
    also have "\<dots> = MDP.policy_iteration (D_Map.map_to_fun (policy_step_code d))"
      using 1(2-4) * ** policy_step_code_correct lookup' invar_step keys_step
      by (intro conjunct1[OF 1(1)]) (auto )
    also have "\<dots> = MDP.policy_iteration (MDP.policy_step (D_Map.map_to_fun d))"
      using 1 by (auto simp: policy_step_code_correct)
    finally have aux: "D_Map.map_to_fun (PI_code_aux d) = MDP.policy_iteration (D_Map.map_to_fun d)"
      unfolding  PI_code_aux.simps[of d] PI_code_aux'.simps[of d]
      using ** by (auto simp:  MDP.policy_iteration.simps)
    thus ?thesis
    proof -
      have d: "is_dec_det_code d"
        unfolding is_dec_det_code_def
        using 1 a_lookup_None_notin_A
        by (metis atLeastLessThan_iff set_upt)
      hence "is_dec_det_code (policy_step_code d)"
        by (metis a_lookup_None_notin_A atLeastLessThan_iff invar_step is_dec_det_code_def keys_step lookup' set_upt)
      hence "PI_code_aux (policy_step_code d) = PI_code_aux' (policy_step_code d) transition_vecs"
        using * ** 1 invar_step keys_step lookup' policy_step_code_correct by metis
      hence "PI_code_aux d = PI_code_aux' d transition_vecs"
        unfolding  PI_code_aux.simps[of d] PI_code_aux'.simps[of d]
        using policy_step_code_eq'[OF d]
        by auto
      thus ?thesis
        using ** aux
        by fastforce
    qed
  qed
qed

lemma PI_code_correct:
  assumes "D_Map.invar d" "D_Map.keys d = MDP.state_space" "(\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s)"
  shows "D_Map.map_to_fun (PI_code d) = MDP.policy_iteration (D_Map.map_to_fun d)"
proof -
  have "is_dec_det_code d"
    unfolding is_dec_det_code_def
    using a_lookup_None_notin_A assms
    by (fastforce simp: not_Some_eq[symmetric])
  thus ?thesis
    using assms
    by (auto simp: PI_code_def conjunct1[OF PI_code_aux_correct_aux])
qed

lemma [code]: "PI_code d0 = (if \<not> is_dec_det_code d0 then d0 else PI_code_aux' d0 transition_vecs)"
  using conjunct2[OF PI_code_aux_correct_aux[of d0]]
  unfolding PI_code_def is_dec_det_code_def
  using a_lookup_some_in_A
  by force

definition "d0 = D_Map.from_list' (\<lambda>s. fst (hd (a_inorder (s_lookup mdp s)))) [0..<states]"

end

lemma inorder_empty: "Tree2.inorder am = [] \<Longrightarrow> am = \<langle>\<rangle>"
  using Tree2.inorder.elims by blast

global_interpretation PI_Code: MDP_Code
(* state map (transition system) *)
"IArray.sub" "\<lambda>n x arr. IArray ((IArray.list_of arr)[n:= x])" "IArray.length" "IArray" "IArray.list_of" "\<lambda>_. True"

(* action map *)
RBT_Set.empty RBT_Map.update RBT_Map.delete Lookup2.lookup Tree2.inorder rbt

"MDP.transitions (Rep_Valid_MDP mdp)" "MDP.states (Rep_Valid_MDP mdp)"

(* value map *)
starray_get "\<lambda>i x arr. starray_set arr i x" starray_length starray_of_list "\<lambda>arr. starray_foldr (\<lambda>x xs. x # xs) arr []" "\<lambda>_. True"

(* decision rule map *)
RBT_Set.empty RBT_Map.update RBT_Map.delete Lookup2.lookup Tree2.inorder rbt

"MDP.disc (Rep_Valid_MDP mdp)"
for mdp
defines PI_code = PI_Code.PI_code
  and PI_code_aux = PI_Code.PI_code_aux
  and L\<^sub>a_code = PI_Code.L\<^sub>a_code
  and a_lookup' = PI_Code.a_lookup'
  and d_lookup' = PI_Code.d_lookup'
  and find_policy_state_code_aux' = PI_Code.find_policy_state_code_aux'
  and find_policy_state_code_aux = PI_Code.find_policy_state_code_aux
  and entries = M.entries
  and from_list' = M.from_list'
  and pi_find_policy_code = PI_Code.pi_find_policy_code
  and pi_find_policy_state_code_aux' = PI_Code.pi_find_policy_state_code_aux'
  and policy_eval_code = PI_Code.policy_eval_code
  and is_dec_det_code = PI_Code.is_dec_det_code
  and policy_step_code = PI_Code.policy_step_code
  and eq_policy = PI_Code.eq_policy
  and MDP_r = PI_Code.MDP_r
  and MDP_K = PI_Code.MDP_K
  and d0 = PI_Code.d0
  and k_mat = PI_Code.k_mat
  and one_st = PI_Code.one_st
  and arr_tabulate = starray_Array.arr_tabulate
  and transition_vecs = PI_Code.transition_vecs
  and M_from_list = M.from_list
  and M_lookup' = M.lookup'
  and M_keys = M.keys
  and M_invar = M.invar

and PI_code_aux' = PI_Code.PI_code_aux'
and policy_step_code' = PI_Code.policy_step_code'
and policy_eval_code' = PI_Code.policy_eval_code'
and k_mat' = PI_Code.k_mat'

  using Rep_Valid_MDP is_MDP_def
  by unfold_locales
    (fastforce simp: Ball_set_list_all[symmetric] case_prod_beta pmf_of_list_wf_def is_MDP_def M.invar_def empty_def M.entries_def M.is_empty_def length_0_conv[symmetric])+

lemmas arr_tabulate_def[unfolded starray_Array.arr_tabulate_def, code]
lemmas entries_def[unfolded M.entries_def, code]
lemmas from_list'_def[unfolded M.from_list'_def, code]

lemmas M_from_list_def[unfolded M.from_list_def, code]
lemmas M_lookup'_def[unfolded M.lookup'_def, code]
lemmas M_keys_def[unfolded M.keys_def, code]
lemmas M_invar_def[unfolded M.invar_def, code]

lift_definition mat_of_row_fun_code :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a vec_impl) \<Rightarrow> 'a mat_impl" is
  "\<lambda> nr nc f. (nr, nc,
  let m = IArray.of_fun (\<lambda> i. snd (Rep_vec_impl (f i))) nr in
    if \<forall>i<nr. IArray.length (IArray.sub m i) = nc
    then m else Code.abort (STR ''set_fold_cfc RBT_set: ccompare = None'')
    (\<lambda>_. IArray.of_fun (\<lambda> i. IArray.of_fun (\<lambda> j. vec_index_impl (f i) j) nc) nr))
  " by auto

lift_definition vec_to_vec_impl :: "'a vec \<Rightarrow> 'a vec_impl" is
  "\<lambda>v. vec_of_fun (dim_vec v) (($) v)".

lemma vec_impl_eqI: "snd (Rep_vec_impl v) = snd (Rep_vec_impl u) \<Longrightarrow> fst (Rep_vec_impl v) = fst (Rep_vec_impl u) \<Longrightarrow> v = u"
  by (meson Rep_vec_impl_inject prod_eq_iff)

lemma vec_impl_exhaust: "(\<And>v. P (Abs_vec_impl (IArray.length v, v))) \<Longrightarrow> P u"
  by (auto intro: Abs_vec_impl_induct)

lemma vec_to_vec_impl_code[code]: "vec_to_vec_impl (vec_impl v) = v"
proof -
  have "vec_to_vec_impl (vec_impl (Abs_vec_impl (length v, IArray v))) = Abs_vec_impl (length v, IArray v)" for v
  proof -
    have "vec_to_vec_impl (vec_impl (Abs_vec_impl (length v, IArray v))) = vec_of_fun (length v) (($v) (vec_impl (Abs_vec_impl (length v, IArray v))))"
      unfolding vec_to_vec_impl.abs_eq
      by (metis dim_vec_of_list vec_of_list vec_of_list_impl.abs_eq)
    also have "\<dots> = Abs_vec_impl (length v, IArray (map (($v) (Abs_vec (length v, Matrix.mk_vec (length v) ((!!) (IArray v))))) [0..<length v]))"
      by (subst vec_impl.abs_eq) (auto simp: eq_onp_same_args vec_of_fun_def )
    also have "\<dots> = Abs_vec_impl (length v, IArray (map (Matrix.mk_vec (length v) ((!!) (IArray v))) [0..<length v]))"
      by (subst vec_index.abs_eq) (auto simp: eq_onp_same_args)
    also have "\<dots> = Abs_vec_impl (length v, IArray (map (((!!) (IArray v))) [0..<length v]))"
      by (metis IArray.sub_def Matrix.mk_vec_def list_of.simps undef_vec)
    also have "\<dots> = Abs_vec_impl (length v, IArray v)"
      by (simp add: list.map_cong map_nth)
    finally show ?thesis.
  qed
  hence "vec_to_vec_impl (vec_impl (Abs_vec_impl (IArray.length v, v))) = Abs_vec_impl (IArray.length v, v)" for v
    unfolding IArray.length_def using list_of.simps iarray.exhaust by metis
  thus ?thesis
    by (rule vec_impl_exhaust)
qed

lemma dim_row_mat_of_row_fun_code[simp]: "dim_row (mat_impl (mat_of_row_fun_code nr nc f)) = nr"
  by (simp add: dim_row_code dim_row_impl.abs_eq eq_onp_same_args mat_of_row_fun_code.abs_eq)

lemma dim_col_mat_of_row_fun_code[simp]: "dim_col (mat_impl (mat_of_row_fun_code nr nc f)) = nc"
  by (simp add: dim_col_code dim_col_impl.abs_eq eq_onp_same_args mat_of_row_fun_code.abs_eq)

lemma mat_of_row_fun_code[code]: "mat_of_row_fun nr nc f =
  mat_impl (mat_of_row_fun_code nr nc (\<lambda>i. vec_to_vec_impl (f i)))"
proof -
  have "index_mat_impl (mat_of_row_fun_code nr nc (\<lambda>i. vec_to_vec_impl (f i))) (i, j) = f i $v j" if "i < nr" "j < nc" for i j
  proof (cases "\<forall>i<nr. length (IArray.list_of (snd (Rep_vec_impl (vec_to_vec_impl (f i))))) = nc")
    case True
    then show ?thesis
      using that
      unfolding mat_of_row_fun_code.abs_eq vec_to_vec_impl.rep_eq
      by (auto simp: index_mat_impl.abs_eq eq_onp_same_args vec_of_fun.rep_eq)
  next
    case False
    then show ?thesis
      using that
      unfolding mat_of_row_fun_code.abs_eq vec_to_vec_impl.rep_eq
      using list_of_vec_index[of "f i" j] list_of_vec_map[of "f i"]
      by (auto simp: index_mat_impl.abs_eq eq_onp_same_args vec_of_fun.rep_eq vec_index_impl.rep_eq)
  qed
  thus ?thesis
    by (auto simp: index_mat_code)
qed
end