(*  Title:      HOL/Probability/Fin_Map.thy
    Author:     Fabian Immler, TU München
*)

section {* Finite Maps *}

theory Fin_Map
imports Finite_Product_Measure
begin

text {* Auxiliary type that is instantiated to @{class polish_space}, needed for the proof of
  projective limit. @{const extensional} functions are used for the representation in order to
  stay close to the developments of (finite) products @{const Pi\<^sub>E} and their sigma-algebra
  @{const Pi\<^sub>M}. *}

typedef ('i, 'a) finmap ("(_ \<Rightarrow>\<^sub>F /_)" [22, 21] 21) =
  "{(I::'i set, f::'i \<Rightarrow> 'a). finite I \<and> f \<in> extensional I}" by auto

subsection {* Domain and Application *}

definition domain where "domain P = fst (Rep_finmap P)"

lemma finite_domain[simp, intro]: "finite (domain P)"
  by (cases P) (auto simp: domain_def Abs_finmap_inverse)

definition proj ("'((_)')\<^sub>F" [0] 1000) where "proj P i = snd (Rep_finmap P) i"

declare [[coercion proj]]

lemma extensional_proj[simp, intro]: "(P)\<^sub>F \<in> extensional (domain P)"
  by (cases P) (auto simp: domain_def Abs_finmap_inverse proj_def[abs_def])

lemma proj_undefined[simp, intro]: "i \<notin> domain P \<Longrightarrow> P i = undefined"
  using extensional_proj[of P] unfolding extensional_def by auto

lemma finmap_eq_iff: "P = Q \<longleftrightarrow> (domain P = domain Q \<and> (\<forall>i\<in>domain P. P i = Q i))"
  by (cases P, cases Q)
     (auto simp add: Abs_finmap_inject extensional_def domain_def proj_def Abs_finmap_inverse
              intro: extensionalityI)

subsection {* Countable Finite Maps *}

instance finmap :: (countable, countable) countable
proof
  obtain mapper where mapper: "\<And>fm :: 'a \<Rightarrow>\<^sub>F 'b. set (mapper fm) = domain fm"
    by (metis finite_list[OF finite_domain])
  have "inj (\<lambda>fm. map (\<lambda>i. (i, (fm)\<^sub>F i)) (mapper fm))" (is "inj ?F")
  proof (rule inj_onI)
    fix f1 f2 assume "?F f1 = ?F f2"
    then have "map fst (?F f1) = map fst (?F f2)" by simp
    then have "mapper f1 = mapper f2" by (simp add: comp_def)
    then have "domain f1 = domain f2" by (simp add: mapper[symmetric])
    with `?F f1 = ?F f2` show "f1 = f2"
      unfolding `mapper f1 = mapper f2` map_eq_conv mapper
      by (simp add: finmap_eq_iff)
  qed
  then show "\<exists>to_nat :: 'a \<Rightarrow>\<^sub>F 'b \<Rightarrow> nat. inj to_nat"
    by (intro exI[of _ "to_nat \<circ> ?F"] inj_comp) auto
qed

subsection {* Constructor of Finite Maps *}

definition "finmap_of inds f = Abs_finmap (inds, restrict f inds)"

lemma proj_finmap_of[simp]:
  assumes "finite inds"
  shows "(finmap_of inds f)\<^sub>F = restrict f inds"
  using assms
  by (auto simp: Abs_finmap_inverse finmap_of_def proj_def)

lemma domain_finmap_of[simp]:
  assumes "finite inds"
  shows "domain (finmap_of inds f) = inds"
  using assms
  by (auto simp: Abs_finmap_inverse finmap_of_def domain_def)

lemma finmap_of_eq_iff[simp]:
  assumes "finite i" "finite j"
  shows "finmap_of i m = finmap_of j n \<longleftrightarrow> i = j \<and> (\<forall>k\<in>i. m k= n k)"
  using assms by (auto simp: finmap_eq_iff)

lemma finmap_of_inj_on_extensional_finite:
  assumes "finite K"
  assumes "S \<subseteq> extensional K"
  shows "inj_on (finmap_of K) S"
proof (rule inj_onI)
  fix x y::"'a \<Rightarrow> 'b"
  assume "finmap_of K x = finmap_of K y"
  hence "(finmap_of K x)\<^sub>F = (finmap_of K y)\<^sub>F" by simp
  moreover
  assume "x \<in> S" "y \<in> S" hence "x \<in> extensional K" "y \<in> extensional K" using assms by auto
  ultimately
  show "x = y" using assms by (simp add: extensional_restrict)
qed

subsection {* Product set of Finite Maps *}

text {* This is @{term Pi} for Finite Maps, most of this is copied *}

definition Pi' :: "'i set \<Rightarrow> ('i \<Rightarrow> 'a set) \<Rightarrow> ('i \<Rightarrow>\<^sub>F 'a) set" where
  "Pi' I A = { P. domain P = I \<and> (\<forall>i. i \<in> I \<longrightarrow> (P)\<^sub>F i \<in> A i) } "

syntax
  "_Pi'"  :: "[pttrn, 'a set, 'b set] => ('a => 'b) set"  ("(3PI' _:_./ _)" 10)

syntax (xsymbols)
  "_Pi'" :: "[pttrn, 'a set, 'b set] => ('a => 'b) set"  ("(3\<Pi>' _\<in>_./ _)"   10)

syntax (HTML output)
  "_Pi'" :: "[pttrn, 'a set, 'b set] => ('a => 'b) set"  ("(3\<Pi>' _\<in>_./ _)"   10)

translations
  "PI' x:A. B" == "CONST Pi' A (%x. B)"

subsubsection{*Basic Properties of @{term Pi'}*}

lemma Pi'_I[intro!]: "domain f = A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<in> B x) \<Longrightarrow> f \<in> Pi' A B"
  by (simp add: Pi'_def)

lemma Pi'_I'[simp]: "domain f = A \<Longrightarrow> (\<And>x. x \<in> A \<longrightarrow> f x \<in> B x) \<Longrightarrow> f \<in> Pi' A B"
  by (simp add:Pi'_def)

lemma Pi'_mem: "f\<in> Pi' A B \<Longrightarrow> x \<in> A \<Longrightarrow> f x \<in> B x"
  by (simp add: Pi'_def)

lemma Pi'_iff: "f \<in> Pi' I X \<longleftrightarrow> domain f = I \<and> (\<forall>i\<in>I. f i \<in> X i)"
  unfolding Pi'_def by auto

lemma Pi'E [elim]:
  "f \<in> Pi' A B \<Longrightarrow> (f x \<in> B x \<Longrightarrow> domain f = A \<Longrightarrow> Q) \<Longrightarrow> (x \<notin> A \<Longrightarrow> Q) \<Longrightarrow> Q"
  by(auto simp: Pi'_def)

lemma in_Pi'_cong:
  "domain f = domain g \<Longrightarrow> (\<And> w. w \<in> A \<Longrightarrow> f w = g w) \<Longrightarrow> f \<in> Pi' A B \<longleftrightarrow> g \<in> Pi' A B"
  by (auto simp: Pi'_def)

lemma Pi'_eq_empty[simp]:
  assumes "finite A" shows "(Pi' A B) = {} \<longleftrightarrow> (\<exists>x\<in>A. B x = {})"
  using assms
  apply (simp add: Pi'_def, auto)
  apply (drule_tac x = "finmap_of A (\<lambda>u. SOME y. y \<in> B u)" in spec, auto)
  apply (cut_tac P= "%y. y \<in> B i" in some_eq_ex, auto)
  done

lemma Pi'_mono: "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C x) \<Longrightarrow> Pi' A B \<subseteq> Pi' A C"
  by (auto simp: Pi'_def)

lemma Pi_Pi': "finite A \<Longrightarrow> (Pi\<^sub>E A B) = proj ` Pi' A B"
  apply (auto simp: Pi'_def Pi_def extensional_def)
  apply (rule_tac x = "finmap_of A (restrict x A)" in image_eqI)
  apply auto
  done

subsection {* Topological Space of Finite Maps *}

instantiation finmap :: (type, topological_space) topological_space
begin

definition open_finmap :: "('a \<Rightarrow>\<^sub>F 'b) set \<Rightarrow> bool" where
  "open_finmap = generate_topology {Pi' a b|a b. \<forall>i\<in>a. open (b i)}"

lemma open_Pi'I: "(\<And>i. i \<in> I \<Longrightarrow> open (A i)) \<Longrightarrow> open (Pi' I A)"
  by (auto intro: generate_topology.Basis simp: open_finmap_def)

instance using topological_space_generate_topology
  by intro_classes (auto simp: open_finmap_def class.topological_space_def)

end

lemma open_restricted_space:
  shows "open {m. P (domain m)}"
proof -
  have "{m. P (domain m)} = (\<Union>i \<in> Collect P. {m. domain m = i})" by auto
  also have "open \<dots>"
  proof (rule, safe, cases)
    fix i::"'a set"
    assume "finite i"
    hence "{m. domain m = i} = Pi' i (\<lambda>_. UNIV)" by (auto simp: Pi'_def)
    also have "open \<dots>" by (auto intro: open_Pi'I simp: `finite i`)
    finally show "open {m. domain m = i}" .
  next
    fix i::"'a set"
    assume "\<not> finite i" hence "{m. domain m = i} = {}" by auto
    also have "open \<dots>" by simp
    finally show "open {m. domain m = i}" .
  qed
  finally show ?thesis .
qed

lemma closed_restricted_space:
  shows "closed {m. P (domain m)}"
  using open_restricted_space[of "\<lambda>x. \<not> P x"]
  unfolding closed_def by (rule back_subst) auto

lemma tendsto_proj: "((\<lambda>x. x) ---> a) F \<Longrightarrow> ((\<lambda>x. (x)\<^sub>F i) ---> (a)\<^sub>F i) F"
  unfolding tendsto_def
proof safe
  fix S::"'b set"
  let ?S = "Pi' (domain a) (\<lambda>x. if x = i then S else UNIV)"
  assume "open S" hence "open ?S" by (auto intro!: open_Pi'I)
  moreover assume "\<forall>S. open S \<longrightarrow> a \<in> S \<longrightarrow> eventually (\<lambda>x. x \<in> S) F" "a i \<in> S"
  ultimately have "eventually (\<lambda>x. x \<in> ?S) F" by auto
  thus "eventually (\<lambda>x. (x)\<^sub>F i \<in> S) F"
    by eventually_elim (insert `a i \<in> S`, force simp: Pi'_iff split: split_if_asm)
qed

lemma continuous_proj:
  shows "continuous_on s (\<lambda>x. (x)\<^sub>F i)"
  unfolding continuous_on_def by (safe intro!: tendsto_proj tendsto_ident_at)

instance finmap :: (type, first_countable_topology) first_countable_topology
proof
  fix x::"'a\<Rightarrow>\<^sub>F'b"
  have "\<forall>i. \<exists>A. countable A \<and> (\<forall>a\<in>A. x i \<in> a) \<and> (\<forall>a\<in>A. open a) \<and>
    (\<forall>S. open S \<and> x i \<in> S \<longrightarrow> (\<exists>a\<in>A. a \<subseteq> S)) \<and> (\<forall>a b. a \<in> A \<longrightarrow> b \<in> A \<longrightarrow> a \<inter> b \<in> A)" (is "\<forall>i. ?th i")
  proof
    fix i from first_countable_basis_Int_stableE[of "x i"] guess A .
    thus "?th i" by (intro exI[where x=A]) simp
  qed
  then guess A unfolding choice_iff .. note A = this
  hence open_sub: "\<And>i S. i\<in>domain x \<Longrightarrow> open (S i) \<Longrightarrow> x i\<in>(S i) \<Longrightarrow> (\<exists>a\<in>A i. a\<subseteq>(S i))" by auto
  have A_notempty: "\<And>i. i \<in> domain x \<Longrightarrow> A i \<noteq> {}" using open_sub[of _ "\<lambda>_. UNIV"] by auto
  let ?A = "(\<lambda>f. Pi' (domain x) f) ` (Pi\<^sub>E (domain x) A)"
  show "\<exists>A::nat \<Rightarrow> ('a\<Rightarrow>\<^sub>F'b) set. (\<forall>i. x \<in> (A i) \<and> open (A i)) \<and> (\<forall>S. open S \<and> x \<in> S \<longrightarrow> (\<exists>i. A i \<subseteq> S))"
  proof (rule first_countableI[where A="?A"], safe)
    show "countable ?A" using A by (simp add: countable_PiE)
  next
    fix S::"('a \<Rightarrow>\<^sub>F 'b) set" assume "open S" "x \<in> S"
    thus "\<exists>a\<in>?A. a \<subseteq> S" unfolding open_finmap_def
    proof (induct rule: generate_topology.induct)
      case UNIV thus ?case by (auto simp add: ex_in_conv PiE_eq_empty_iff A_notempty)
    next
      case (Int a b)
      then obtain f g where
        "f \<in> Pi\<^sub>E (domain x) A" "Pi' (domain x) f \<subseteq> a" "g \<in> Pi\<^sub>E (domain x) A" "Pi' (domain x) g \<subseteq> b"
        by auto
      thus ?case using A
        by (auto simp: Pi'_iff PiE_iff extensional_def Int_stable_def
            intro!: bexI[where x="\<lambda>i. f i \<inter> g i"])
    next
      case (UN B)
      then obtain b where "x \<in> b" "b \<in> B" by auto
      hence "\<exists>a\<in>?A. a \<subseteq> b" using UN by simp
      thus ?case using `b \<in> B` by blast
    next
      case (Basis s)
      then obtain a b where xs: "x\<in> Pi' a b" "s = Pi' a b" "\<And>i. i\<in>a \<Longrightarrow> open (b i)" by auto
      have "\<forall>i. \<exists>a. (i \<in> domain x \<and> open (b i) \<and> (x)\<^sub>F i \<in> b i) \<longrightarrow> (a\<in>A i \<and> a \<subseteq> b i)"
        using open_sub[of _ b] by auto
      then obtain b'
        where "\<And>i. i \<in> domain x \<Longrightarrow> open (b i) \<Longrightarrow> (x)\<^sub>F i \<in> b i \<Longrightarrow> (b' i \<in>A i \<and> b' i \<subseteq> b i)"
          unfolding choice_iff by auto
      with xs have "\<And>i. i \<in> a \<Longrightarrow> (b' i \<in>A i \<and> b' i \<subseteq> b i)" "Pi' a b' \<subseteq> Pi' a b"
        by (auto simp: Pi'_iff intro!: Pi'_mono)
      thus ?case using xs
        by (intro bexI[where x="Pi' a b'"])
          (auto simp: Pi'_iff intro!: image_eqI[where x="restrict b' (domain x)"])
    qed
  qed (insert A,auto simp: PiE_iff intro!: open_Pi'I)
qed

subsection {* Metric Space of Finite Maps *}

instantiation finmap :: (type, metric_space) metric_space
begin

definition dist_finmap where
  "dist P Q = Max (range (\<lambda>i. dist ((P)\<^sub>F i) ((Q)\<^sub>F i))) + (if domain P = domain Q then 0 else 1)"

lemma finite_proj_image': "x \<notin> domain P \<Longrightarrow> finite ((P)\<^sub>F ` S)"
  by (rule finite_subset[of _ "proj P ` (domain P \<inter> S \<union> {x})"]) auto

lemma finite_proj_image: "finite ((P)\<^sub>F ` S)"
 by (cases "\<exists>x. x \<notin> domain P") (auto intro: finite_proj_image' finite_subset[where B="domain P"])

lemma finite_proj_diag: "finite ((\<lambda>i. d ((P)\<^sub>F i) ((Q)\<^sub>F i)) ` S)"
proof -
  have "(\<lambda>i. d ((P)\<^sub>F i) ((Q)\<^sub>F i)) ` S = (\<lambda>(i, j). d i j) ` ((\<lambda>i. ((P)\<^sub>F i, (Q)\<^sub>F i)) ` S)" by auto
  moreover have "((\<lambda>i. ((P)\<^sub>F i, (Q)\<^sub>F i)) ` S) \<subseteq> (\<lambda>i. (P)\<^sub>F i) ` S \<times> (\<lambda>i. (Q)\<^sub>F i) ` S" by auto
  moreover have "finite \<dots>" using finite_proj_image[of P S] finite_proj_image[of Q S]
    by (intro finite_cartesian_product) simp_all
  ultimately show ?thesis by (simp add: finite_subset)
qed

lemma dist_le_1_imp_domain_eq:
  shows "dist P Q < 1 \<Longrightarrow> domain P = domain Q"
  by (simp add: dist_finmap_def finite_proj_diag split: split_if_asm)

lemma dist_proj:
  shows "dist ((x)\<^sub>F i) ((y)\<^sub>F i) \<le> dist x y"
proof -
  have "dist (x i) (y i) \<le> Max (range (\<lambda>i. dist (x i) (y i)))"
    by (simp add: Max_ge_iff finite_proj_diag)
  also have "\<dots> \<le> dist x y" by (simp add: dist_finmap_def)
  finally show ?thesis .
qed

lemma dist_finmap_lessI:
  assumes "domain P = domain Q"
  assumes "0 < e"
  assumes "\<And>i. i \<in> domain P \<Longrightarrow> dist (P i) (Q i) < e"
  shows "dist P Q < e"
proof -
  have "dist P Q = Max (range (\<lambda>i. dist (P i) (Q i)))"
    using assms by (simp add: dist_finmap_def finite_proj_diag)
  also have "\<dots> < e"
  proof (subst Max_less_iff, safe)
    fix i
    show "dist ((P)\<^sub>F i) ((Q)\<^sub>F i) < e" using assms
      by (cases "i \<in> domain P") simp_all
  qed (simp add: finite_proj_diag)
  finally show ?thesis .
qed

instance
proof
  fix S::"('a \<Rightarrow>\<^sub>F 'b) set"
  show "open S = (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)" (is "_ = ?od")
  proof
    assume "open S"
    thus ?od
      unfolding open_finmap_def
    proof (induct rule: generate_topology.induct)
      case UNIV thus ?case by (auto intro: zero_less_one)
    next
      case (Int a b)
      show ?case
      proof safe
        fix x assume x: "x \<in> a" "x \<in> b"
        with Int x obtain e1 e2 where
          "e1>0" "\<forall>y. dist y x < e1 \<longrightarrow> y \<in> a" "e2>0" "\<forall>y. dist y x < e2 \<longrightarrow> y \<in> b" by force
        thus "\<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> a \<inter> b"
          by (auto intro!: exI[where x="min e1 e2"])
      qed
    next
      case (UN K)
      show ?case
      proof safe
        fix x X assume "x \<in> X" and X: "X \<in> K"
        with UN obtain e where "e>0" "\<And>y. dist y x < e \<longrightarrow> y \<in> X" by force
        with X show "\<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> \<Union>K" by auto
      qed
    next
      case (Basis s) then obtain a b where s: "s = Pi' a b" and b: "\<And>i. i\<in>a \<Longrightarrow> open (b i)" by auto
      show ?case
      proof safe
        fix x assume "x \<in> s"
        hence [simp]: "finite a" and a_dom: "a = domain x" using s by (auto simp: Pi'_iff)
        obtain es where es: "\<forall>i \<in> a. es i > 0 \<and> (\<forall>y. dist y (proj x i) < es i \<longrightarrow> y \<in> b i)"
          using b `x \<in> s` by atomize_elim (intro bchoice, auto simp: open_dist s)
        hence in_b: "\<And>i y. i \<in> a \<Longrightarrow> dist y (proj x i) < es i \<Longrightarrow> y \<in> b i" by auto
        show "\<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> s"
        proof (cases, rule, safe)
          assume "a \<noteq> {}"
          show "0 < min 1 (Min (es ` a))" using es by (auto simp: `a \<noteq> {}`)
          fix y assume d: "dist y x < min 1 (Min (es ` a))"
          show "y \<in> s" unfolding s
          proof
            show "domain y = a" using d s `a \<noteq> {}` by (auto simp: dist_le_1_imp_domain_eq a_dom)
            fix i assume i: "i \<in> a"
            hence "dist ((y)\<^sub>F i) ((x)\<^sub>F i) < es i" using d
              by (auto simp: dist_finmap_def `a \<noteq> {}` intro!: le_less_trans[OF dist_proj])
            with i show "y i \<in> b i" by (rule in_b)
          qed
        next
          assume "\<not>a \<noteq> {}"
          thus "\<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> s"
            using s `x \<in> s` by (auto simp: Pi'_def dist_le_1_imp_domain_eq intro!: exI[where x=1])
        qed
      qed
    qed
  next
    assume "\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S"
    then obtain e where e_pos: "\<And>x. x \<in> S \<Longrightarrow> e x > 0" and
      e_in:  "\<And>x y . x \<in> S \<Longrightarrow> dist y x < e x \<Longrightarrow> y \<in> S"
      unfolding bchoice_iff
      by auto
    have S_eq: "S = \<Union>{Pi' a b| a b. \<exists>x\<in>S. domain x = a \<and> b = (\<lambda>i. ball (x i) (e x))}"
    proof safe
      fix x assume "x \<in> S"
      thus "x \<in> \<Union>{Pi' a b| a b. \<exists>x\<in>S. domain x = a \<and> b = (\<lambda>i. ball (x i) (e x))}"
        using e_pos by (auto intro!: exI[where x="Pi' (domain x) (\<lambda>i. ball (x i) (e x))"])
    next
      fix x y
      assume "y \<in> S"
      moreover
      assume "x \<in> (\<Pi>' i\<in>domain y. ball (y i) (e y))"
      hence "dist x y < e y" using e_pos `y \<in> S`
        by (auto simp: dist_finmap_def Pi'_iff finite_proj_diag dist_commute)
      ultimately show "x \<in> S" by (rule e_in)
    qed
    also have "open \<dots>"
      unfolding open_finmap_def
      by (intro generate_topology.UN) (auto intro: generate_topology.Basis)
    finally show "open S" .
  qed
next
  fix P Q::"'a \<Rightarrow>\<^sub>F 'b"
  have Max_eq_iff: "\<And>A m. finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> (Max A = m) = (m \<in> A \<and> (\<forall>a\<in>A. a \<le> m))"
    by (auto intro: Max_in Max_eqI)
  show "dist P Q = 0 \<longleftrightarrow> P = Q"
    by (auto simp: finmap_eq_iff dist_finmap_def Max_ge_iff finite_proj_diag Max_eq_iff
        add_nonneg_eq_0_iff
      intro!: Max_eqI image_eqI[where x=undefined])
next
  fix P Q R::"'a \<Rightarrow>\<^sub>F 'b"
  let ?dists = "\<lambda>P Q i. dist ((P)\<^sub>F i) ((Q)\<^sub>F i)"
  let ?dpq = "?dists P Q" and ?dpr = "?dists P R" and ?dqr = "?dists Q R"
  let ?dom = "\<lambda>P Q. (if domain P = domain Q then 0 else 1::real)"
  have "dist P Q = Max (range ?dpq) + ?dom P Q"
    by (simp add: dist_finmap_def)
  also obtain t where "t \<in> range ?dpq" "t = Max (range ?dpq)" by (simp add: finite_proj_diag)
  then obtain i where "Max (range ?dpq) = ?dpq i" by auto
  also have "?dpq i \<le> ?dpr i + ?dqr i" by (rule dist_triangle2)
  also have "?dpr i \<le> Max (range ?dpr)" by (simp add: finite_proj_diag)
  also have "?dqr i \<le> Max (range ?dqr)" by (simp add: finite_proj_diag)
  also have "?dom P Q \<le> ?dom P R + ?dom Q R" by simp
  finally show "dist P Q \<le> dist P R + dist Q R" by (simp add: dist_finmap_def ac_simps)
qed

end

subsection {* Complete Space of Finite Maps *}

lemma tendsto_finmap:
  fixes f::"nat \<Rightarrow> ('i \<Rightarrow>\<^sub>F ('a::metric_space))"
  assumes ind_f:  "\<And>n. domain (f n) = domain g"
  assumes proj_g:  "\<And>i. i \<in> domain g \<Longrightarrow> (\<lambda>n. (f n) i) ----> g i"
  shows "f ----> g"
  unfolding tendsto_iff
proof safe
  fix e::real assume "0 < e"
  let ?dists = "\<lambda>x i. dist ((f x)\<^sub>F i) ((g)\<^sub>F i)"
  have "eventually (\<lambda>x. \<forall>i\<in>domain g. ?dists x i < e) sequentially"
    using finite_domain[of g] proj_g
  proof induct
    case (insert i G)
    with `0 < e` have "eventually (\<lambda>x. ?dists x i < e) sequentially" by (auto simp add: tendsto_iff)
    moreover
    from insert have "eventually (\<lambda>x. \<forall>i\<in>G. dist ((f x)\<^sub>F i) ((g)\<^sub>F i) < e) sequentially" by simp
    ultimately show ?case by eventually_elim auto
  qed simp
  thus "eventually (\<lambda>x. dist (f x) g < e) sequentially"
    by eventually_elim (auto simp add: dist_finmap_def finite_proj_diag ind_f `0 < e`)
qed

instance finmap :: (type, complete_space) complete_space
proof
  fix P::"nat \<Rightarrow> 'a \<Rightarrow>\<^sub>F 'b"
  assume "Cauchy P"
  then obtain Nd where Nd: "\<And>n. n \<ge> Nd \<Longrightarrow> dist (P n) (P Nd) < 1"
    by (force simp: cauchy)
  def d \<equiv> "domain (P Nd)"
  with Nd have dim: "\<And>n. n \<ge> Nd \<Longrightarrow> domain (P n) = d" using dist_le_1_imp_domain_eq by auto
  have [simp]: "finite d" unfolding d_def by simp
  def p \<equiv> "\<lambda>i n. (P n) i"
  def q \<equiv> "\<lambda>i. lim (p i)"
  def Q \<equiv> "finmap_of d q"
  have q: "\<And>i. i \<in> d \<Longrightarrow> q i = Q i" by (auto simp add: Q_def Abs_finmap_inverse)
  {
    fix i assume "i \<in> d"
    have "Cauchy (p i)" unfolding cauchy p_def
    proof safe
      fix e::real assume "0 < e"
      with `Cauchy P` obtain N where N: "\<And>n. n\<ge>N \<Longrightarrow> dist (P n) (P N) < min e 1"
        by (force simp: cauchy min_def)
      hence "\<And>n. n \<ge> N \<Longrightarrow> domain (P n) = domain (P N)" using dist_le_1_imp_domain_eq by auto
      with dim have dim: "\<And>n. n \<ge> N \<Longrightarrow> domain (P n) = d" by (metis nat_le_linear)
      show "\<exists>N. \<forall>n\<ge>N. dist ((P n) i) ((P N) i) < e"
      proof (safe intro!: exI[where x="N"])
        fix n assume "N \<le> n" have "N \<le> N" by simp
        have "dist ((P n) i) ((P N) i) \<le> dist (P n) (P N)"
          using dim[OF `N \<le> n`]  dim[OF `N \<le> N`] `i \<in> d`
          by (auto intro!: dist_proj)
        also have "\<dots> < e" using N[OF `N \<le> n`] by simp
        finally show "dist ((P n) i) ((P N) i) < e" .
      qed
    qed
    hence "convergent (p i)" by (metis Cauchy_convergent_iff)
    hence "p i ----> q i" unfolding q_def convergent_def by (metis limI)
  } note p = this
  have "P ----> Q"
  proof (rule metric_LIMSEQ_I)
    fix e::real assume "0 < e"
    have "\<exists>ni. \<forall>i\<in>d. \<forall>n\<ge>ni i. dist (p i n) (q i) < e"
    proof (safe intro!: bchoice)
      fix i assume "i \<in> d"
      from p[OF `i \<in> d`, THEN metric_LIMSEQ_D, OF `0 < e`]
      show "\<exists>no. \<forall>n\<ge>no. dist (p i n) (q i) < e" .
    qed then guess ni .. note ni = this
    def N \<equiv> "max Nd (Max (ni ` d))"
    show "\<exists>N. \<forall>n\<ge>N. dist (P n) Q < e"
    proof (safe intro!: exI[where x="N"])
      fix n assume "N \<le> n"
      hence dom: "domain (P n) = d" "domain Q = d" "domain (P n) = domain Q"
        using dim by (simp_all add: N_def Q_def dim_def Abs_finmap_inverse)
      show "dist (P n) Q < e"
      proof (rule dist_finmap_lessI[OF dom(3) `0 < e`])
        fix i
        assume "i \<in> domain (P n)"
        hence "ni i \<le> Max (ni ` d)" using dom by simp
        also have "\<dots> \<le> N" by (simp add: N_def)
        finally show "dist ((P n)\<^sub>F i) ((Q)\<^sub>F i) < e" using ni `i \<in> domain (P n)` `N \<le> n` dom
          by (auto simp: p_def q N_def less_imp_le)
      qed
    qed
  qed
  thus "convergent P" by (auto simp: convergent_def)
qed

subsection {* Second Countable Space of Finite Maps *}

instantiation finmap :: (countable, second_countable_topology) second_countable_topology
begin

definition basis_proj::"'b set set"
  where "basis_proj = (SOME B. countable B \<and> topological_basis B)"

lemma countable_basis_proj: "countable basis_proj" and basis_proj: "topological_basis basis_proj"
  unfolding basis_proj_def by (intro is_basis countable_basis)+

definition basis_finmap::"('a \<Rightarrow>\<^sub>F 'b) set set"
  where "basis_finmap = {Pi' I S|I S. finite I \<and> (\<forall>i \<in> I. S i \<in> basis_proj)}"

lemma in_basis_finmapI:
  assumes "finite I" assumes "\<And>i. i \<in> I \<Longrightarrow> S i \<in> basis_proj"
  shows "Pi' I S \<in> basis_finmap"
  using assms unfolding basis_finmap_def by auto

lemma basis_finmap_eq:
  assumes "basis_proj \<noteq> {}"
  shows "basis_finmap = (\<lambda>f. Pi' (domain f) (\<lambda>i. from_nat_into basis_proj ((f)\<^sub>F i))) `
    (UNIV::('a \<Rightarrow>\<^sub>F nat) set)" (is "_ = ?f ` _")
  unfolding basis_finmap_def
proof safe
  fix I::"'a set" and S::"'a \<Rightarrow> 'b set"
  assume "finite I" "\<forall>i\<in>I. S i \<in> basis_proj"
  hence "Pi' I S = ?f (finmap_of I (\<lambda>x. to_nat_on basis_proj (S x)))"
    by (force simp: Pi'_def countable_basis_proj)
  thus "Pi' I S \<in> range ?f" by simp
next
  fix x and f::"'a \<Rightarrow>\<^sub>F nat"
  show "\<exists>I S. (\<Pi>' i\<in>domain f. from_nat_into basis_proj ((f)\<^sub>F i)) = Pi' I S \<and>
    finite I \<and> (\<forall>i\<in>I. S i \<in> basis_proj)"
    using assms by (auto intro: from_nat_into)
qed

lemma basis_finmap_eq_empty: "basis_proj = {} \<Longrightarrow> basis_finmap = {Pi' {} undefined}"
  by (auto simp: Pi'_iff basis_finmap_def)

lemma countable_basis_finmap: "countable basis_finmap"
  by (cases "basis_proj = {}") (auto simp: basis_finmap_eq basis_finmap_eq_empty)

lemma finmap_topological_basis:
  "topological_basis basis_finmap"
proof (subst topological_basis_iff, safe)
  fix B' assume "B' \<in> basis_finmap"
  thus "open B'"
    by (auto intro!: open_Pi'I topological_basis_open[OF basis_proj]
      simp: topological_basis_def basis_finmap_def Let_def)
next
  fix O'::"('a \<Rightarrow>\<^sub>F 'b) set" and x
  assume O': "open O'" "x \<in> O'"
  then obtain a where a:
    "x \<in> Pi' (domain x) a" "Pi' (domain x) a \<subseteq> O'" "\<And>i. i\<in>domain x \<Longrightarrow> open (a i)"
    unfolding open_finmap_def
  proof (atomize_elim, induct rule: generate_topology.induct)
    case (Int a b)
    let ?p="\<lambda>a f. x \<in> Pi' (domain x) f \<and> Pi' (domain x) f \<subseteq> a \<and> (\<forall>i. i \<in> domain x \<longrightarrow> open (f i))"
    from Int obtain f g where "?p a f" "?p b g" by auto
    thus ?case by (force intro!: exI[where x="\<lambda>i. f i \<inter> g i"] simp: Pi'_def)
  next
    case (UN k)
    then obtain kk a where "x \<in> kk" "kk \<in> k" "x \<in> Pi' (domain x) a" "Pi' (domain x) a \<subseteq> kk"
      "\<And>i. i\<in>domain x \<Longrightarrow> open (a i)"
      by force
    thus ?case by blast
  qed (auto simp: Pi'_def)
  have "\<exists>B.
    (\<forall>i\<in>domain x. x i \<in> B i \<and> B i \<subseteq> a i \<and> B i \<in> basis_proj)"
  proof (rule bchoice, safe)
    fix i assume "i \<in> domain x"
    hence "open (a i)" "x i \<in> a i" using a by auto
    from topological_basisE[OF basis_proj this] guess b' .
    thus "\<exists>y. x i \<in> y \<and> y \<subseteq> a i \<and> y \<in> basis_proj" by auto
  qed
  then guess B .. note B = this
  def B' \<equiv> "Pi' (domain x) (\<lambda>i. (B i)::'b set)"
  have "B' \<subseteq> Pi' (domain x) a" using B by (auto intro!: Pi'_mono simp: B'_def)
  also note `\<dots> \<subseteq> O'`
  finally show "\<exists>B'\<in>basis_finmap. x \<in> B' \<and> B' \<subseteq> O'" using B
    by (auto intro!: bexI[where x=B'] Pi'_mono in_basis_finmapI simp: B'_def)
qed

lemma range_enum_basis_finmap_imp_open:
  assumes "x \<in> basis_finmap"
  shows "open x"
  using finmap_topological_basis assms by (auto simp: topological_basis_def)

instance proof qed (blast intro: finmap_topological_basis countable_basis_finmap topological_basis_imp_subbasis)

end

subsection {* Polish Space of Finite Maps *}

instance finmap :: (countable, polish_space) polish_space proof qed

subsection {* Product Measurable Space of Finite Maps *}

definition "PiF I M \<equiv>
  sigma (\<Union>J \<in> I. (\<Pi>' j\<in>J. space (M j))) {(\<Pi>' j\<in>J. X j) |X J. J \<in> I \<and> X \<in> (\<Pi> j\<in>J. sets (M j))}"

abbreviation
  "Pi\<^sub>F I M \<equiv> PiF I M"

syntax
  "_PiF" :: "pttrn \<Rightarrow> 'i set \<Rightarrow> 'a measure \<Rightarrow> ('i => 'a) measure"  ("(3PIF _:_./ _)" 10)

syntax (xsymbols)
  "_PiF" :: "pttrn \<Rightarrow> 'i set \<Rightarrow> 'a measure \<Rightarrow> ('i => 'a) measure"  ("(3\<Pi>\<^sub>F _\<in>_./ _)"  10)

syntax (HTML output)
  "_PiF" :: "pttrn \<Rightarrow> 'i set \<Rightarrow> 'a measure \<Rightarrow> ('i => 'a) measure"  ("(3\<Pi>\<^sub>F _\<in>_./ _)"  10)

translations
  "PIF x:I. M" == "CONST PiF I (%x. M)"

lemma PiF_gen_subset: "{(\<Pi>' j\<in>J. X j) |X J. J \<in> I \<and> X \<in> (\<Pi> j\<in>J. sets (M j))} \<subseteq>
    Pow (\<Union>J \<in> I. (\<Pi>' j\<in>J. space (M j)))"
  by (auto simp: Pi'_def) (blast dest: sets.sets_into_space)

lemma space_PiF: "space (PiF I M) = (\<Union>J \<in> I. (\<Pi>' j\<in>J. space (M j)))"
  unfolding PiF_def using PiF_gen_subset by (rule space_measure_of)

lemma sets_PiF:
  "sets (PiF I M) = sigma_sets (\<Union>J \<in> I. (\<Pi>' j\<in>J. space (M j)))
    {(\<Pi>' j\<in>J. X j) |X J. J \<in> I \<and> X \<in> (\<Pi> j\<in>J. sets (M j))}"
  unfolding PiF_def using PiF_gen_subset by (rule sets_measure_of)

lemma sets_PiF_singleton:
  "sets (PiF {I} M) = sigma_sets (\<Pi>' j\<in>I. space (M j))
    {(\<Pi>' j\<in>I. X j) |X. X \<in> (\<Pi> j\<in>I. sets (M j))}"
  unfolding sets_PiF by simp

lemma in_sets_PiFI:
  assumes "X = (Pi' J S)" "J \<in> I" "\<And>i. i\<in>J \<Longrightarrow> S i \<in> sets (M i)"
  shows "X \<in> sets (PiF I M)"
  unfolding sets_PiF
  using assms by blast

lemma product_in_sets_PiFI:
  assumes "J \<in> I" "\<And>i. i\<in>J \<Longrightarrow> S i \<in> sets (M i)"
  shows "(Pi' J S) \<in> sets (PiF I M)"
  unfolding sets_PiF
  using assms by blast

lemma singleton_space_subset_in_sets:
  fixes J
  assumes "J \<in> I"
  assumes "finite J"
  shows "space (PiF {J} M) \<in> sets (PiF I M)"
  using assms
  by (intro in_sets_PiFI[where J=J and S="\<lambda>i. space (M i)"])
      (auto simp: product_def space_PiF)

lemma singleton_subspace_set_in_sets:
  assumes A: "A \<in> sets (PiF {J} M)"
  assumes "finite J"
  assumes "J \<in> I"
  shows "A \<in> sets (PiF I M)"
  using A[unfolded sets_PiF]
  apply (induct A)
  unfolding sets_PiF[symmetric] unfolding space_PiF[symmetric]
  using assms
  by (auto intro: in_sets_PiFI intro!: singleton_space_subset_in_sets)

lemma finite_measurable_singletonI:
  assumes "finite I"
  assumes "\<And>J. J \<in> I \<Longrightarrow> finite J"
  assumes MN: "\<And>J. J \<in> I \<Longrightarrow> A \<in> measurable (PiF {J} M) N"
  shows "A \<in> measurable (PiF I M) N"
  unfolding measurable_def
proof safe
  fix y assume "y \<in> sets N"
  have "A -` y \<inter> space (PiF I M) = (\<Union>J\<in>I. A -` y \<inter> space (PiF {J} M))"
    by (auto simp: space_PiF)
  also have "\<dots> \<in> sets (PiF I M)"
  proof
    show "finite I" by fact
    fix J assume "J \<in> I"
    with assms have "finite J" by simp
    show "A -` y \<inter> space (PiF {J} M) \<in> sets (PiF I M)"
      by (rule singleton_subspace_set_in_sets[OF measurable_sets[OF assms(3)]]) fact+
  qed
  finally show "A -` y \<inter> space (PiF I M) \<in> sets (PiF I M)" .
next
  fix x assume "x \<in> space (PiF I M)" thus "A x \<in> space N"
    using MN[of "domain x"]
    by (auto simp: space_PiF measurable_space Pi'_def)
qed

lemma countable_finite_comprehension:
  fixes f :: "'a::countable set \<Rightarrow> _"
  assumes "\<And>s. P s \<Longrightarrow> finite s"
  assumes "\<And>s. P s \<Longrightarrow> f s \<in> sets M"
  shows "\<Union>{f s|s. P s} \<in> sets M"
proof -
  have "\<Union>{f s|s. P s} = (\<Union>n::nat. let s = set (from_nat n) in if P s then f s else {})"
  proof safe
    fix x X s assume *: "x \<in> f s" "P s"
    with assms obtain l where "s = set l" using finite_list by blast
    with * show "x \<in> (\<Union>n. let s = set (from_nat n) in if P s then f s else {})" using `P s`
      by (auto intro!: exI[where x="to_nat l"])
  next
    fix x n assume "x \<in> (let s = set (from_nat n) in if P s then f s else {})"
    thus "x \<in> \<Union>{f s|s. P s}" using assms by (auto simp: Let_def split: split_if_asm)
  qed
  hence "\<Union>{f s|s. P s} = (\<Union>n. let s = set (from_nat n) in if P s then f s else {})" by simp
  also have "\<dots> \<in> sets M" using assms by (auto simp: Let_def)
  finally show ?thesis .
qed

lemma space_subset_in_sets:
  fixes J::"'a::countable set set"
  assumes "J \<subseteq> I"
  assumes "\<And>j. j \<in> J \<Longrightarrow> finite j"
  shows "space (PiF J M) \<in> sets (PiF I M)"
proof -
  have "space (PiF J M) = \<Union>{space (PiF {j} M)|j. j \<in> J}"
    unfolding space_PiF by blast
  also have "\<dots> \<in> sets (PiF I M)" using assms
    by (intro countable_finite_comprehension) (auto simp: singleton_space_subset_in_sets)
  finally show ?thesis .
qed

lemma subspace_set_in_sets:
  fixes J::"'a::countable set set"
  assumes A: "A \<in> sets (PiF J M)"
  assumes "J \<subseteq> I"
  assumes "\<And>j. j \<in> J \<Longrightarrow> finite j"
  shows "A \<in> sets (PiF I M)"
  using A[unfolded sets_PiF]
  apply (induct A)
  unfolding sets_PiF[symmetric] unfolding space_PiF[symmetric]
  using assms
  by (auto intro: in_sets_PiFI intro!: space_subset_in_sets)

lemma countable_measurable_PiFI:
  fixes I::"'a::countable set set"
  assumes MN: "\<And>J. J \<in> I \<Longrightarrow> finite J \<Longrightarrow> A \<in> measurable (PiF {J} M) N"
  shows "A \<in> measurable (PiF I M) N"
  unfolding measurable_def
proof safe
  fix y assume "y \<in> sets N"
  have "A -` y = (\<Union>{A -` y \<inter> {x. domain x = J}|J. finite J})" by auto
  { fix x::"'a \<Rightarrow>\<^sub>F 'b"
    from finite_list[of "domain x"] obtain xs where "set xs = domain x" by auto
    hence "\<exists>n. domain x = set (from_nat n)"
      by (intro exI[where x="to_nat xs"]) auto }
  hence "A -` y \<inter> space (PiF I M) = (\<Union>n. A -` y \<inter> space (PiF ({set (from_nat n)}\<inter>I) M))"
    by (auto simp: space_PiF Pi'_def)
  also have "\<dots> \<in> sets (PiF I M)"
    apply (intro sets.Int sets.countable_nat_UN subsetI, safe)
    apply (case_tac "set (from_nat i) \<in> I")
    apply simp_all
    apply (rule singleton_subspace_set_in_sets[OF measurable_sets[OF MN]])
    using assms `y \<in> sets N`
    apply (auto simp: space_PiF)
    done
  finally show "A -` y \<inter> space (PiF I M) \<in> sets (PiF I M)" .
next
  fix x assume "x \<in> space (PiF I M)" thus "A x \<in> space N"
    using MN[of "domain x"] by (auto simp: space_PiF measurable_space Pi'_def)
qed

lemma measurable_PiF:
  assumes f: "\<And>x. x \<in> space N \<Longrightarrow> domain (f x) \<in> I \<and> (\<forall>i\<in>domain (f x). (f x) i \<in> space (M i))"
  assumes S: "\<And>J S. J \<in> I \<Longrightarrow> (\<And>i. i \<in> J \<Longrightarrow> S i \<in> sets (M i)) \<Longrightarrow>
    f -` (Pi' J S) \<inter> space N \<in> sets N"
  shows "f \<in> measurable N (PiF I M)"
  unfolding PiF_def
  using PiF_gen_subset
  apply (rule measurable_measure_of)
  using f apply force
  apply (insert S, auto)
  done

lemma restrict_sets_measurable:
  assumes A: "A \<in> sets (PiF I M)" and "J \<subseteq> I"
  shows "A \<inter> {m. domain m \<in> J} \<in> sets (PiF J M)"
  using A[unfolded sets_PiF]
proof (induct A)
  case (Basic a)
  then obtain K S where S: "a = Pi' K S" "K \<in> I" "(\<forall>i\<in>K. S i \<in> sets (M i))"
    by auto
  show ?case
  proof cases
    assume "K \<in> J"
    hence "a \<inter> {m. domain m \<in> J} \<in> {Pi' K X |X K. K \<in> J \<and> X \<in> (\<Pi> j\<in>K. sets (M j))}" using S
      by (auto intro!: exI[where x=K] exI[where x=S] simp: Pi'_def)
    also have "\<dots> \<subseteq> sets (PiF J M)" unfolding sets_PiF by auto
    finally show ?thesis .
  next
    assume "K \<notin> J"
    hence "a \<inter> {m. domain m \<in> J} = {}" using S by (auto simp: Pi'_def)
    also have "\<dots> \<in> sets (PiF J M)" by simp
    finally show ?thesis .
  qed
next
  case (Union a)
  have "UNION UNIV a \<inter> {m. domain m \<in> J} = (\<Union>i. (a i \<inter> {m. domain m \<in> J}))"
    by simp
  also have "\<dots> \<in> sets (PiF J M)" using Union by (intro sets.countable_nat_UN) auto
  finally show ?case .
next
  case (Compl a)
  have "(space (PiF I M) - a) \<inter> {m. domain m \<in> J} = (space (PiF J M) - (a \<inter> {m. domain m \<in> J}))"
    using `J \<subseteq> I` by (auto simp: space_PiF Pi'_def)
  also have "\<dots> \<in> sets (PiF J M)" using Compl by auto
  finally show ?case by (simp add: space_PiF)
qed simp

lemma measurable_finmap_of:
  assumes f: "\<And>i. (\<exists>x \<in> space N. i \<in> J x) \<Longrightarrow> (\<lambda>x. f x i) \<in> measurable N (M i)"
  assumes J: "\<And>x. x \<in> space N \<Longrightarrow> J x \<in> I" "\<And>x. x \<in> space N \<Longrightarrow> finite (J x)"
  assumes JN: "\<And>S. {x. J x = S} \<inter> space N \<in> sets N"
  shows "(\<lambda>x. finmap_of (J x) (f x)) \<in> measurable N (PiF I M)"
proof (rule measurable_PiF)
  fix x assume "x \<in> space N"
  with J[of x] measurable_space[OF f]
  show "domain (finmap_of (J x) (f x)) \<in> I \<and>
        (\<forall>i\<in>domain (finmap_of (J x) (f x)). (finmap_of (J x) (f x)) i \<in> space (M i))"
    by auto
next
  fix K S assume "K \<in> I" and *: "\<And>i. i \<in> K \<Longrightarrow> S i \<in> sets (M i)"
  with J have eq: "(\<lambda>x. finmap_of (J x) (f x)) -` Pi' K S \<inter> space N =
    (if \<exists>x \<in> space N. K = J x \<and> finite K then if K = {} then {x \<in> space N. J x = K}
      else (\<Inter>i\<in>K. (\<lambda>x. f x i) -` S i \<inter> {x \<in> space N. J x = K}) else {})"
    by (auto simp: Pi'_def)
  have r: "{x \<in> space N. J x = K} = space N \<inter> ({x. J x = K} \<inter> space N)" by auto
  show "(\<lambda>x. finmap_of (J x) (f x)) -` Pi' K S \<inter> space N \<in> sets N"
    unfolding eq r
    apply (simp del: INT_simps add: )
    apply (intro conjI impI sets.finite_INT JN sets.Int[OF sets.top])
    apply simp apply assumption
    apply (subst Int_assoc[symmetric])
    apply (rule sets.Int)
    apply (intro measurable_sets[OF f] *) apply force apply assumption
    apply (intro JN)
    done
qed

lemma measurable_PiM_finmap_of:
  assumes "finite J"
  shows "finmap_of J \<in> measurable (Pi\<^sub>M J M) (PiF {J} M)"
  apply (rule measurable_finmap_of)
  apply (rule measurable_component_singleton)
  apply simp
  apply rule
  apply (rule `finite J`)
  apply simp
  done

lemma proj_measurable_singleton:
  assumes "A \<in> sets (M i)"
  shows "(\<lambda>x. (x)\<^sub>F i) -` A \<inter> space (PiF {I} M) \<in> sets (PiF {I} M)"
proof cases
  assume "i \<in> I"
  hence "(\<lambda>x. (x)\<^sub>F i) -` A \<inter> space (PiF {I} M) =
    Pi' I (\<lambda>x. if x = i then A else space (M x))"
    using sets.sets_into_space[OF ] `A \<in> sets (M i)` assms
    by (auto simp: space_PiF Pi'_def)
  thus ?thesis  using assms `A \<in> sets (M i)`
    by (intro in_sets_PiFI) auto
next
  assume "i \<notin> I"
  hence "(\<lambda>x. (x)\<^sub>F i) -` A \<inter> space (PiF {I} M) =
    (if undefined \<in> A then space (PiF {I} M) else {})" by (auto simp: space_PiF Pi'_def)
  thus ?thesis by simp
qed

lemma measurable_proj_singleton:
  assumes "i \<in> I"
  shows "(\<lambda>x. (x)\<^sub>F i) \<in> measurable (PiF {I} M) (M i)"
  by (unfold measurable_def, intro CollectI conjI ballI proj_measurable_singleton assms)
     (insert `i \<in> I`, auto simp: space_PiF)

lemma measurable_proj_countable:
  fixes I::"'a::countable set set"
  assumes "y \<in> space (M i)"
  shows "(\<lambda>x. if i \<in> domain x then (x)\<^sub>F i else y) \<in> measurable (PiF I M) (M i)"
proof (rule countable_measurable_PiFI)
  fix J assume "J \<in> I" "finite J"
  show "(\<lambda>x. if i \<in> domain x then x i else y) \<in> measurable (PiF {J} M) (M i)"
    unfolding measurable_def
  proof safe
    fix z assume "z \<in> sets (M i)"
    have "(\<lambda>x. if i \<in> domain x then x i else y) -` z \<inter> space (PiF {J} M) =
      (\<lambda>x. if i \<in> J then (x)\<^sub>F i else y) -` z \<inter> space (PiF {J} M)"
      by (auto simp: space_PiF Pi'_def)
    also have "\<dots> \<in> sets (PiF {J} M)" using `z \<in> sets (M i)` `finite J`
      by (cases "i \<in> J") (auto intro!: measurable_sets[OF measurable_proj_singleton])
    finally show "(\<lambda>x. if i \<in> domain x then x i else y) -` z \<inter> space (PiF {J} M) \<in>
      sets (PiF {J} M)" .
  qed (insert `y \<in> space (M i)`, auto simp: space_PiF Pi'_def)
qed

lemma measurable_restrict_proj:
  assumes "J \<in> II" "finite J"
  shows "finmap_of J \<in> measurable (PiM J M) (PiF II M)"
  using assms
  by (intro measurable_finmap_of measurable_component_singleton) auto

lemma measurable_proj_PiM:
  fixes J K ::"'a::countable set" and I::"'a set set"
  assumes "finite J" "J \<in> I"
  assumes "x \<in> space (PiM J M)"
  shows "proj \<in> measurable (PiF {J} M) (PiM J M)"
proof (rule measurable_PiM_single)
  show "proj \<in> space (PiF {J} M) \<rightarrow> (\<Pi>\<^sub>E i \<in> J. space (M i))"
    using assms by (auto simp add: space_PiM space_PiF extensional_def sets_PiF Pi'_def)
next
  fix A i assume A: "i \<in> J" "A \<in> sets (M i)"
  show "{\<omega> \<in> space (PiF {J} M). (\<omega>)\<^sub>F i \<in> A} \<in> sets (PiF {J} M)"
  proof
    have "{\<omega> \<in> space (PiF {J} M). (\<omega>)\<^sub>F i \<in> A} =
      (\<lambda>\<omega>. (\<omega>)\<^sub>F i) -` A \<inter> space (PiF {J} M)" by auto
    also have "\<dots> \<in> sets (PiF {J} M)"
      using assms A by (auto intro: measurable_sets[OF measurable_proj_singleton] simp: space_PiM)
    finally show ?thesis .
  qed simp
qed

lemma space_PiF_singleton_eq_product:
  assumes "finite I"
  shows "space (PiF {I} M) = (\<Pi>' i\<in>I. space (M i))"
  by (auto simp: product_def space_PiF assms)

text {* adapted from @{thm sets_PiM_single} *}

lemma sets_PiF_single:
  assumes "finite I" "I \<noteq> {}"
  shows "sets (PiF {I} M) =
    sigma_sets (\<Pi>' i\<in>I. space (M i))
      {{f\<in>\<Pi>' i\<in>I. space (M i). f i \<in> A} | i A. i \<in> I \<and> A \<in> sets (M i)}"
    (is "_ = sigma_sets ?\<Omega> ?R")
  unfolding sets_PiF_singleton
proof (rule sigma_sets_eqI)
  interpret R: sigma_algebra ?\<Omega> "sigma_sets ?\<Omega> ?R" by (rule sigma_algebra_sigma_sets) auto
  fix A assume "A \<in> {Pi' I X |X. X \<in> (\<Pi> j\<in>I. sets (M j))}"
  then obtain X where X: "A = Pi' I X" "X \<in> (\<Pi> j\<in>I. sets (M j))" by auto
  show "A \<in> sigma_sets ?\<Omega> ?R"
  proof -
    from `I \<noteq> {}` X have "A = (\<Inter>j\<in>I. {f\<in>space (PiF {I} M). f j \<in> X j})"
      using sets.sets_into_space
      by (auto simp: space_PiF product_def) blast
    also have "\<dots> \<in> sigma_sets ?\<Omega> ?R"
      using X `I \<noteq> {}` assms by (intro R.finite_INT) (auto simp: space_PiF)
    finally show "A \<in> sigma_sets ?\<Omega> ?R" .
  qed
next
  fix A assume "A \<in> ?R"
  then obtain i B where A: "A = {f\<in>\<Pi>' i\<in>I. space (M i). f i \<in> B}" "i \<in> I" "B \<in> sets (M i)"
    by auto
  then have "A = (\<Pi>' j \<in> I. if j = i then B else space (M j))"
    using sets.sets_into_space[OF A(3)]
    apply (auto simp: Pi'_iff split: split_if_asm)
    apply blast
    done
  also have "\<dots> \<in> sigma_sets ?\<Omega> {Pi' I X |X. X \<in> (\<Pi> j\<in>I. sets (M j))}"
    using A
    by (intro sigma_sets.Basic )
       (auto intro: exI[where x="\<lambda>j. if j = i then B else space (M j)"])
  finally show "A \<in> sigma_sets ?\<Omega> {Pi' I X |X. X \<in> (\<Pi> j\<in>I. sets (M j))}" .
qed

text {* adapted from @{thm PiE_cong} *}

lemma Pi'_cong:
  assumes "finite I"
  assumes "\<And>i. i \<in> I \<Longrightarrow> f i = g i"
  shows "Pi' I f = Pi' I g"
using assms by (auto simp: Pi'_def)

text {* adapted from @{thm Pi_UN} *}

lemma Pi'_UN:
  fixes A :: "nat \<Rightarrow> 'i \<Rightarrow> 'a set"
  assumes "finite I"
  assumes mono: "\<And>i n m. i \<in> I \<Longrightarrow> n \<le> m \<Longrightarrow> A n i \<subseteq> A m i"
  shows "(\<Union>n. Pi' I (A n)) = Pi' I (\<lambda>i. \<Union>n. A n i)"
proof (intro set_eqI iffI)
  fix f assume "f \<in> Pi' I (\<lambda>i. \<Union>n. A n i)"
  then have "\<forall>i\<in>I. \<exists>n. f i \<in> A n i" "domain f = I" by (auto simp: `finite I` Pi'_def)
  from bchoice[OF this(1)] obtain n where n: "\<And>i. i \<in> I \<Longrightarrow> f i \<in> (A (n i) i)" by auto
  obtain k where k: "\<And>i. i \<in> I \<Longrightarrow> n i \<le> k"
    using `finite I` finite_nat_set_iff_bounded_le[of "n`I"] by auto
  have "f \<in> Pi' I (\<lambda>i. A k i)"
  proof
    fix i assume "i \<in> I"
    from mono[OF this, of "n i" k] k[OF this] n[OF this] `domain f = I` `i \<in> I`
    show "f i \<in> A k i " by (auto simp: `finite I`)
  qed (simp add: `domain f = I` `finite I`)
  then show "f \<in> (\<Union>n. Pi' I (A n))" by auto
qed (auto simp: Pi'_def `finite I`)

text {* adapted from @{thm sets_PiM_sigma} *}

lemma sigma_fprod_algebra_sigma_eq:
  fixes E :: "'i \<Rightarrow> 'a set set" and S :: "'i \<Rightarrow> nat \<Rightarrow> 'a set"
  assumes [simp]: "finite I" "I \<noteq> {}"
    and S_union: "\<And>i. i \<in> I \<Longrightarrow> (\<Union>j. S i j) = space (M i)"
    and S_in_E: "\<And>i. i \<in> I \<Longrightarrow> range (S i) \<subseteq> E i"
  assumes E_closed: "\<And>i. i \<in> I \<Longrightarrow> E i \<subseteq> Pow (space (M i))"
    and E_generates: "\<And>i. i \<in> I \<Longrightarrow> sets (M i) = sigma_sets (space (M i)) (E i)"
  defines "P == { Pi' I F | F. \<forall>i\<in>I. F i \<in> E i }"
  shows "sets (PiF {I} M) = sigma_sets (space (PiF {I} M)) P"
proof
  let ?P = "sigma (space (Pi\<^sub>F {I} M)) P"
  from `finite I`[THEN ex_bij_betw_finite_nat] guess T ..
  then have T: "\<And>i. i \<in> I \<Longrightarrow> T i < card I" "\<And>i. i\<in>I \<Longrightarrow> the_inv_into I T (T i) = i"
    by (auto simp add: bij_betw_def set_eq_iff image_iff the_inv_into_f_f simp del: `finite I`)
  have P_closed: "P \<subseteq> Pow (space (Pi\<^sub>F {I} M))"
    using E_closed by (auto simp: space_PiF P_def Pi'_iff subset_eq)
  then have space_P: "space ?P = (\<Pi>' i\<in>I. space (M i))"
    by (simp add: space_PiF)
  have "sets (PiF {I} M) =
      sigma_sets (space ?P) {{f \<in> \<Pi>' i\<in>I. space (M i). f i \<in> A} |i A. i \<in> I \<and> A \<in> sets (M i)}"
    using sets_PiF_single[of I M] by (simp add: space_P)
  also have "\<dots> \<subseteq> sets (sigma (space (PiF {I} M)) P)"
  proof (safe intro!: sets.sigma_sets_subset)
    fix i A assume "i \<in> I" and A: "A \<in> sets (M i)"
    have "(\<lambda>x. (x)\<^sub>F i) \<in> measurable ?P (sigma (space (M i)) (E i))"
    proof (subst measurable_iff_measure_of)
      show "E i \<subseteq> Pow (space (M i))" using `i \<in> I` by fact
      from space_P `i \<in> I` show "(\<lambda>x. (x)\<^sub>F i) \<in> space ?P \<rightarrow> space (M i)"
        by auto
      show "\<forall>A\<in>E i. (\<lambda>x. (x)\<^sub>F i) -` A \<inter> space ?P \<in> sets ?P"
      proof
        fix A assume A: "A \<in> E i"
        then have "(\<lambda>x. (x)\<^sub>F i) -` A \<inter> space ?P = (\<Pi>' j\<in>I. if i = j then A else space (M j))"
          using E_closed `i \<in> I` by (auto simp: space_P Pi_iff subset_eq split: split_if_asm)
        also have "\<dots> = (\<Pi>' j\<in>I. \<Union>n. if i = j then A else S j n)"
          by (intro Pi'_cong) (simp_all add: S_union)
        also have "\<dots> = (\<Union>xs\<in>{xs. length xs = card I}. \<Pi>' j\<in>I. if i = j then A else S j (xs ! T j))"
          using T
          apply auto
          apply (simp_all add: Pi'_iff bchoice_iff)
          apply (erule conjE exE)+
          apply (rule_tac x="map (\<lambda>n. f (the_inv_into I T n)) [0..<card I]" in exI)
          apply (auto simp: bij_betw_def)
          done
        also have "\<dots> \<in> sets ?P"
        proof (safe intro!: sets.countable_UN)
          fix xs show "(\<Pi>' j\<in>I. if i = j then A else S j (xs ! T j)) \<in> sets ?P"
            using A S_in_E
            by (simp add: P_closed)
               (auto simp: P_def subset_eq intro!: exI[of _ "\<lambda>j. if i = j then A else S j (xs ! T j)"])
        qed
        finally show "(\<lambda>x. (x)\<^sub>F i) -` A \<inter> space ?P \<in> sets ?P"
          using P_closed by simp
      qed
    qed
    from measurable_sets[OF this, of A] A `i \<in> I` E_closed
    have "(\<lambda>x. (x)\<^sub>F i) -` A \<inter> space ?P \<in> sets ?P"
      by (simp add: E_generates)
    also have "(\<lambda>x. (x)\<^sub>F i) -` A \<inter> space ?P = {f \<in> \<Pi>' i\<in>I. space (M i). f i \<in> A}"
      using P_closed by (auto simp: space_PiF)
    finally show "\<dots> \<in> sets ?P" .
  qed
  finally show "sets (PiF {I} M) \<subseteq> sigma_sets (space (PiF {I} M)) P"
    by (simp add: P_closed)
  show "sigma_sets (space (PiF {I} M)) P \<subseteq> sets (PiF {I} M)"
    using `finite I` `I \<noteq> {}`
    by (auto intro!: sets.sigma_sets_subset product_in_sets_PiFI simp: E_generates P_def)
qed

lemma product_open_generates_sets_PiF_single:
  assumes "I \<noteq> {}"
  assumes [simp]: "finite I"
  shows "sets (PiF {I} (\<lambda>_. borel::'b::second_countable_topology measure)) =
    sigma_sets (space (PiF {I} (\<lambda>_. borel))) {Pi' I F |F. (\<forall>i\<in>I. F i \<in> Collect open)}"
proof -
  from open_countable_basisE[OF open_UNIV] guess S::"'b set set" . note S = this
  show ?thesis
  proof (rule sigma_fprod_algebra_sigma_eq)
    show "finite I" by simp
    show "I \<noteq> {}" by fact
    def S'\<equiv>"from_nat_into S"
    show "(\<Union>j. S' j) = space borel"
      using S
      apply (auto simp add: from_nat_into countable_basis_proj S'_def basis_proj_def)
      apply (metis (lifting, mono_tags) UNIV_I UnionE basis_proj_def countable_basis_proj countable_subset from_nat_into_surj)
      done
    show "range S' \<subseteq> Collect open"
      using S
      apply (auto simp add: from_nat_into countable_basis_proj S'_def)
      apply (metis UNIV_not_empty Union_empty from_nat_into set_mp topological_basis_open[OF basis_proj] basis_proj_def)
      done
    show "Collect open \<subseteq> Pow (space borel)" by simp
    show "sets borel = sigma_sets (space borel) (Collect open)"
      by (simp add: borel_def)
  qed
qed

lemma finmap_UNIV[simp]: "(\<Union>J\<in>Collect finite. PI' j : J. UNIV) = UNIV" by auto

lemma borel_eq_PiF_borel:
  shows "(borel :: ('i::countable \<Rightarrow>\<^sub>F 'a::polish_space) measure) =
    PiF (Collect finite) (\<lambda>_. borel :: 'a measure)"
  unfolding borel_def PiF_def
proof (rule measure_eqI, clarsimp, rule sigma_sets_eqI)
  fix a::"('i \<Rightarrow>\<^sub>F 'a) set" assume "a \<in> Collect open" hence "open a" by simp
  then obtain B' where B': "B'\<subseteq>basis_finmap" "a = \<Union>B'"
    using finmap_topological_basis by (force simp add: topological_basis_def)
  have "a \<in> sigma UNIV {Pi' J X |X J. finite J \<and> X \<in> J \<rightarrow> sigma_sets UNIV (Collect open)}"
    unfolding `a = \<Union>B'`
  proof (rule sets.countable_Union)
    from B' countable_basis_finmap show "countable B'" by (metis countable_subset)
  next
    show "B' \<subseteq> sets (sigma UNIV
      {Pi' J X |X J. finite J \<and> X \<in> J \<rightarrow> sigma_sets UNIV (Collect open)})" (is "_ \<subseteq> sets ?s")
    proof
      fix x assume "x \<in> B'" with B' have "x \<in> basis_finmap" by auto
      then obtain J X where "x = Pi' J X" "finite J" "X \<in> J \<rightarrow> sigma_sets UNIV (Collect open)"
        by (auto simp: basis_finmap_def topological_basis_open[OF basis_proj])
      thus "x \<in> sets ?s" by auto
    qed
  qed
  thus "a \<in> sigma_sets UNIV {Pi' J X |X J. finite J \<and> X \<in> J \<rightarrow> sigma_sets UNIV (Collect open)}"
    by simp
next
  fix b::"('i \<Rightarrow>\<^sub>F 'a) set"
  assume "b \<in> {Pi' J X |X J. finite J \<and> X \<in> J \<rightarrow> sigma_sets UNIV (Collect open)}"
  hence b': "b \<in> sets (Pi\<^sub>F (Collect finite) (\<lambda>_. borel))" by (auto simp: sets_PiF borel_def)
  let ?b = "\<lambda>J. b \<inter> {x. domain x = J}"
  have "b = \<Union>((\<lambda>J. ?b J) ` Collect finite)" by auto
  also have "\<dots> \<in> sets borel"
  proof (rule sets.countable_Union, safe)
    fix J::"'i set" assume "finite J"
    { assume ef: "J = {}"
      have "?b J \<in> sets borel"
      proof cases
        assume "?b J \<noteq> {}"
        then obtain f where "f \<in> b" "domain f = {}" using ef by auto
        hence "?b J = {f}" using `J = {}`
          by (auto simp: finmap_eq_iff)
        also have "{f} \<in> sets borel" by simp
        finally show ?thesis .
      qed simp
    } moreover {
      assume "J \<noteq> ({}::'i set)"
      have "(?b J) = b \<inter> {m. domain m \<in> {J}}" by auto
      also have "\<dots> \<in> sets (PiF {J} (\<lambda>_. borel))"
        using b' by (rule restrict_sets_measurable) (auto simp: `finite J`)
      also have "\<dots> = sigma_sets (space (PiF {J} (\<lambda>_. borel)))
        {Pi' (J) F |F. (\<forall>j\<in>J. F j \<in> Collect open)}"
        (is "_ = sigma_sets _ ?P")
       by (rule product_open_generates_sets_PiF_single[OF `J \<noteq> {}` `finite J`])
      also have "\<dots> \<subseteq> sigma_sets UNIV (Collect open)"
        by (intro sigma_sets_mono'') (auto intro!: open_Pi'I simp: space_PiF)
      finally have "(?b J) \<in> sets borel" by (simp add: borel_def)
    } ultimately show "(?b J) \<in> sets borel" by blast
  qed (simp add: countable_Collect_finite)
  finally show "b \<in> sigma_sets UNIV (Collect open)" by (simp add: borel_def)
qed (simp add: emeasure_sigma borel_def PiF_def)

subsection {* Isomorphism between Functions and Finite Maps *}

lemma measurable_finmap_compose:
  shows "(\<lambda>m. compose J m f) \<in> measurable (PiM (f ` J) (\<lambda>_. M)) (PiM J (\<lambda>_. M))"
  unfolding compose_def by measurable

lemma measurable_compose_inv:
  assumes inj: "\<And>j. j \<in> J \<Longrightarrow> f' (f j) = j"
  shows "(\<lambda>m. compose (f ` J) m f') \<in> measurable (PiM J (\<lambda>_. M)) (PiM (f ` J) (\<lambda>_. M))"
  unfolding compose_def by (rule measurable_restrict) (auto simp: inj)

locale function_to_finmap =
  fixes J::"'a set" and f :: "'a \<Rightarrow> 'b::countable" and f'
  assumes [simp]: "finite J"
  assumes inv: "i \<in> J \<Longrightarrow> f' (f i) = i"
begin

text {* to measure finmaps *}

definition "fm = (finmap_of (f ` J)) o (\<lambda>g. compose (f ` J) g f')"

lemma domain_fm[simp]: "domain (fm x) = f ` J"
  unfolding fm_def by simp

lemma fm_restrict[simp]: "fm (restrict y J) = fm y"
  unfolding fm_def by (auto simp: compose_def inv intro: restrict_ext)

lemma fm_product:
  assumes "\<And>i. space (M i) = UNIV"
  shows "fm -` Pi' (f ` J) S \<inter> space (Pi\<^sub>M J M) = (\<Pi>\<^sub>E j \<in> J. S (f j))"
  using assms
  by (auto simp: inv fm_def compose_def space_PiM Pi'_def)

lemma fm_measurable:
  assumes "f ` J \<in> N"
  shows "fm \<in> measurable (Pi\<^sub>M J (\<lambda>_. M)) (Pi\<^sub>F N (\<lambda>_. M))"
  unfolding fm_def
proof (rule measurable_comp, rule measurable_compose_inv)
  show "finmap_of (f ` J) \<in> measurable (Pi\<^sub>M (f ` J) (\<lambda>_. M)) (PiF N (\<lambda>_. M)) "
    using assms by (intro measurable_finmap_of measurable_component_singleton) auto
qed (simp_all add: inv)

lemma proj_fm:
  assumes "x \<in> J"
  shows "fm m (f x) = m x"
  using assms by (auto simp: fm_def compose_def o_def inv)

lemma inj_on_compose_f': "inj_on (\<lambda>g. compose (f ` J) g f') (extensional J)"
proof (rule inj_on_inverseI)
  fix x::"'a \<Rightarrow> 'c" assume "x \<in> extensional J"
  thus "(\<lambda>x. compose J x f) (compose (f ` J) x f') = x"
    by (auto simp: compose_def inv extensional_def)
qed

lemma inj_on_fm:
  assumes "\<And>i. space (M i) = UNIV"
  shows "inj_on fm (space (Pi\<^sub>M J M))"
  using assms
  apply (auto simp: fm_def space_PiM PiE_def)
  apply (rule comp_inj_on)
  apply (rule inj_on_compose_f')
  apply (rule finmap_of_inj_on_extensional_finite)
  apply simp
  apply (auto)
  done

text {* to measure functions *}

definition "mf = (\<lambda>g. compose J g f) o proj"

lemma mf_fm:
  assumes "x \<in> space (Pi\<^sub>M J (\<lambda>_. M))"
  shows "mf (fm x) = x"
proof -
  have "mf (fm x) \<in> extensional J"
    by (auto simp: mf_def extensional_def compose_def)
  moreover
  have "x \<in> extensional J" using assms sets.sets_into_space
    by (force simp: space_PiM PiE_def)
  moreover
  { fix i assume "i \<in> J"
    hence "mf (fm x) i = x i"
      by (auto simp: inv mf_def compose_def fm_def)
  }
  ultimately
  show ?thesis by (rule extensionalityI)
qed

lemma mf_measurable:
  assumes "space M = UNIV"
  shows "mf \<in> measurable (PiF {f ` J} (\<lambda>_. M)) (PiM J (\<lambda>_. M))"
  unfolding mf_def
proof (rule measurable_comp, rule measurable_proj_PiM)
  show "(\<lambda>g. compose J g f) \<in> measurable (Pi\<^sub>M (f ` J) (\<lambda>x. M)) (Pi\<^sub>M J (\<lambda>_. M))"
    by (rule measurable_finmap_compose)
qed (auto simp add: space_PiM extensional_def assms)

lemma fm_image_measurable:
  assumes "space M = UNIV"
  assumes "X \<in> sets (Pi\<^sub>M J (\<lambda>_. M))"
  shows "fm ` X \<in> sets (PiF {f ` J} (\<lambda>_. M))"
proof -
  have "fm ` X = (mf) -` X \<inter> space (PiF {f ` J} (\<lambda>_. M))"
  proof safe
    fix x assume "x \<in> X"
    with mf_fm[of x] sets.sets_into_space[OF assms(2)] show "fm x \<in> mf -` X" by auto
    show "fm x \<in> space (PiF {f ` J} (\<lambda>_. M))" by (simp add: space_PiF assms)
  next
    fix y x
    assume x: "mf y \<in> X"
    assume y: "y \<in> space (PiF {f ` J} (\<lambda>_. M))"
    thus "y \<in> fm ` X"
      by (intro image_eqI[OF _ x], unfold finmap_eq_iff)
         (auto simp: space_PiF fm_def mf_def compose_def inv Pi'_def)
  qed
  also have "\<dots> \<in> sets (PiF {f ` J} (\<lambda>_. M))"
    using assms
    by (intro measurable_sets[OF mf_measurable]) auto
  finally show ?thesis .
qed

lemma fm_image_measurable_finite:
  assumes "space M = UNIV"
  assumes "X \<in> sets (Pi\<^sub>M J (\<lambda>_. M::'c measure))"
  shows "fm ` X \<in> sets (PiF (Collect finite) (\<lambda>_. M::'c measure))"
  using fm_image_measurable[OF assms]
  by (rule subspace_set_in_sets) (auto simp: finite_subset)

text {* measure on finmaps *}

definition "mapmeasure M N = distr M (PiF (Collect finite) N) (fm)"

lemma sets_mapmeasure[simp]: "sets (mapmeasure M N) = sets (PiF (Collect finite) N)"
  unfolding mapmeasure_def by simp

lemma space_mapmeasure[simp]: "space (mapmeasure M N) = space (PiF (Collect finite) N)"
  unfolding mapmeasure_def by simp

lemma mapmeasure_PiF:
  assumes s1: "space M = space (Pi\<^sub>M J (\<lambda>_. N))"
  assumes s2: "sets M = sets (Pi\<^sub>M J (\<lambda>_. N))"
  assumes "space N = UNIV"
  assumes "X \<in> sets (PiF (Collect finite) (\<lambda>_. N))"
  shows "emeasure (mapmeasure M (\<lambda>_. N)) X = emeasure M ((fm -` X \<inter> extensional J))"
  using assms
  by (auto simp: measurable_cong_sets[OF s2 refl] mapmeasure_def emeasure_distr
    fm_measurable space_PiM PiE_def)

lemma mapmeasure_PiM:
  fixes N::"'c measure"
  assumes s1: "space M = space (Pi\<^sub>M J (\<lambda>_. N))"
  assumes s2: "sets M = (Pi\<^sub>M J (\<lambda>_. N))"
  assumes N: "space N = UNIV"
  assumes X: "X \<in> sets M"
  shows "emeasure M X = emeasure (mapmeasure M (\<lambda>_. N)) (fm ` X)"
  unfolding mapmeasure_def
proof (subst emeasure_distr, subst measurable_cong_sets[OF s2 refl], rule fm_measurable)
  have "X \<subseteq> space (Pi\<^sub>M J (\<lambda>_. N))" using assms by (simp add: sets.sets_into_space)
  from assms inj_on_fm[of "\<lambda>_. N"] set_mp[OF this] have "fm -` fm ` X \<inter> space (Pi\<^sub>M J (\<lambda>_. N)) = X"
    by (auto simp: vimage_image_eq inj_on_def)
  thus "emeasure M X = emeasure M (fm -` fm ` X \<inter> space M)" using s1
    by simp
  show "fm ` X \<in> sets (PiF (Collect finite) (\<lambda>_. N))"
    by (rule fm_image_measurable_finite[OF N X[simplified s2]])
qed simp

end

end


theory axioms_base
imports remove_notation
begin

text{* Before we begin, a note on Isabelle's HOL.
       According to \cite[BlPoTr14]:

       \begin{quote}
       By HOL we mean classical higher-order logic with Hilbert choice,
       the axiom of infinity, and rank-1 polymorphism. HOL is based on
       Church's simple type theory [4]. It is the logic of Gordon's
       system of the same name [5] and of its many successors. HOL is
       roughly equivalent to ZF without support for classes and with the
       axiom of comprehension taking the place of the axiom of
       replacement.\\

       [...] Beyond  HOL,  Paulson  and  Grabczewski  [14]  have
       formalized  some  ordinal  and cardinal theory in Isabelle/ZF
       following the usual set-theoretic recipe, via the class of
       ordinals with membership. Their main objective was to formalize
       several alternative statements of the axiom of choice, and hence
       they invest care in avoiding this axiom for part of the cardinal
       theory. If our case, the Hilbert choice operator (effectively
       enforcing a bounded version of the axiom of choice) is pervasive.
       \end{quote}

       In fact we have the following lemma, to be found also in in
       "A Proof Assistant for Higher Order Logic" by Nikpow, Paulson,
       and Wenzel (page 87 of the 2015 version).
*}
(* WARNING: *)
lemma "(\<forall>x. \<exists>y. P x y) \<Longrightarrow> (\<exists>f. \<forall>z. P z (f(z)))"
using Hilbert_Choice.choice .

text{* This means that we should be very careful when using metafunctions.  *}

section{* NBG Set Theory *}

text{* This is NBG Set theory as presented in "Chapter 4: Axiomatic
       Set Theory" by Mendelson, but based on Isabelle's Higher
       Order Logic (HOL), instead of Mendelson's First Order Logic
       (FOL). According to Mendelson, this exposition follows
       "G\"{o}del's monograph to a great extent, though there will be
       some key differences". Phrases in quotation marks or in a
       quote environment (see e.g. below) will be phrases taken
       from the relevant text in Mendelson's book, unless stated
       otherwise.

       \begin{quote} NBG has a single predicate letter $A^2_2$,
       but no function letters or individual constants [...]
       is thought of as the membership relation.
       \end{quote}

       Since Isabelle is a typed system, we shall define first
       a primitive type ``Class'' for the objects of NBG Set Theory
       and denote the predicate letter $A^2_2$ by an Isabelle-
       -metafunction symbol, which is the canonical way to represent
       predicates in lambda calculus.
       *}

typedecl Class
axiomatization belongs :: "Class \<Rightarrow> Class \<Rightarrow> bool" (infixl "\<in>" 78)

abbreviation not_belongs (infixl "\<notin>" 78)
where "X \<notin> Y \<equiv> \<not>(X \<in> Y)" -- "non-membership"

text{* In Mendelson, extensionality for classes is in fact the
       definition of equality. Since we already have equality in
       HOL, and since we want to use the same equality, we define
       extensionality as usual. *}

(*   page 226 *)
axiomatization
  where extensionality: "(\<forall>Z::Class. (Z \<in> X \<longleftrightarrow> Z \<in> Y)) \<longleftrightarrow> (X = Y)"

definition
  subclass' :: "Class \<Rightarrow> Class \<Rightarrow> bool" (infixl "\<subseteq>" 78 )
where "(X \<subseteq> Y) =  (\<forall>Z. (Z \<in> X \<longrightarrow> Z \<in> Y))"

definition
  strict_subclass :: "Class \<Rightarrow> Class \<Rightarrow> bool" (infixl "\<subset>" 78)
where "(X \<subset> Y) = (X \<subseteq> Y \<and> X \<noteq> Y)"

text{* The following lemmas are Proposition 4.1 in Mendelson. *}

lemma Prop4_1_a: "(X=Y) \<longleftrightarrow> (X \<subseteq> Y \<and> Y \<subseteq> X)"
using extensionality subclass'_def by blast

text{* The following we get from HOL's definition of equality. *}

lemma Prop4_2_b: "X=X" ..

lemma Prop4_1_c: "(X=Y) \<longrightarrow> (Y=X)" by simp

lemma Prop4_1_d: "(X=Y) \<longrightarrow> ((Y=Z) \<longrightarrow> (X=Z))" by simp

lemma Prop4_1_e: "(X=Y) \<longrightarrow> (Z\<in>X \<longleftrightarrow> Z\<in>Y)"
by simp

text{* Sets are those classes that are members of another class.
       The predicate Mendelson uses is called $M$, but we
       use $set$. We
       shall reserve the symbol $\mathcal{V}$ for the universal
       class. *}

text {* In Mendelson, the set predicate is M( ) but we shall use set( ). *}
definition set_predicate :: "Class \<Rightarrow> bool" ("set")
where "set(X) \<longleftrightarrow> (\<exists>Y::Class. X \<in> Y)"
notation set_predicate ("((_) is a set)" 70)

abbreviation not_a_set ("((_) is not a set)" 70)
where "(X is not a set) \<equiv> \<not>(X is a set)"

definition proper_class_predicate:: "Class \<Rightarrow> bool" ("Pr")
where "Pr(X) \<longleftrightarrow> \<not>set(X)"

(* page 227 *)
text{* Exercise 4.1.: *}

lemma Ex4_1 [simp]: "Y \<in> X \<longrightarrow> set(Y)"
using set_predicate_def by blast

text{* At this point Mendelson introduces the equivalent of a
       quantifier over the type of Sets. We shall define the
       type Set as a subtype of Class. Before we can do that
       we need the set existence axiom and constants for the
       universe and for the empty set, since no type can be
       empty. We could also define a special quantifier over
       the type Set, but in the moment it doesn't seem
       necessary. *}

axiomatization
  universe :: Class ("\<V>")
  where universe: "X \<in> \<V> \<longleftrightarrow> set(X)"
    and set_existence: "\<exists>X. set(X)"

typedef
  Set = "Collect (\<lambda>A::Class. A \<in> \<V>)"
using set_existence universe by auto

declare [[coercion_enabled]] -- "Enables the coersion below."
declare [[coercion Rep_Set]] -- "It adds the necessary Rep_Set automatically"
setup_lifting type_definition_Set
    -- "something with Quotient_Set. Involves translations between Abs_Set and Rep_Set"
print_theorems

lemma obvious_set: "\<forall>x::Set. (x is a set)" using Rep_Set universe by auto

text{* Mendelson does not define the bounded quantifier "$\forall x \in Y$, but we do at this point
       to make the proofs more modern looking. *}

definition forall_in:: "Class \<Rightarrow> (Set \<Rightarrow> bool) \<Rightarrow> bool"
  where "forall_in A \<phi> \<longleftrightarrow> (\<forall>x::Set. x \<in> A \<longrightarrow> \<phi>(x))"

definition exists_in :: "Class \<Rightarrow> (Set \<Rightarrow> bool) \<Rightarrow> bool"
  where "exists_in A \<phi> \<longleftrightarrow> (\<exists>x::Set. x\<in>A \<and> \<phi>(x))"

text{* We denote these quantifiers as follows. *}

syntax (xsymbols)
  "_forall_in" :: "pttrn \<Rightarrow> Class \<Rightarrow> (Set \<Rightarrow> bool) => bool"
      ("(\<forall> _\<in>_./ _)" [0, 10] 10)
  "_exists_in" :: "pttrn \<Rightarrow> Class \<Rightarrow> (Set \<Rightarrow> bool) => bool"
      ("(\<exists> _\<in>_./ _)" [0, 10] 10)

translations
  "\<forall> x \<in> A. \<phi>" == "CONST forall_in A (\<lambda>x. \<phi>)"
  "\<exists> x \<in> A. \<phi>" == "CONST exists_in A (\<lambda>x. \<phi>)"

(* From here on we have both type Class and type Set, and bounded quantification. *)

text{* Exercise 4.2 in Mendelson *}
lemma Ex4_2:
  fixes X Y ::Class
  shows "(X=Y) \<longleftrightarrow> (\<forall>z::Set. (z \<in> X \<longleftrightarrow> z\<in>Y))"
by (metis Abs_Set_inverse extensionality mem_Collect_eq set_predicate_def universe)

lemmas set_extensionality = Ex4_2

text{* Mendelson's Axiom T is a theorem of HOL. *}
lemma axiom_T:
  fixes X1 X2 X3 :: Class
  shows "(X1 = X2) \<longrightarrow> (X1 \<in> X3 \<longleftrightarrow> X2 \<in> X3)" by simp

lemma Ex4_3: "set(Z) \<and> (Z = Y) \<longrightarrow> set(Y)" by auto

axiomatization
  upair :: "Set \<Rightarrow> Set \<Rightarrow> Set" ("(1{_, _})")
where pairing:
  "u \<in> {x,y}  \<longleftrightarrow> u = x \<or> u = y"

text{* We should introduce a new function symbol only after we
       prove that the unordered pair is unique, but then it
       should be defined as:\\
       texttt{definition upair : Set $\Rightarrow$ Set $\Rightarrow$
       Set" ("(1$\{$\_, \_$\}$)")}\\
       \texttt{where "$\{$x,y$\}$ == (THE v. $\forall$u::Set.
       (u$\in$v $\longleftrightarrow$ u = x $\lor$ u = y)"}\\
       Since we are uncertain about the ``THE''-operator, we
       introduced first the upair function symbol above, and
       we prove its uniqueness in the following lemma. The same
       happens with the empty set later. *}

text{* \textbf{FOMUS workshop exercise:} *}

lemma Ex4_4: "\<forall>x y::Set. \<forall>u::Set. ((\<forall>z. (z\<in>u \<longleftrightarrow> z=x \<or> z=y)) \<longrightarrow>
              (u = {x, y}))"

text{*
\begin{quote}
  This asserts that there is a unique set z, called the unordered pair of x and y,
  such that z has x and y as its only members. Use axiom P and the extensionality principle.
\end{quote}
*}
sorry

lemma Ex4_5: "\<forall>X :: Class. (X is a set) \<longleftrightarrow> (\<exists>y. X \<in> y)"
using set_predicate_def by simp

lemma Ex4_6: "\<exists> M :: Class. (Pr(X) \<longrightarrow> (\<not> (\<forall> Y Z:: Class. \<exists> W ::Class. \<forall> U :: Class.
                                           (U \<in> Z \<longleftrightarrow> (U = X) \<or> (U = Y)))))"
by (metis proper_class_predicate_def set_existence)

axiomatization empty :: Set ("\<emptyset>")
where empty_set: "\<forall>y. y \<notin> \<emptyset>"

(*   page 229 *)

(*   comments after null set definition contain lemmas to be formalised. *)

abbreviation singleton :: "Set \<Rightarrow> Set"  ("(1{ _})")
where "{x} \<equiv> {x, x}"

text{* \textbf{FOMUS workshop exercise:} *}

lemma Ex4_7_a: "{X, Y} = {Y, X}"
sorry

lemma Ex4_7_b: "\<forall>x y. ({x} = {y}) \<longrightarrow> (x = y)"
by (metis Rep_Set_inject pairing)

end


theory T100
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. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(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


(*  Title:      ZF/WF.thy
    Author:     Tobias Nipkow and Lawrence C Paulson
    Copyright   1994  University of Cambridge

Derived first for transitive relations, and finally for arbitrary WF relations
via wf_trancl and trans_trancl.

It is difficult to derive this general case directly, using r^+ instead of
r.  In is_recfun, the two occurrences of the relation must have the same
form.  Inserting r^+ in the_recfun or wftrec yields a recursion rule with
r^+ -`` {a} instead of r-``{a}.  This recursion rule is stronger in
principle, but harder to use, especially to prove wfrec_eclose_eq in
epsilon.ML.  Expanding out the definition of wftrec in wfrec would yield
a mess.
*)

section\<open>Well-Founded Recursion\<close>

theory WF imports Trancl begin

definition
  wf           :: "i=>o"  where
    (*r is a well-founded relation*)
    "wf(r) == \<forall>Z. Z=0 | (\<exists>x\<in>Z. \<forall>y. <y,x>:r \<longrightarrow> ~ y \<in> Z)"

definition
  wf_on        :: "[i,i]=>o"                      (\<open>wf[_]'(_')\<close>)  where
    (*r is well-founded on A*)
    "wf_on(A,r) == wf(r \<inter> A*A)"

definition
  is_recfun    :: "[i, i, [i,i]=>i, i] =>o"  where
    "is_recfun(r,a,H,f) == (f = (\<lambda>x\<in>r-``{a}. H(x, restrict(f, r-``{x}))))"

definition
  the_recfun   :: "[i, i, [i,i]=>i] =>i"  where
    "the_recfun(r,a,H) == (THE f. is_recfun(r,a,H,f))"

definition
  wftrec :: "[i, i, [i,i]=>i] =>i"  where
    "wftrec(r,a,H) == H(a, the_recfun(r,a,H))"

definition
  wfrec :: "[i, i, [i,i]=>i] =>i"  where
    (*public version.  Does not require r to be transitive*)
    "wfrec(r,a,H) == wftrec(r^+, a, %x f. H(x, restrict(f,r-``{x})))"

definition
  wfrec_on     :: "[i, i, i, [i,i]=>i] =>i"       (\<open>wfrec[_]'(_,_,_')\<close>)  where
    "wfrec[A](r,a,H) == wfrec(r \<inter> A*A, a, H)"

subsection\<open>Well-Founded Relations\<close>

subsubsection\<open>Equivalences between \<^term>\<open>wf\<close> and \<^term>\<open>wf_on\<close>\<close>

lemma wf_imp_wf_on: "wf(r) ==> wf[A](r)"
by (unfold wf_def wf_on_def, force)

lemma wf_on_imp_wf: "[|wf[A](r); r \<subseteq> A*A|] ==> wf(r)"
by (simp add: wf_on_def subset_Int_iff)

lemma wf_on_field_imp_wf: "wf[field(r)](r) ==> wf(r)"
by (unfold wf_def wf_on_def, fast)

lemma wf_iff_wf_on_field: "wf(r) \<longleftrightarrow> wf[field(r)](r)"
by (blast intro: wf_imp_wf_on wf_on_field_imp_wf)

lemma wf_on_subset_A: "[| wf[A](r);  B<=A |] ==> wf[B](r)"
by (unfold wf_on_def wf_def, fast)

lemma wf_on_subset_r: "[| wf[A](r); s<=r |] ==> wf[A](s)"
by (unfold wf_on_def wf_def, fast)

lemma wf_subset: "[|wf(s); r<=s|] ==> wf(r)"
by (simp add: wf_def, fast)

subsubsection\<open>Introduction Rules for \<^term>\<open>wf_on\<close>\<close>

text\<open>If every non-empty subset of \<^term>\<open>A\<close> has an \<^term>\<open>r\<close>-minimal element
   then we have \<^term>\<open>wf[A](r)\<close>.\<close>
lemma wf_onI:
 assumes prem: "!!Z u. [| Z<=A;  u \<in> Z;  \<forall>x\<in>Z. \<exists>y\<in>Z. <y,x>:r |] ==> False"
 shows         "wf[A](r)"
apply (unfold wf_on_def wf_def)
apply (rule equals0I [THEN disjCI, THEN allI])
apply (rule_tac Z = Z in prem, blast+)
done

text\<open>If \<^term>\<open>r\<close> allows well-founded induction over \<^term>\<open>A\<close>
   then we have \<^term>\<open>wf[A](r)\<close>.   Premise is equivalent to
  \<^prop>\<open>!!B. \<forall>x\<in>A. (\<forall>y. <y,x>: r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B ==> A<=B\<close>\<close>
lemma wf_onI2:
 assumes prem: "!!y B. [| \<forall>x\<in>A. (\<forall>y\<in>A. <y,x>:r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B;   y \<in> A |]
                       ==> y \<in> B"
 shows         "wf[A](r)"
apply (rule wf_onI)
apply (rule_tac c=u in prem [THEN DiffE])
  prefer 3 apply blast
 apply fast+
done

subsubsection\<open>Well-founded Induction\<close>

text\<open>Consider the least \<^term>\<open>z\<close> in \<^term>\<open>domain(r)\<close> such that
  \<^term>\<open>P(z)\<close> does not hold...\<close>
lemma wf_induct_raw:
    "[| wf(r);
        !!x.[| \<forall>y. <y,x>: r \<longrightarrow> P(y) |] ==> P(x) |]
     ==> P(a)"
apply (unfold wf_def)
apply (erule_tac x = "{z \<in> domain(r). ~ P(z)}" in allE)
apply blast
done

lemmas wf_induct = wf_induct_raw [rule_format, consumes 1, case_names step, induct set: wf]

text\<open>The form of this rule is designed to match \<open>wfI\<close>\<close>
lemma wf_induct2:
    "[| wf(r);  a \<in> A;  field(r)<=A;
        !!x.[| x \<in> A;  \<forall>y. <y,x>: r \<longrightarrow> P(y) |] ==> P(x) |]
     ==>  P(a)"
apply (erule_tac P="a \<in> A" in rev_mp)
apply (erule_tac a=a in wf_induct, blast)
done

lemma field_Int_square: "field(r \<inter> A*A) \<subseteq> A"
by blast

lemma wf_on_induct_raw [consumes 2, induct set: wf_on]:
    "[| wf[A](r);  a \<in> A;
        !!x.[| x \<in> A;  \<forall>y\<in>A. <y,x>: r \<longrightarrow> P(y) |] ==> P(x)
     |]  ==>  P(a)"
apply (unfold wf_on_def)
apply (erule wf_induct2, assumption)
apply (rule field_Int_square, blast)
done

lemma wf_on_induct [consumes 2, case_names step, induct set: wf_on]:
  "wf[A](r) \<Longrightarrow> a \<in> A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> (\<And>y. y \<in> A \<Longrightarrow> \<langle>y, x\<rangle> \<in> r \<Longrightarrow> P(y)) \<Longrightarrow> P(x)) \<Longrightarrow> P(a)"
  using wf_on_induct_raw [of A r a P] by simp

text\<open>If \<^term>\<open>r\<close> allows well-founded induction
   then we have \<^term>\<open>wf(r)\<close>.\<close>
lemma wfI:
    "[| field(r)<=A;
        !!y B. [| \<forall>x\<in>A. (\<forall>y\<in>A. <y,x>:r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B;  y \<in> A|]
               ==> y \<in> B |]
     ==>  wf(r)"
apply (rule wf_on_subset_A [THEN wf_on_field_imp_wf])
apply (rule wf_onI2)
 prefer 2 apply blast
apply blast
done

subsection\<open>Basic Properties of Well-Founded Relations\<close>

lemma wf_not_refl: "wf(r) ==> <a,a> \<notin> r"
by (erule_tac a=a in wf_induct, blast)

lemma wf_not_sym [rule_format]: "wf(r) ==> \<forall>x. <a,x>:r \<longrightarrow> <x,a> \<notin> r"
by (erule_tac a=a in wf_induct, blast)

(* @{term"[| wf(r);  <a,x> \<in> r;  ~P ==> <x,a> \<in> r |] ==> P"} *)
lemmas wf_asym = wf_not_sym [THEN swap]

lemma wf_on_not_refl: "[| wf[A](r); a \<in> A |] ==> <a,a> \<notin> r"
by (erule_tac a=a in wf_on_induct, assumption, blast)

lemma wf_on_not_sym:
     "[| wf[A](r);  a \<in> A |] ==> (\<And>b. b\<in>A \<Longrightarrow> <a,b>:r \<Longrightarrow> <b,a>\<notin>r)"
apply (atomize (full), intro impI)
apply (erule_tac a=a in wf_on_induct, assumption, blast)
done

lemma wf_on_asym:
     "[| wf[A](r);  ~Z ==> <a,b> \<in> r;
         <b,a> \<notin> r ==> Z; ~Z ==> a \<in> A; ~Z ==> b \<in> A |] ==> Z"
by (blast dest: wf_on_not_sym)

(*Needed to prove well_ordI.  Could also reason that wf[A](r) means
  wf(r \<inter> A*A);  thus wf( (r \<inter> A*A)^+ ) and use wf_not_refl *)
lemma wf_on_chain3:
     "[| wf[A](r); <a,b>:r; <b,c>:r; <c,a>:r; a \<in> A; b \<in> A; c \<in> A |] ==> P"
apply (subgoal_tac "\<forall>y\<in>A. \<forall>z\<in>A. <a,y>:r \<longrightarrow> <y,z>:r \<longrightarrow> <z,a>:r \<longrightarrow> P",
       blast)
apply (erule_tac a=a in wf_on_induct, assumption, blast)
done

text\<open>transitive closure of a WF relation is WF provided
  \<^term>\<open>A\<close> is downward closed\<close>
lemma wf_on_trancl:
    "[| wf[A](r);  r-``A \<subseteq> A |] ==> wf[A](r^+)"
apply (rule wf_onI2)
apply (frule bspec [THEN mp], assumption+)
apply (erule_tac a = y in wf_on_induct, assumption)
apply (blast elim: tranclE, blast)
done

lemma wf_trancl: "wf(r) ==> wf(r^+)"
apply (simp add: wf_iff_wf_on_field)
apply (rule wf_on_subset_A)
 apply (erule wf_on_trancl)
 apply blast
apply (rule trancl_type [THEN field_rel_subset])
done

text\<open>\<^term>\<open>r-``{a}\<close> is the set of everything under \<^term>\<open>a\<close> in \<^term>\<open>r\<close>\<close>

lemmas underI = vimage_singleton_iff [THEN iffD2]
lemmas underD = vimage_singleton_iff [THEN iffD1]

subsection\<open>The Predicate \<^term>\<open>is_recfun\<close>\<close>

lemma is_recfun_type: "is_recfun(r,a,H,f) ==> f \<in> r-``{a} -> range(f)"
apply (unfold is_recfun_def)
apply (erule ssubst)
apply (rule lamI [THEN rangeI, THEN lam_type], assumption)
done

lemmas is_recfun_imp_function = is_recfun_type [THEN fun_is_function]

lemma apply_recfun:
    "[| is_recfun(r,a,H,f); <x,a>:r |] ==> f`x = H(x, restrict(f,r-``{x}))"
apply (unfold is_recfun_def)
  txt\<open>replace f only on the left-hand side\<close>
apply (erule_tac P = "%x. t(x) = u" for t u in ssubst)
apply (simp add: underI)
done

lemma is_recfun_equal [rule_format]:
     "[| wf(r);  trans(r);  is_recfun(r,a,H,f);  is_recfun(r,b,H,g) |]
      ==> <x,a>:r \<longrightarrow> <x,b>:r \<longrightarrow> f`x=g`x"
apply (frule_tac f = f in is_recfun_type)
apply (frule_tac f = g in is_recfun_type)
apply (simp add: is_recfun_def)
apply (erule_tac a=x in wf_induct)
apply (intro impI)
apply (elim ssubst)
apply (simp (no_asm_simp) add: vimage_singleton_iff restrict_def)
apply (rule_tac t = "%z. H (x, z)" for x in subst_context)
apply (subgoal_tac "\<forall>y\<in>r-``{x}. \<forall>z. <y,z>:f \<longleftrightarrow> <y,z>:g")
 apply (blast dest: transD)
apply (simp add: apply_iff)
apply (blast dest: transD intro: sym)
done

lemma is_recfun_cut:
     "[| wf(r);  trans(r);
         is_recfun(r,a,H,f);  is_recfun(r,b,H,g);  <b,a>:r |]
      ==> restrict(f, r-``{b}) = g"
apply (frule_tac f = f in is_recfun_type)
apply (rule fun_extension)
  apply (blast dest: transD intro: restrict_type2)
 apply (erule is_recfun_type, simp)
apply (blast dest: transD intro: is_recfun_equal)
done

subsection\<open>Recursion: Main Existence Lemma\<close>

lemma is_recfun_functional:
     "[| wf(r); trans(r); is_recfun(r,a,H,f); is_recfun(r,a,H,g) |]  ==>  f=g"
by (blast intro: fun_extension is_recfun_type is_recfun_equal)

lemma the_recfun_eq:
    "[| is_recfun(r,a,H,f);  wf(r);  trans(r) |] ==> the_recfun(r,a,H) = f"
apply (unfold the_recfun_def)
apply (blast intro: is_recfun_functional)
done

(*If some f satisfies is_recfun(r,a,H,-) then so does the_recfun(r,a,H) *)
lemma is_the_recfun:
    "[| is_recfun(r,a,H,f);  wf(r);  trans(r) |]
     ==> is_recfun(r, a, H, the_recfun(r,a,H))"
by (simp add: the_recfun_eq)

lemma unfold_the_recfun:
     "[| wf(r);  trans(r) |] ==> is_recfun(r, a, H, the_recfun(r,a,H))"
apply (rule_tac a=a in wf_induct, assumption)
apply (rename_tac a1)
apply (rule_tac f = "\<lambda>y\<in>r-``{a1}. wftrec (r,y,H)" in is_the_recfun)
  apply typecheck
apply (unfold is_recfun_def wftrec_def)
  \<comment> \<open>Applying the substitution: must keep the quantified assumption!\<close>
apply (rule lam_cong [OF refl])
apply (drule underD)
apply (fold is_recfun_def)
apply (rule_tac t = "%z. H(x, z)" for x in subst_context)
apply (rule fun_extension)
  apply (blast intro: is_recfun_type)
 apply (rule lam_type [THEN restrict_type2])
  apply blast
 apply (blast dest: transD)
apply atomize
apply (frule spec [THEN mp], assumption)
apply (subgoal_tac "<xa,a1> \<in> r")
 apply (drule_tac x1 = xa in spec [THEN mp], assumption)
apply (simp add: vimage_singleton_iff
                 apply_recfun is_recfun_cut)
apply (blast dest: transD)
done

subsection\<open>Unfolding \<^term>\<open>wftrec(r,a,H)\<close>\<close>

lemma the_recfun_cut:
     "[| wf(r);  trans(r);  <b,a>:r |]
      ==> restrict(the_recfun(r,a,H), r-``{b}) = the_recfun(r,b,H)"
by (blast intro: is_recfun_cut unfold_the_recfun)

(*NOT SUITABLE FOR REWRITING: it is recursive!*)
lemma wftrec:
    "[| wf(r);  trans(r) |] ==>
          wftrec(r,a,H) = H(a, \<lambda>x\<in>r-``{a}. wftrec(r,x,H))"
apply (unfold wftrec_def)
apply (subst unfold_the_recfun [unfolded is_recfun_def])
apply (simp_all add: vimage_singleton_iff [THEN iff_sym] the_recfun_cut)
done

subsubsection\<open>Removal of the Premise \<^term>\<open>trans(r)\<close>\<close>

(*NOT SUITABLE FOR REWRITING: it is recursive!*)
lemma wfrec:
    "wf(r) ==> wfrec(r,a,H) = H(a, \<lambda>x\<in>r-``{a}. wfrec(r,x,H))"
apply (unfold wfrec_def)
apply (erule wf_trancl [THEN wftrec, THEN ssubst])
 apply (rule trans_trancl)
apply (rule vimage_pair_mono [THEN restrict_lam_eq, THEN subst_context])
 apply (erule r_into_trancl)
apply (rule subset_refl)
done

(*This form avoids giant explosions in proofs.  NOTE USE OF == *)
lemma def_wfrec:
    "[| !!x. h(x)==wfrec(r,x,H);  wf(r) |] ==>
     h(a) = H(a, \<lambda>x\<in>r-``{a}. h(x))"
apply simp
apply (elim wfrec)
done

lemma wfrec_type:
    "[| wf(r);  a \<in> A;  field(r)<=A;
        !!x u. [| x \<in> A;  u \<in> Pi(r-``{x}, B) |] ==> H(x,u) \<in> B(x)
     |] ==> wfrec(r,a,H) \<in> B(a)"
apply (rule_tac a = a in wf_induct2, assumption+)
apply (subst wfrec, assumption)
apply (simp add: lam_type underD)
done

lemma wfrec_on:
 "[| wf[A](r);  a \<in> A |] ==>
         wfrec[A](r,a,H) = H(a, \<lambda>x\<in>(r-``{a}) \<inter> A. wfrec[A](r,x,H))"
apply (unfold wf_on_def wfrec_on_def)
apply (erule wfrec [THEN trans])
apply (simp add: vimage_Int_square cons_subset_iff)
done

text\<open>Minimal-element characterization of well-foundedness\<close>
lemma wf_eq_minimal:
     "wf(r) \<longleftrightarrow> (\<forall>Q x. x \<in> Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. <y,z>:r \<longrightarrow> y\<notin>Q))"
by (unfold wf_def, blast)

end


subsection\<open>Converting between Resolution and SC proofs\<close>
theory LSC_Resolution
imports LSC Resolution
begin

lemma literal_subset_sandwich:
  assumes "is_lit_plus F" "cnf F = {C}" "R \<subseteq> C"
  shows "R = \<box> \<or> R = C"
using assms by(cases F rule: is_lit_plus.cases; simp) blast+ (* proof somewhat strange internally\<dots> *)

text\<open>Proof following Gallier~\<^cite>\<open>"gallier2015logic"\<close>.\<close>
theorem CSC_Resolution_pre: "\<Gamma> \<Rightarrow>\<^sub>n \<Longrightarrow> \<forall>\<gamma> \<in> set_mset \<Gamma>. is_cnf \<gamma> \<Longrightarrow> (\<Union>(cnf ` set_mset \<Gamma>)) \<turnstile> \<box>"
proof(induction rule: LSC.induct)
  case (Ax k \<Gamma>)
  let ?s = "\<Union>(cnf ` set_mset (\<^bold>\<not> (Atom k), Atom k, \<Gamma>))"
  have "?s \<turnstile> {k\<^sup>+}" "?s \<turnstile> {k\<inverse>}" using Resolution.Ass[where 'a='a] by simp_all
  from Resolution.R[OF this, of k]
  have "?s \<turnstile> \<box>" by simp
  thus ?case by simp
next
  case (BotL \<Gamma>) thus ?case by(simp add: Ass)
next
  case (AndL F G \<Gamma>)
  hence "\<Union>(cnf ` set_mset (F, G, \<Gamma>)) \<turnstile> \<box>" by simp
  thus ?case by(simp add: Un_left_commute sup.assoc)
next
  (* The idea for the whole trickery with F being a literal (is_disj has to only allows right deep formulas)
    and the sandwiching is from Gallier, but mentioned there only in one little sentence. *)
  case (OrL F \<Gamma> G)
  hence "is_cnf (F \<^bold>\<or> G)" by simp
  hence d: "is_disj (F \<^bold>\<or> G)" by simp
  hence db: "is_disj F" "is_lit_plus F" "is_disj G" by (-, cases F) simp_all
  hence "is_cnf F \<and> is_cnf G" by(cases F; cases G; simp)
  with OrL have IH: "(\<Union>(cnf ` set_mset (F, \<Gamma>))) \<turnstile> \<box>" "(\<Union>(cnf ` set_mset (G, \<Gamma>))) \<turnstile> \<box>" by simp_all
  let ?\<Gamma> = "(\<Union>(cnf ` set_mset \<Gamma>))"
  from IH have IH_readable: "cnf F \<union> ?\<Gamma> \<turnstile> \<box>" "cnf G \<union> ?\<Gamma> \<turnstile> \<box>" by auto
  show ?case proof(cases "cnf F = {} \<or> cnf G = {}")
    case True
    hence "cnf (F \<^bold>\<or> G) = {}" by auto
    thus ?thesis using True IH by auto
  next
    case False
    then obtain S T where ST: "cnf F = {S}" "cnf G = {T}"
      using cnf_disj_ex db(1,3) (* try applying meson here. It's weird. and sledgehammer even suggests it. *) by metis
    (* hint: card S \<le> 1 *)
    hence R: "cnf (F \<^bold>\<or> G) = { S \<union> T }" by simp
    have "\<lbrakk>S\<triangleright>?\<Gamma> \<turnstile> \<box>; T\<triangleright>?\<Gamma> \<turnstile> \<box>\<rbrakk> \<Longrightarrow> S \<union> T\<triangleright> ?\<Gamma> \<turnstile> \<box>" proof -
      assume s: "S\<triangleright>?\<Gamma> \<turnstile> \<box>" and t: "T\<triangleright>?\<Gamma> \<turnstile> \<box>"
      hence s_w: "S \<triangleright> S \<union> T \<triangleright> ?\<Gamma> \<turnstile> \<box>" using Resolution_weaken by (metis insert_commute insert_is_Un)
      note Resolution_taint_assumptions[of "{T}" ?\<Gamma> "\<box>" S] t
      then obtain R where R: "S \<union> T \<triangleright> \<Union>(cnf ` set_mset \<Gamma>) \<turnstile> R" "R\<subseteq>S" by (auto simp: Un_commute)
      show ?thesis using literal_subset_sandwich[OF db(2) ST(1) R(2)] proof
        assume "R = \<box>" thus ?thesis using R(1) by blast
      next
        from Resolution_unnecessary[where T="{_}", simplified] R(1)
        have "(R \<triangleright> S \<union> T \<triangleright> ?\<Gamma> \<turnstile> \<box>) = (S \<union> T \<triangleright> ?\<Gamma> \<turnstile> \<box>)"  .
        moreover assume "R = S"
        ultimately show ?thesis using s_w by simp
      qed
    qed
    thus ?thesis using IH ST R by simp
  qed
  hence case_readable: "cnf (F \<^bold>\<or> G) \<union> ?\<Gamma> \<turnstile> \<box>" by auto
qed auto

corollary LSC_Resolution:
  assumes "\<Gamma> \<Rightarrow>\<^sub>n"
  shows "(\<Union>(cnf ` nnf ` set_mset \<Gamma>)) \<turnstile> \<box>"
proof -
  from assms
  have "image_mset nnf \<Gamma> \<Rightarrow>\<^sub>n" by (simp add: LSC_NNF)
  from LSC_cnf[OF this]
  have "image_mset (cnf_form_of \<circ> nnf) \<Gamma> \<Rightarrow>\<^sub>n" by(simp add: image_mset.compositionality is_nnf_nnf)
  moreover have "\<forall>\<gamma> \<in> set_mset (image_mset (cnf_form_of \<circ> nnf) \<Gamma>). is_cnf \<gamma>"
    using cnf_form_of_is[where 'a='a, OF is_nnf_nnf] by simp
  moreover note CSC_Resolution_pre
  ultimately have "\<Union>(cnf ` set_mset (image_mset (cnf_form_of \<circ> nnf) \<Gamma>)) \<turnstile> \<box>"  by blast
  hence "\<Union>((\<lambda>F. cnf (cnf_form_of (nnf F))) ` set_mset \<Gamma>) \<turnstile> \<box>" by simp
  thus ?thesis unfolding cnf_cnf[OF is_nnf_nnf] by simp
qed

corollary SC_Resolution:
  assumes "\<Gamma> \<Rightarrow> {#}"
  shows "(\<Union>(cnf ` nnf ` set_mset \<Gamma>)) \<turnstile> \<box>"
proof -
  from assms have "image_mset nnf \<Gamma> \<Rightarrow>\<^sub>n" by (simp add: LSC_NNF SC_LSC)
  hence "\<Union>(cnf` nnf ` set_mset (image_mset nnf \<Gamma>)) \<turnstile> \<box>" using LSC_Resolution by blast
  thus ?thesis using is_nnf_nnf_id[where 'a='a] is_nnf_nnf[where 'a='a] by auto
qed

(* Gallier just goes "Any resolution refutation can be transformed to a derivation in SCNF'"
   But we don't know what a resolution refutation is, inductively speaking. *)
(* would have been a bit nicer with orderings on formula to convert mset \<rightarrow> list *)
lemma Resolution_LSC_pre:
  assumes "S \<turnstile> R"
  assumes "finite R"
  assumes "finite S" "Ball S finite"
  shows "\<exists>S' R'. \<forall>\<Gamma>. set R' = R \<and> set (map set S') = S \<and>
    (disj_of_clause R', {#disj_of_clause c. c \<in># mset S'#} + \<Gamma> \<Rightarrow>\<^sub>n \<longrightarrow> {#disj_of_clause c. c \<in># mset S'#} + \<Gamma> \<Rightarrow>\<^sub>n)"
(* order of quantifiers is important here\<dots> *)
using assms proof(induction S R rule: Resolution.induct)
  case (Ass F S)
  (* Idea: we don't just obtain an S', we obtain an S' that contains R (and not just some reordering of it) *)
  define Sm where "Sm = S - {F}"
  hence Sm: "S = F\<triangleright>Sm" "F \<notin> Sm" using Ass by fast+ (* try doing this with obtain\<dots> *)
  with Ass have fsm: "finite Sm" "Ball Sm finite" by auto
  then obtain Sm' where "Sm = set (map set Sm')" by (metis (full_types) ex_map_conv finite_list)
  moreover obtain R' where [simp]: "F = set R'" using Ass finite_list by blast
  ultimately have S: "S = set (map set (R'#Sm'))" unfolding Sm by simp
  show ?case
    using LSC_Contract[where 'a='a]
    by(intro exI[where x="R'#Sm'"] exI[where x=R']) (simp add: S add_ac)
  (* this was the base case. ugh. *)
next
  case (R S F G k)
  from R.prems have fin: "finite F" "finite G" by simp_all
  from R.IH(1)[OF fin(1) R.prems(2,3)] obtain FR FS where IHF:
    "set FR = F" "set (map set FS) = S"
    "\<And>\<Gamma> GS. (disj_of_clause FR, image_mset disj_of_clause (mset (FS@GS)) + \<Gamma> \<Rightarrow>\<^sub>n
      \<Longrightarrow> image_mset disj_of_clause (mset (FS@GS)) + \<Gamma> \<Rightarrow>\<^sub>n)"
      by simp (metis add.assoc)
  from R.IH(2)[OF fin(2) R.prems(2,3)] obtain GR GS where IHG:
    "set GR = G" "set (map set GS) = S"
    "\<And>\<Gamma> HS. (disj_of_clause GR, image_mset disj_of_clause (mset (GS@HS)) + \<Gamma> \<Rightarrow>\<^sub>n
      \<Longrightarrow> image_mset disj_of_clause (mset (GS@HS)) + \<Gamma> \<Rightarrow>\<^sub>n)"
    by simp (metis add.assoc)
  have IH: "image_mset disj_of_clause (mset (FS @ GS)) + \<Gamma> \<Rightarrow>\<^sub>n"
    if "disj_of_clause FR, disj_of_clause GR, image_mset disj_of_clause (mset (FS @ GS)) + \<Gamma> \<Rightarrow>\<^sub>n"
    for \<Gamma> using IHF(3)[of GS \<Gamma>] IHG(3)[of FS "disj_of_clause FR, \<Gamma>"] that
    by(simp add: add_mset_commute add_ac)
  show ?case
    apply(intro exI[where x="FS @ GS"] exI[where x="removeAll (k\<^sup>+) FR @ removeAll (k\<inverse>) GR"] allI impI conjI)
      apply(simp add: IHF IHG;fail)
     apply(insert IHF IHG; simp;fail)
    apply(intro IH)
    apply(auto dest!: LSC_Sim_resolution_la simp add: IHF IHG R.hyps)
  done
qed

lemma Resolution_LSC_pre_nodisj: (* I've tried showing this directly instead of Resolution_LSC_pre, but that is surprisingly painful. *)
  assumes "S \<turnstile> R"
  assumes "finite R"
  assumes "finite S" "Ball S finite"
  shows "\<exists>S' R'. \<forall>\<Gamma>. is_nnf_mset \<Gamma> \<longrightarrow> is_disj R' \<and> is_nnf S' \<and> cnf R' = {R} \<and> cnf S' \<subseteq> S \<and>
    (R', S', \<Gamma> \<Rightarrow>\<^sub>n \<longrightarrow> S', \<Gamma> \<Rightarrow>\<^sub>n)"
proof -
  have mehorder: "F, \<^bold>\<And>G, \<Gamma> = \<^bold>\<And>G, F, \<Gamma>" for F G \<Gamma> by(simp add: add_ac)
  from Resolution_LSC_pre[where 'a='a,OF assms]
  obtain S' R' where o: "\<And>\<Gamma>. is_nnf_mset \<Gamma> \<Longrightarrow> set R' = R \<and> set (map set S') = S \<and>
  (disj_of_clause R', image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n \<longrightarrow> image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n)"
    by blast
  hence p: "is_nnf_mset \<Gamma> \<Longrightarrow> (disj_of_clause R', image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n \<Longrightarrow> image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n)"
    for \<Gamma> by blast
  show ?thesis
    apply(rule exI[where x="\<^bold>\<And>map disj_of_clause S'"])
    apply(rule exI[where x="disj_of_clause R'"])
    apply safe
         apply(intro disj_of_clause_is;fail)
        apply(simp add: cnf_disj o; fail)+
     subgoal using o by(fastforce simp add: cnf_BigAnd cnf_disj)
    subgoal for \<Gamma>
      apply(frule p)
       apply(unfold mehorder)
       apply(drule LSC_BigAndL_inv)
         apply(simp;fail)+
      by (simp add: LSC_BigAndL)
    done
qed

corollary Resolution_LSC1:
  assumes "S \<turnstile> \<box>"
  shows "\<exists>F. is_nnf F \<and> cnf F \<subseteq> S \<and> {#F#} \<Rightarrow>\<^sub>n"
proof -
  have *: "{f \<union> g |f g. f \<in> F \<and> g \<in> G} = {\<box>} \<Longrightarrow> F = {\<box>}" for F G
  proof (rule ccontr)
    assume m: "{f \<union> g |f g. f \<in> F \<and> g \<in> G} = {\<box>}"
    assume "F \<noteq> {\<box>}"
    hence "F = {} \<or> (\<exists>E. E \<in> F \<and> E \<noteq> \<box>)" by blast
    thus False proof
      assume "F = {}"
      with m show False by simp
    next
      assume "\<exists>E. E \<in> F \<and> E \<noteq> \<box>"
      then obtain E where E: "E \<in> F \<and> E \<noteq> \<box>" ..
      show False proof cases
        assume "G = {}" with m show False by simp
      next
        assume "G \<noteq> {}"
        then obtain D where "D \<in> G" by blast
        with E have "E \<union> D \<in> {f \<union> g |f g. f \<in> F \<and> g \<in> G}" by blast
        with m E show False by simp
      qed
    qed
  qed
  have *: "F = {\<box>} \<and> G = {\<box>}" if "{f \<union> g |f g. f \<in> F \<and> g \<in> G} = {\<box>}" for F G
  proof (intro conjI)
    show "G = {\<box>}"
      apply(rule *[of G F])
      apply(subst that[symmetric])
    by blast
  qed (rule *[OF that])
  have *: "is_nnf F \<Longrightarrow> is_nnf_mset \<Gamma> \<Longrightarrow> cnf F = {\<box>} \<Longrightarrow> F,\<Gamma> \<Rightarrow>\<^sub>n" for F \<Gamma>
    apply(induction F rule: cnf.induct; simp)
      apply blast
     apply (metis LSC.LSC.AndL LSC_weaken add_mset_commute singleton_Un_iff)
    apply(drule *; simp add: LSC.LSC.OrL)
  done
  from Resolution_useless_infinite[OF assms]
  obtain S' where su: "S'\<subseteq>S" and fin: "finite S'" "Ball S' finite" and pr: "(S' \<turnstile> \<box>)" by blast
  from Resolution_LSC_pre_nodisj[OF pr finite.emptyI fin]
  obtain S'' where "is_nnf S''" "cnf S'' \<subseteq> S'" "{# S'' #} \<Rightarrow>\<^sub>n"
    using * [OF disj_is_nnf, of _ \<open>{#}\<close>]
    by (metis LSC_weaken add_mset_commute empty_iff set_mset_empty)
  with su show ?thesis by blast
qed

corollary Resolution_SC1:
  assumes "S \<turnstile> \<box>"
  shows "\<exists>F. cnf (nnf F) \<subseteq> S \<and> {#F#} \<Rightarrow> {#}"
  apply(insert Resolution_LSC1[OF assms])
  apply(elim ex_forward)
  apply(elim conjE; intro conjI)
   subgoal by(subst is_nnf_nnf_id; assumption)
  apply(unfold SC_LSC)
  subgoal by (simp;fail)
done

(* really, these proofs have to do with sets, multisets and lists.
If I'd introduce finite sets somehow, the chaos would be perfect.
I want out.
*)

end