theory T30
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(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, 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. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, 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. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


section \<open>Implementation\<close>

theory HMM_Implementation
  imports
    Hidden_Markov_Model
    "Monad_Memo_DP.State_Main"
    Simple_List_Memory
begin

subsection \<open>The Forward Algorithm\<close>

locale HMM4 = HMM3 _ _ _ \<O>\<^sub>s \<K> for \<O>\<^sub>s :: "'t set" and \<K> :: "'s \<Rightarrow> 's pmf" +
  assumes states_distinct: "distinct state_list"

context HMM3_defs
begin

context
  fixes os :: "'t iarray"
begin

text \<open>
  Alternative definition using indices into the list of states.
  The list of states is implemented as an immutable array for better performance.
\<close>

function forward_ix_rec where
  "forward_ix_rec s t_end n = (if n \<ge> IArray.length os then indicator {t_end} s else
    (\<Sum>t \<leftarrow> state_list.
      ennreal (pmf (\<O> t) (os !! n)) * ennreal (pmf (\<K> s) t) * forward_ix_rec t t_end (n + 1)))
  "
  by auto
termination
  by (relation "Wellfounded.measure (\<lambda>(_,_,n). IArray.length os - n)") auto

text \<open>Memoization\<close>

memoize_fun forward_ix\<^sub>m: forward_ix_rec
  with_memory dp_consistency_list
  monadifies (state) forward_ix_rec.simps[unfolded Let_def]

memoize_correct
  by memoize_prover

text \<open>The main theorems generated by memoization.\<close>
context
  includes state_monad_syntax
begin
thm forward_ix\<^sub>m'.simps forward_ix\<^sub>m_def
thm forward_ix\<^sub>m.memoized_correct
end

end (* Fixed IArray *)

definition
  "forward_ix os = forward_ix_rec (IArray os)"

definition
  "likelihood_compute s os \<equiv>
    if s \<in> set state_list then Some (\<Sum>t \<leftarrow> state_list. forward s t os) else None"

end (* HMM3 Defs *)

text \<open>Correctness of the alternative definition.\<close>

lemma (in HMM3) forward_ix_drop_one:
  "forward_ix (o # os) s t (n + 1) = forward_ix os s t n"
  by (induction "length os - n" arbitrary: s n; simp add: forward_ix_def)

lemma (in HMM4) forward_ix_forward:
  "forward_ix os s t 0 = forward s t os"
  unfolding forward_ix_def
proof (induction os arbitrary: s)
  case Nil
  then show ?case
    by simp
next
  case (Cons o os)
  show ?case
    using forward_ix_drop_one[unfolded forward_ix_def] states_distinct
    by (subst forward.simps, subst forward_ix_rec.simps)
       (simp add: Cons.IH state_list_\<S> sum_list_distinct_conv_sum_set
             del: forward_ix_rec.simps forward.simps
       )
qed

text \<open>
  Instructs the code generator to use this equation instead to execute \<open>forward\<close>.
  Uses the memoized version of \<open>forward_ix\<close>.
\<close>
lemma (in HMM4) forward_code [code]:
  "forward s t os = fst (run_state (forward_ix\<^sub>m' (IArray os) s t 0) [])"
  by (simp only:
      forward_ix_def forward_ix\<^sub>m.memoized_correct forward_ix_forward[symmetric]
      states_distinct
     )

theorem (in HMM4) likelihood_compute:
  "likelihood_compute s os = Some x \<longleftrightarrow> s \<in> \<S> \<and> x = likelihood s os"
  unfolding likelihood_compute_def
  by (auto simp: states_distinct state_list_\<S> sum_list_distinct_conv_sum_set likelihood_forward)

subsection \<open>The Viterbi Algorithm\<close>

context HMM3_defs
begin

context
  fixes os :: "'t iarray"
begin

text \<open>
  Alternative definition using indices into the list of states.
  The list of states is implemented as an immutable array for better performance.
\<close>

function viterbi_ix_rec where
  "viterbi_ix_rec s t_end n = (if n \<ge> IArray.length os then ([], indicator {t_end} s) else
  fst (
    argmax snd (map
      (\<lambda>t. let (xs, v) = viterbi_ix_rec t t_end (n + 1) in
        (t # xs, ennreal (pmf (\<O> t) (os !! n) * pmf (\<K> s) t) * v))
    state_list)))
  "
  by pat_completeness auto
termination
  by (relation "Wellfounded.measure (\<lambda>(_,_,n). IArray.length os - n)") auto

text \<open>Memoization\<close>

memoize_fun viterbi_ix\<^sub>m: viterbi_ix_rec
  with_memory dp_consistency_list
  monadifies (state) viterbi_ix_rec.simps[unfolded Let_def]

memoize_correct
  by memoize_prover

text \<open>The main theorems generated by memoization.\<close>
context
  includes state_monad_syntax
begin
thm viterbi_ix\<^sub>m'.simps viterbi_ix\<^sub>m_def
thm viterbi_ix\<^sub>m.memoized_correct
end

end (* Fixed IArray *)

definition
  "viterbi_ix os = viterbi_ix_rec (IArray os)"

end (* HMM3 Defs *)

context HMM3
begin

lemma viterbi_ix_drop_one:
  "viterbi_ix (o # os) s t (n + 1) = viterbi_ix os s t n"
  by (induction "length os - n" arbitrary: s n; simp add: viterbi_ix_def)

lemma viterbi_ix_viterbi:
  "viterbi_ix os s t 0 = viterbi s t os"
  unfolding viterbi_ix_def
proof (induction os arbitrary: s)
  case Nil
  then show ?case
    by simp
next
  case (Cons o os)
  show ?case
    using viterbi_ix_drop_one[unfolded viterbi_ix_def]
    by (subst viterbi.simps, subst viterbi_ix_rec.simps)
       (simp add: Cons.IH del: viterbi_ix_rec.simps viterbi.simps)
qed

lemma viterbi_code [code]:
  "viterbi s t os = fst (run_state (viterbi_ix\<^sub>m' (IArray os) s t 0) [])"
  by (simp only: viterbi_ix_def viterbi_ix\<^sub>m.memoized_correct viterbi_ix_viterbi[symmetric])

end (* Hidden Markov Model 3 *)

subsection \<open>Misc\<close>

lemma pmf_of_alist_support_aux_1:
  assumes "\<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
  shows "(0 :: real) \<le> (case map_of \<mu> x of None \<Rightarrow> 0 | Some p \<Rightarrow> p)"
  using assms by (auto split: option.split dest: map_of_SomeD)

lemma pmf_of_alist_support_aux_2:
  assumes "\<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
    and "sum_list (map snd \<mu>) = 1"
    and "distinct (map fst \<mu>)"
  shows "\<integral>\<^sup>+ x. ennreal (case map_of \<mu> x of None \<Rightarrow> 0 | Some p \<Rightarrow> p) \<partial>count_space UNIV = 1"
  using assms
  apply (subst nn_integral_count_space)
  subgoal
    by (rule finite_subset[where B = "fst ` set \<mu>"];
        force split: option.split_asm simp: image_iff dest: map_of_SomeD)
  apply (subst sum.mono_neutral_left[where T = "fst ` set \<mu>"])
     apply blast
  subgoal
    by (smt ennreal_less_zero_iff map_of_eq_None_iff mem_Collect_eq option.case(1) subsetI)
  subgoal
    by auto
  subgoal premises prems
  proof -
    have "(\<Sum>x = 0..<length \<mu>. snd (\<mu> ! x))
      = sum (\<lambda> x. case map_of \<mu> x of None \<Rightarrow> 0 | Some v \<Rightarrow> v) (fst ` set \<mu>)"
      apply (rule sym)
      apply (rule sum.reindex_cong[where l = "\<lambda> i. fst (\<mu> ! i)"])
        apply (auto split: option.split)
      subgoal
        using prems(3) by (intro inj_onI, auto simp: distinct_conv_nth)
      subgoal
        by (auto simp: in_set_conv_nth rev_image_eqI)
      subgoal
        by (simp add: map_of_eq_None_iff)
      subgoal
        using map_of_eq_Some_iff[OF prems(3)]
        by (metis fst_conv nth_mem option.inject prod_eqI snd_conv)
      done
    with prems(2) show ?thesis
      by (smt pmf_of_alist_support_aux_1[OF assms(1)] atLeastLessThan_iff ennreal_1
          length_map nth_map sum.cong sum_ennreal sum_list_sum_nth
          )
  qed
  done

lemma pmf_of_alist_support:
  assumes "\<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
    and "sum_list (map snd \<mu>) = 1"
    and "distinct (map fst \<mu>)"
  shows "set_pmf (pmf_of_alist \<mu>) \<subseteq> fst ` set \<mu>"
  unfolding pmf_of_alist_def
  apply (subst set_embed_pmf)
  subgoal for x
    using assms(1) by (auto split: option.split dest: map_of_SomeD)
  subgoal
    using pmf_of_alist_support_aux_2[OF assms] .
  apply (force split: option.split_asm simp: image_iff dest: map_of_SomeD)+
  done

text \<open>Defining a Markov kernel from an association list.\<close>
locale Closed_Kernel_From =
  fixes K :: "('s \<times> ('t \<times> real) list) list"
    and S :: "'t list"
  assumes wellformed: "S \<noteq> []"
      and closed: "\<forall> (s, \<mu>) \<in> set K. \<forall> (t, _) \<in> set \<mu>. t \<in> set S"
      and is_pmf:
        "\<forall> (_, \<mu>) \<in> set K. \<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
        "\<forall> (_, \<mu>) \<in> set K. distinct (map fst \<mu>)"
        "\<forall> (s, \<mu>) \<in> set K. sum_list (map snd \<mu>) = 1"
      and is_unique:
        "distinct (map fst K)"
begin

definition
  "K' s \<equiv> case map_of (map (\<lambda> (s, \<mu>). (s, PMF_Impl.pmf_of_alist \<mu>)) K) s of
  None \<Rightarrow> return_pmf (hd S) |
  Some s \<Rightarrow> s"

sublocale Closed_Kernel K' "set S"
  using wellformed closed is_pmf pmf_of_alist_support
  unfolding K'_def by - (standard; fastforce split: option.split_asm dest: map_of_SomeD)

definition [code]:
  "K1 = map_of (map (\<lambda> (s, \<mu>). (s, map_of \<mu>)) K)"

lemma pmf_of_alist_aux:
  assumes "(s, \<mu>) \<in> set K"
  shows
    "pmf (pmf_of_alist \<mu>) t = (case map_of \<mu> t of
      None \<Rightarrow> 0
    | Some p \<Rightarrow> p)"
  using assms is_pmf unfolding pmf_of_alist_def
  by (intro pmf_embed_pmf pmf_of_alist_support_aux_2)
     (auto 4 3 split: option.split dest: map_of_SomeD)

lemma (in -) map_of_NoneD:
  "x \<notin> fst ` set M" if "map_of M x = None"
  using that by (auto dest: weak_map_of_SomeI)

lemma K'_code [code_post]:
  "pmf (K' s) t = (case K1 s of
      None \<Rightarrow> (if t = hd S then 1 else 0)
    | Some \<mu> \<Rightarrow> case \<mu> t of
        None \<Rightarrow> 0
      | Some p \<Rightarrow> p
  )"
  unfolding K'_def K1_def
  apply (clarsimp split: option.split, safe)
                 apply (drule map_of_SomeD, drule map_of_NoneD, force)+
         apply (fastforce dest: unique map_of_SomeD simp: pmf_of_alist_aux)+
  done

end

subsection \<open>Executing Concrete HMMs\<close>

locale Concrete_HMM_defs =
  fixes \<K> :: "('s \<times> ('s \<times> real) list) list"
    and \<O> :: "('s \<times> ('t \<times> real) list) list"
    and \<O>\<^sub>s :: "'t list"
    and \<K>\<^sub>s :: "'s list"
begin

definition
  "\<K>' s \<equiv> case map_of (map (\<lambda> (s, \<mu>). (s, PMF_Impl.pmf_of_alist \<mu>)) \<K>) s of
    None \<Rightarrow> return_pmf (hd \<K>\<^sub>s) |
    Some s \<Rightarrow> s"

definition
  "\<O>' s \<equiv> case map_of (map (\<lambda> (s, \<mu>). (s, PMF_Impl.pmf_of_alist \<mu>)) \<O>) s of
    None \<Rightarrow> return_pmf (hd \<O>\<^sub>s) |
    Some s \<Rightarrow> s"

end

locale Concrete_HMM = Concrete_HMM_defs +
  assumes observations_wellformed': "\<O>\<^sub>s \<noteq> []"
      and observations_closed': "\<forall> (s, \<mu>) \<in> set \<O>. \<forall> (t, _) \<in> set \<mu>. t \<in> set \<O>\<^sub>s"
      and observations_form_pmf':
        "\<forall> (_, \<mu>) \<in> set \<O>. \<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
        "\<forall> (_, \<mu>) \<in> set \<O>. distinct (map fst \<mu>)"
        "\<forall> (s, \<mu>) \<in> set \<O>. sum_list (map snd \<mu>) = 1"
      and observations_unique:
        "distinct (map fst \<O>)"
  assumes states_wellformed: "\<K>\<^sub>s \<noteq> []"
      and states_closed: "\<forall> (s, \<mu>) \<in> set \<K>. \<forall> (t, _) \<in> set \<mu>. t \<in> set \<K>\<^sub>s"
      and states_form_pmf:
        "\<forall> (_, \<mu>) \<in> set \<K>. \<forall> (_, p) \<in> set \<mu>. p \<ge> 0"
        "\<forall> (_, \<mu>) \<in> set \<K>. distinct (map fst \<mu>)"
        "\<forall> (s, \<mu>) \<in> set \<K>. sum_list (map snd \<mu>) = 1"
      and states_unique:
        "distinct (map fst \<K>)" "distinct \<K>\<^sub>s"
begin

interpretation O: Closed_Kernel_From \<O> \<O>\<^sub>s
  rewrites "O.K' = \<O>'"
proof -
  show \<open>Closed_Kernel_From \<O> \<O>\<^sub>s\<close>
    using observations_wellformed' observations_closed' observations_form_pmf' observations_unique
    by unfold_locales auto
  show \<open>Closed_Kernel_From.K' \<O> \<O>\<^sub>s = \<O>'\<close>
    unfolding Closed_Kernel_From.K'_def[OF \<open>Closed_Kernel_From \<O> \<O>\<^sub>s\<close>] \<O>'_def
    by auto
qed

interpretation K: Closed_Kernel_From \<K> \<K>\<^sub>s
  rewrites "K.K' = \<K>'"
proof -
  show \<open>Closed_Kernel_From \<K> \<K>\<^sub>s\<close>
    using states_wellformed states_closed states_form_pmf states_unique by unfold_locales auto
  show \<open>Closed_Kernel_From.K' \<K> \<K>\<^sub>s = \<K>'\<close>
    unfolding Closed_Kernel_From.K'_def[OF \<open>Closed_Kernel_From \<K> \<K>\<^sub>s\<close>] \<K>'_def
    by auto
qed

lemmas O_code = O.K'_code O.K1_def
lemmas K_code = K.K'_code K.K1_def

sublocale HMM_interp: HMM4 \<O>' "set \<K>\<^sub>s" \<K>\<^sub>s "set \<O>\<^sub>s" \<K>'
  using O.Closed_Kernel_axioms K.Closed_Kernel_axioms states_unique(2)
  by (intro_locales; intro HMM4_axioms.intro HMM3_axioms.intro HOL.refl)

end (* Concrete HMM *)

end


theory Demo1 imports Main begin

section{* How to simplify *}

text{* No assumption: *}
lemma "ys @ [] = []"
apply simp
oops

text{* Simple assumption: *}
lemma "xs = [] \<Longrightarrow> xs @ ys = ys @ xs @ ys"
apply simp
oops

text{* Simplification in assumption: *}
lemma "\<lbrakk> xs @ zs = ys @ xs; [] @ xs = [] @ [] \<rbrakk> \<Longrightarrow> ys = zs"
apply simp
done

text{*
  This assumption would lead to nontermination.
  (Note that ALL binds stronger than ==>)
*}
lemma "\<forall>x. f x = g x \<and> g x = f x \<Longrightarrow> f [] = f [] @ []"
(* Would diverge:
apply(simp)
*)
apply(simp (no_asm))
done

text{* Using additional rules: *}
lemma "(a+b)*(a-b) = a*a - b*(b::int)"
apply(simp add: ring_distrib right_diff_distrib)
done

text{* Giving a lemma the simp-attribute: *}
declare ring_distrib [simp]

subsection{* Tracing: *}

lemma "rev [x] = []"
apply simp
oops

subsection{* Auto *}

text{* Method ``auto'' can be modified almost like ``simp'': instead of
``add'' use ``simp add'': *}

lemma "(\<exists>u::nat. x=y+u) \<longrightarrow> a*(b+c)+y \<le> x + a*b+a*c"
apply(auto simp add: add_mult_distrib2)
done

end


theory Determinancy
  imports Typing Typing_Lemmas
begin

lemma unique_ty: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k1 ; \<Gamma> , \<Delta> \<turnstile>\<^sub>t\<^sub>y \<tau> : k2 \<rbrakk> \<Longrightarrow> k1 = k2"
proof (nominal_induct \<tau> arbitrary: k1 k2 rule: \<tau>.strong_induct)
  case (TyVar x)
  then show ?case using isin_split isin_same(1) by blast
next
  case (TyData x)
  then show ?case using axiom_isin_split axiom_isin_same(1) axioms_valid(2)[OF TyData(2)] by blast
next
  case (TyApp \<tau>1 \<tau>2)
  then show ?case by fastforce
next
  case (TyForall x1 x2a x3)
  then show ?case by (metis Ty_Forall_Inv_2)
qed auto

lemma unique_tm: "\<lbrakk> \<Gamma> , \<Delta> \<turnstile> e : \<tau>1 ; \<Gamma> , \<Delta> \<turnstile> e : \<tau>2 \<rbrakk> \<Longrightarrow> \<tau>1 = \<tau>2"
proof (nominal_induct e avoiding: \<Gamma> \<tau>1 \<tau>2 rule: term.strong_induct)
  case (Var x)
  then show ?case using isin_split isin_same(2) by blast
next
  case (App e1 e2)
  then show ?case by fastforce
next
  case (TApp e1 \<tau>)
  obtain a1 k1 \<sigma>1 where 1: "\<Gamma> , \<Delta> \<turnstile> e1 : \<forall> a1:k1. \<sigma>1" "\<tau>1 = \<sigma>1[\<tau>/a1]" by (cases rule: Tm.cases[OF TApp(2)]) auto
  obtain a2 k2 \<sigma>2 where 2: "\<Gamma> , \<Delta> \<turnstile> e1 : \<forall> a2:k2. \<sigma>2" "\<tau>2 = \<sigma>2[\<tau>/a2]" by (cases rule: Tm.cases[OF TApp(3)]) auto
  show ?case using TApp(1)[OF 1(1) 2(1)] subst_type_same 1(2) 2(2) by simp
next
  case (Ctor x)
  then show ?case using axiom_isin_split axiom_isin_same(2) axioms_valid(3)[OF Ctor(2)] by blast
next
  case (Lam x \<tau> e)
  then show ?case by (metis T_Abs_Inv)
next
  case (TyLam a k e)
  then show ?case by (metis T_AbsT_Inv)
next
  case (Let x \<tau> e1 e2)
  then show ?case using T_Let_Inv by blast
qed

end


theory ex10_2
  imports "Trie1"
begin

fun union::"trie \<Rightarrow> trie \<Rightarrow> trie" where
  "union t Leaf = t"
| "union Leaf t = t"
| "union (Node b1 (l1,r1)) (Node b2 (l2,r2)) = Node (b1 \<or> b2) (union l1 l2, union r1 r2)"

declare[[names_short]]

value "isin (Node True (Leaf, Leaf)) []"

value "isin Leaf []"

lemma "isin (union a b) x = (isin a x \<or> isin b x)"
  apply(induction a b arbitrary: x rule: union.induct)
  by (auto split: list.splits)


(* Lambda terms modulo alpha, with freshness and substitution *)
theory Lambda
imports "Prelim"
begin

(* We define the following functions by nonfree recursion:
-- the number of variable occurrences
-- a HOAS encoding of lambda-calculus in itself
-- a weighted version of depth
-- semantic interpretation in a Henkin domain

Then we prove a few facts about lambda-terms.
*)

(* Below, neq is the inequality predicate; currently the package
does not support as parameters arbitrary terms, but only applied constants,
andthis is hy we ave to use "neq x y" instead of "x \<noteq> y". *)
nonfree_datatype ('var,'const) trm =
    Var 'var | Ct 'const | App "('var,'const) trm" "('var,'const) trm" | Lam 'var "('var,'const) trm"
  | subst "('var,'const) trm" "('var,'const) trm" 'var (* subst X Y z = X[Y/z] *)
where
  subst_V1: "subst (Var x) X x = X"
| subst_Ct: "subst (Ct c) X x = Ct c"
| subst_V2: "neq x y \<Longrightarrow> subst (Var x) Y y = Var x"
| subst_App: "subst (App X Y) Z z = App (subst X Z z) (subst Y Z z)"
| subst_Lam: "\<lbrakk>neq x y ; fresh x Y\<rbrakk> \<Longrightarrow> subst (Lam x X) Y y = Lam x (subst X Y y)"
| fresh_V: "neq x y \<Longrightarrow> fresh x (Var y)"
| fresh_Ct: "fresh x (Ct c)"
| fresh_App: "\<lbrakk>fresh x Y ; fresh x Z\<rbrakk> \<Longrightarrow> fresh x (App Y Z)"
| fresh_Lam1: "fresh x (Lam x X)"
| fresh_Lam2: "fresh x Y \<Longrightarrow> fresh x (Lam y Y)"
| Lam_subst:  "\<lbrakk>neq y x ; fresh y X\<rbrakk> \<Longrightarrow> Lam y (subst X (Var y) x) = Lam x X"
| fresh_subst: "\<lbrakk>fresh x X; fresh x Z\<rbrakk> \<Longrightarrow>  fresh x (subst X Z z)"

declare subst_V1[simp] subst_V2[simp] subst_Ct[simp] subst_App[simp] subst_Lam[simp]
        fresh_V[simp] fresh_Ct[simp] fresh_App[simp] fresh_Lam1[simp] fresh_Lam2[simp]
        Lam_subst[simp] fresh_subst[simp]

(* Count number of free occurrences of a variable in a trm: *)
nonfree_primrec
  occs :: "('var,'const) trm \<Rightarrow> ('var \<Rightarrow> nat)"
where
  "occs (Var x) = (\<lambda> z. if x = z then 1 else 0)"
| "occs (Ct c) = (\<lambda> z. 0)"
| "occs (App X Y)  = (\<lambda> z. occs X z + occs Y z)"
| "occs (Lam x X) = (\<lambda> z. if x = z then 0 else occs X z)"
| "occs (subst X Y y) = (\<lambda> z.
     if y = z then occs X y * occs Y z
     else occs X z + occs X y * occs Y z)"
| "fresh x X ==> occs X x = 0"
by (auto simp: algebra_simps)

datatype 'const const = Old 'const | lam | app

(* HOAS encoding of lambda trms in themselves, proved adequate at definition time! *)
nonfree_primrec
  enc :: "('var,'const) trm \<Rightarrow> ('var,'const const) trm"
where
  "enc (Var x) = Var x"
| "enc (Ct c) = Ct (Old c)"
| "enc (App X Y) = App (App (Ct app) (enc X)) (enc Y)"
| "enc (Lam x X) = App (Ct lam) (Lam x (enc X))"
| "enc (subst X Y y) = subst (enc X) (enc Y) y"
| "fresh x X ==> fresh x (enc X)"
by auto

(* Interpretation of terms in semantic domains: *)

locale Semantics =
fixes APP :: "'dom \<Rightarrow> 'dom \<Rightarrow> 'dom"
  and LAM :: "('dom \<Rightarrow> 'dom) \<Rightarrow> 'dom"
begin

nonfree_primrec
  sem :: "('var,'const) trm \<Rightarrow> ('const \<Rightarrow> 'dom) \<Rightarrow> ('var \<Rightarrow> 'dom) \<Rightarrow> 'dom"
where
  "sem (Var x) = (\<lambda> \<xi> \<rho>. \<rho> x)"
| "sem (Ct c) = (\<lambda> \<xi> \<rho>. \<xi> c)"
| "sem (App X Y) = (\<lambda> \<xi> \<rho>. APP (sem X \<xi> \<rho>) (sem Y \<xi> \<rho>))"
| "sem (Lam x X) = (\<lambda> \<xi> \<rho>. LAM (\<lambda> d. sem X \<xi> (\<rho> (x := d))))"
| "sem (subst X Y y) = (\<lambda> \<xi> \<rho>. sem X \<xi> (\<rho> (y := sem Y \<xi> \<rho>)))"
| "fresh x X ==> (\<forall> \<xi> \<rho>1 \<rho>2.
     (\<forall> y. y \<noteq> x \<longrightarrow> \<rho>1 y = \<rho>2 y) \<longrightarrow>  sem X \<xi> \<rho>1 = sem X \<xi> \<rho>2)"
apply (auto intro!: ext
       arg_cong[of _ _ LAM] arg_cong[of _ _ AP] arg_cong2[of _ _ _ _ APP])
apply (metis fun_upd_other fun_upd_twist)
proof- (* todo: clean up proof *)
  fix x' x'a \<rho>1 \<rho>2 d assume "\<forall>y. y \<noteq> x' \<longrightarrow> \<rho>1 y = \<rho>2 y"
  hence "\<rho>1(x' := d) = \<rho>2(x' := d)" by auto
  thus "x'a (\<rho>1(x' := d)) = x'a (\<rho>2(x' := d))" by simp
qed

end (* context Semantics *)

(* Relativized depth, assuming weights for each (free) variable, is an
  instance of the semantic-domain interpretation:  *)
interpretation I : Semantics where APP = max and LAM = "\<lambda> K. Suc (K (0::nat))" done

definition wdepth :: "('var,'const) trm \<Rightarrow> ('var \<Rightarrow> nat) \<Rightarrow> nat" where
"wdepth X \<equiv> I.sem X (\<lambda> c. 0)"

lemma wdepth_simps[simp]:
  "wdepth (Var x) \<rho> = \<rho> x"
  "wdepth (Ct c) \<rho> = 0"
  "wdepth (App X Y) \<rho> = max (wdepth X \<rho>) (wdepth Y \<rho>)"
  "wdepth (Lam x X) \<rho> = Suc (wdepth X (\<rho> (x := 0)))"
  "wdepth (subst X Y y) \<rho> = wdepth X (\<rho> (y := wdepth Y \<rho>))"
  "\<lbrakk>fresh x X; \<And> y. y \<noteq> x \<Longrightarrow>  \<rho>1 y = \<rho>2 y\<rbrakk> \<Longrightarrow>  wdepth X \<rho>1 = wdepth X \<rho>2"
unfolding wdepth_def by auto

(* The usual depth operator is obtained with weigth 0 for all variables: *)
definition "depth X \<equiv> wdepth X (\<lambda> x. 0)"

lemma depth_simps[simp]:
  "depth (Var x) = 0"
  "depth (Ct c) = 0"
  "depth (App X Y) = max (depth X) (depth Y)"
  "depth (Lam x X) = Suc (depth X)"
unfolding depth_def by simp_all (metis fun_upd_triv)

lemma depth_subst_var[simp]: "depth (subst X (Var z) x) = depth X"
unfolding depth_def by simp (metis fun_upd_triv)

(* Some setup: *)
definition "isVar X \<equiv> \<exists> x. X = Var x"
definition "isCt X \<equiv> \<exists> c. X = Ct c"
definition "isApp X \<equiv> \<exists> X1 X2. X = App X1 X2"
definition "isLam X \<equiv> \<exists> x X1. X = Lam x X1"
definition "issubst X \<equiv> \<exists> X1 X2 x. X = subst X1 X2 x"

lemma nchotomy_aux: "isVar X \<or> isCt X \<or> isApp X \<or> isLam X \<or> issubst X"
apply(induction X) unfolding isVar_def isCt_def isApp_def isLam_def issubst_def by blast+

lemma cases_aux:
"\<lbrakk>isVar X \<Longrightarrow>  \<phi>; isCt X \<Longrightarrow>  \<phi>; isApp X \<Longrightarrow>  \<phi>; isLam X \<Longrightarrow>  \<phi>; issubst X \<Longrightarrow>  \<phi>\<rbrakk> \<Longrightarrow> \<phi>"
using nchotomy_aux by auto

lemma isVar_subst:
assumes "isVar X1" shows "isVar (subst X1 X2 x) \<or> subst X1 X2 x = X2"
proof-
  obtain x1 where X1: "X1 = Var x1" using assms unfolding isVar_def by auto
  show ?thesis unfolding isVar_def X1 by (cases "x = x1") auto
qed

lemma isCt_subst:
assumes "isCt X1" shows "subst X1 X2 x = X1"
using assms unfolding isCt_def by auto

lemma isApp_subst:
assumes "isApp X1" shows "isApp (subst X1 X2 x)"
using assms unfolding isApp_def by fastforce

lemma finite_nonFresh:
fixes X :: "('var,'const) trm"
assumes i: "\<not> finite (UNIV::'var set)"
shows "finite {z. \<not> fresh z X}"
proof (induction X)
  fix x::'var
  have "{z. \<not> fresh z (Var x)} \<subseteq> {x}" by (auto, case_tac "x = xa", auto)
  thus "finite {z. \<not> fresh z (Var x)}" by (metis finite.simps subset_singletonD)
next
  fix c::'const show "finite {z::'var. \<not> fresh z (Ct c)}" using i by auto
next
  fix X1 X2 :: "('var,'const) trm"
  assume "finite {z::'var. \<not> fresh z X1}" (is "finite ?A1")
     and "finite {z::'var. \<not> fresh z X2}" (is "finite ?A2")
  moreover have "{z::'var. \<not> fresh z (App X1 X2)} \<subseteq> ?A1 \<union> ?A2" (is "?B \<subseteq> _") by auto
  ultimately show "finite ?B"
  by (metis finite_UnI finite_subset)
next
  fix x :: 'var and X1 :: "('var,'const) trm"
  assume "finite {z::'var. \<not> fresh z X1}" (is "finite ?A1")
  moreover have "finite {x}" by simp
  moreover have "{z::'var. \<not> fresh z (Lam x X1)} \<subseteq> ?A1 \<union> {x}" (is "?B \<subseteq> _") by auto
  ultimately show "finite ?B" by (metis finite_UnI finite_subset)
next
  fix x :: 'var and X1 X2 :: "('var,'const) trm"
  assume "finite {z::'var. \<not> fresh z X1}" (is "finite ?A1")
     and "finite {z::'var. \<not> fresh z X2}" (is "finite ?A2")
  moreover have "{z::'var. \<not> fresh z (subst X1 X2 x)} \<subseteq> ?A1 \<union> ?A2" (is "?B \<subseteq> _") by auto
  ultimately show "finite ?B" by (metis finite_UnI finite_subset)
qed

lemma ex_fresh:
fixes T :: "('var,'const) trm set"
assumes i: "\<not> finite (UNIV::'var set)"
and f: "finite A" and F: "finite T"
shows "\<exists> z. (\<forall> X \<in> T. fresh z X) \<and> z \<notin> A"
proof-
  have "finite ((\<Union> X \<in> T. {z. \<not> fresh z X}) \<union> A)" (is "finite ?B")
  using finite_nonFresh[OF i] f F by auto
  hence "UNIV - ?B \<noteq> {}" by (metis finite.emptyI finite_Diff2 i)
  thus ?thesis by auto
qed

lemma isLam_subst:
fixes X :: "('var,'const) trm"
assumes i: "\<not> finite (UNIV::'var set)" and "isLam X"
shows "isLam (subst X X2 x)"
proof-
  obtain x1 X1 where X: "X = Lam x1 X1" using assms unfolding isLam_def by auto
  then obtain y1 where y1: "fresh y1 X1" "fresh y1 X2" "y1 \<noteq> x1" "y1 \<noteq> x"
  using ex_fresh[of "{x1,x}" "{X1,X2}", OF i] by auto
  hence 1: "Lam x1 X1 = Lam y1 (subst X1 (Var y1) x1)" using subst_Lam by auto
  show ?thesis unfolding X 1 isLam_def using y1 by (auto simp del: Lam_subst)
qed

(* A term is either a variable, or a constant, or an application, or an abstraction: *)
lemma nchotomy:
fixes X :: "('var,'const) trm"
assumes i: "\<not> finite (UNIV::'var set)"
shows "isVar X \<or> isCt X \<or> isApp X \<or> isLam X"
proof (induction X)
  fix x :: 'var and X1 X2 :: "('var,'const) trm"
  assume X1: "isVar X1 \<or> isCt X1 \<or> isApp X1 \<or> isLam X1"
  and X2: "isVar X2 \<or> isCt X2 \<or> isApp X2 \<or> isLam X2"
  let ?Y = "subst X1 X2 x"
  show "isVar ?Y \<or> isCt ?Y \<or> isApp ?Y \<or> isLam ?Y"
  using X1 proof(elim disjE)
    assume "isVar X1"
    from isVar_subst[OF this, of X2 x] X2 show ?thesis by fastforce
  qed (insert X1, auto simp: isCt_subst isApp_subst isLam_subst[OF i])
qed (auto simp: isVar_def isCt_def isApp_def isLam_def)

(* Picking fresh vars: *)
definition pickFresh :: "(var,'const) trm list \<Rightarrow> var list \<Rightarrow> var"
where "pickFresh Xs xs \<equiv> SOME x. (\<forall> X \<in> set Xs. fresh x X) \<and> x \<notin> set xs"

lemma pickFresh:
"(\<forall> X \<in> set Xs. fresh (pickFresh Xs xs) X) \<and> pickFresh Xs xs \<notin> set xs"
unfolding pickFresh_def by (rule someI_ex, rule ex_fresh) auto

lemma fresh_pickFresh[simp]: "X \<in> set Xs \<Longrightarrow>  fresh (pickFresh Xs xs) X"
using pickFresh by auto

lemma notIn_pickFresh[simp]: "pickFresh Xs xs \<notin> set xs"
using pickFresh by auto

end


theory Algebra_Ring_E1
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"subtype_def\", \"subtype_pred_def\", \"ga_assoc___Xx__\",
     \"ga_right_unit___Xx__\", \"ga_left_unit___Xx__\", \"inv_Group\",
     \"rinv_Group\", \"ga_comm___Xx__\", \"ga_assoc___Xx___1\",
     \"ga_right_unit___Xx___1\", \"ga_left_unit___Xx___1\",
     \"distr1_Ring\", \"distr2_Ring\", \"left_zero\", \"right_zero\"]"

typedecl Elem

consts
X0 :: "Elem" ("0''")
X1 :: "Elem" ("1''")
XMinus__X :: "Elem => Elem" ("(-''/ _)" [56] 56)
X__XPlus__X :: "Elem => Elem => Elem" ("(_/ +''/ _)" [54,54] 52)
X__Xx__X :: "Elem => Elem => Elem" ("(_/ *''/ _)" [54,54] 52)
X_isSubtype :: "('s => 't) => ('t => 's) => bool" ("isSubtype/'(_,/ _')" [3,3] 999)
X_isSubtypeWithPred :: "('t => bool) => ('s => 't) => ('t => 's) => bool" ("isSubtypeWithPred/'(_,/ _,/ _')" [3,3,3] 999)

axioms
subtype_def [rule_format] :
"ALL injection.
 ALL projection.
 isSubtype(injection, projection) =
 (ALL x. x = projection (injection x))"

subtype_pred_def [rule_format] :
"ALL P.
 ALL injection.
 ALL projection.
 isSubtypeWithPred(P, injection, projection) =
 ((isSubtype(injection, projection) &
   (ALL x. P x --> x = injection (projection x))) &
  (ALL x. P (injection x)))"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) +' z = x +' (y +' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x +' 0' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 0' +' x = x"

inv_Group [rule_format] : "ALL x. -' x +' x = 0'"

rinv_Group [rule_format] : "ALL x. x +' -' x = 0'"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x +' y = y +' x"

ga_assoc___Xx___1 [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx___1 [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx___1 [rule_format] : "ALL x. 1' *' x = x"

distr1_Ring [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) *' z = (x *' z) +' (y *' z)"

distr2_Ring [rule_format] :
"ALL x. ALL y. ALL z. z *' (x +' y) = (z *' x) +' (z *' y)"

declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare inv_Group [simp]
declare rinv_Group [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx___1 [simp]
declare ga_right_unit___Xx___1 [simp]
declare ga_left_unit___Xx___1 [simp]

theorem left_zero : "ALL x. 0' *' x = 0'"
proof
  fix x
  have "0' = 0' +' 0'" by simp
  hence "0' *' x = (0' +' 0') *' x" by simp
  hence fact: "0' *' x = (0' *' x) +' (0' *' x)" by (simp only: distr1_Ring)
  have "0' = -'(0' *' x) +' (0' *' x)" by simp
  also from fact have "\<dots> = -'(0' *' x) +' ((0' *' x) +' (0' *' x))" by simp
  also have "\<dots> = (-'(0' *' x) +' (0' *' x)) +' (0' *' x)" by (simp only: ga_assoc___Xx__)
  finally show "0' *' x = 0'"
    by (simp  only: ga_left_unit___Xx__ inv_Group)
qed

ML "Header.record \"left_zero\""

theorem right_zero : "ALL x. x *' 0' = 0'"
proof
  fix x
  have "0' = 0' +' 0'" by simp
  hence "x *' 0' = x *' (0' +' 0')" by simp
  hence fact: "x *' 0' = (x *' 0') +' (x *' 0')" by (simp only: distr2_Ring)
  have "0' = -'(x *' 0') +' (x *' 0')" by simp
  also from fact have "\<dots> = -'(x *' 0') +' ((x *' 0') +' (x *' 0'))" by simp
  also have "\<dots> = (-'(x *' 0') +' (x *' 0')) +' (x *' 0')" by (simp only: ga_assoc___Xx__)
  finally show "x *' 0' = 0'"
    by (simp  only: ga_left_unit___Xx__ inv_Group)
qed

ML "Header.record \"right_zero\""

end


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

section \<open>Projective Limit\<close>

theory Projective_Limit
imports
  Fin_Map
  Infinite_Product_Measure
  "HOL-Library.Diagonal_Subsequence"
begin

subsection \<open>Sequences of Finite Maps in Compact Sets\<close>

locale finmap_seqs_into_compact =
  fixes K::"nat \<Rightarrow> (nat \<Rightarrow>\<^sub>F 'a::metric_space) set" and f::"nat \<Rightarrow> (nat \<Rightarrow>\<^sub>F 'a)" and M
  assumes compact: "\<And>n. compact (K n)"
  assumes f_in_K: "\<And>n. K n \<noteq> {}"
  assumes domain_K: "\<And>n. k \<in> K n \<Longrightarrow> domain k = domain (f n)"
  assumes proj_in_K:
    "\<And>t n m. m \<ge> n \<Longrightarrow> t \<in> domain (f n) \<Longrightarrow> (f m)\<^sub>F t \<in> (\<lambda>k. (k)\<^sub>F t) ` K n"
begin

lemma proj_in_K': "(\<exists>n. \<forall>m \<ge> n. (f m)\<^sub>F t \<in> (\<lambda>k. (k)\<^sub>F t) ` K n)"
  using proj_in_K f_in_K
proof cases
  obtain k where "k \<in> K (Suc 0)" using f_in_K by auto
  assume "\<forall>n. t \<notin> domain (f n)"
  thus ?thesis
    by (auto intro!: exI[where x=1] image_eqI[OF _ \<open>k \<in> K (Suc 0)\<close>]
      simp: domain_K[OF \<open>k \<in> K (Suc 0)\<close>])
qed blast

lemma proj_in_KE:
  obtains n where "\<And>m. m \<ge> n \<Longrightarrow> (f m)\<^sub>F t \<in> (\<lambda>k. (k)\<^sub>F t) ` K n"
  using proj_in_K' by blast

lemma compact_projset:
  shows "compact ((\<lambda>k. (k)\<^sub>F i) ` K n)"
  using continuous_proj compact by (rule compact_continuous_image)

end

lemma compactE':
  fixes S :: "'a :: metric_space set"
  assumes "compact S" "\<forall>n\<ge>m. f n \<in> S"
  obtains l r where "l \<in> S" "strict_mono (r::nat\<Rightarrow>nat)" "((f \<circ> r) \<longlongrightarrow> l) sequentially"
proof atomize_elim
  have "strict_mono ((+) m)" by (simp add: strict_mono_def)
  have "\<forall>n. (f o (\<lambda>i. m + i)) n \<in> S" using assms by auto
  from seq_compactE[OF \<open>compact S\<close>[unfolded compact_eq_seq_compact_metric] this]
  obtain l r where "l \<in> S" "strict_mono r" "(f \<circ> (+) m \<circ> r) \<longlonglongrightarrow> l" by blast
  hence "l \<in> S" "strict_mono ((\<lambda>i. m + i) o r) \<and> (f \<circ> ((\<lambda>i. m + i) o r)) \<longlonglongrightarrow> l"
    using strict_mono_o[OF \<open>strict_mono ((+) m)\<close> \<open>strict_mono r\<close>] by (auto simp: o_def)
  thus "\<exists>l r. l \<in> S \<and> strict_mono r \<and> (f \<circ> r) \<longlonglongrightarrow> l" by blast
qed

sublocale finmap_seqs_into_compact \<subseteq> subseqs "\<lambda>n s. (\<exists>l. (\<lambda>i. ((f o s) i)\<^sub>F n) \<longlonglongrightarrow> l)"
proof
  fix n and s :: "nat \<Rightarrow> nat"
  assume "strict_mono s"
  from proj_in_KE[of n] obtain n0 where n0: "\<And>m. n0 \<le> m \<Longrightarrow> (f m)\<^sub>F n \<in> (\<lambda>k. (k)\<^sub>F n) ` K n0"
    by blast
  have "\<forall>i \<ge> n0. ((f \<circ> s) i)\<^sub>F n \<in> (\<lambda>k. (k)\<^sub>F n) ` K n0"
  proof safe
    fix i assume "n0 \<le> i"
    also have "\<dots> \<le> s i" by (rule seq_suble) fact
    finally have "n0 \<le> s i" .
    with n0 show "((f \<circ> s) i)\<^sub>F n \<in> (\<lambda>k. (k)\<^sub>F n) ` K n0 "
      by auto
  qed
  then obtain ls rs
    where "ls \<in> (\<lambda>k. (k)\<^sub>F n) ` K n0" "strict_mono rs" "((\<lambda>i. ((f \<circ> s) i)\<^sub>F n) \<circ> rs) \<longlonglongrightarrow> ls"
    by (rule compactE'[OF compact_projset])
  thus "\<exists>r'. strict_mono r' \<and> (\<exists>l. (\<lambda>i. ((f \<circ> (s \<circ> r')) i)\<^sub>F n) \<longlonglongrightarrow> l)" by (auto simp: o_def)
qed

lemma (in finmap_seqs_into_compact) diagonal_tendsto: "\<exists>l. (\<lambda>i. (f (diagseq i))\<^sub>F n) \<longlonglongrightarrow> l"
proof -
  obtain l where "(\<lambda>i. ((f o (diagseq o (+) (Suc n))) i)\<^sub>F n) \<longlonglongrightarrow> l"
  proof (atomize_elim, rule diagseq_holds)
    fix r s n
    assume "strict_mono (r :: nat \<Rightarrow> nat)"
    assume "\<exists>l. (\<lambda>i. ((f \<circ> s) i)\<^sub>F n) \<longlonglongrightarrow> l"
    then obtain l where "((\<lambda>i. (f i)\<^sub>F n) o s) \<longlonglongrightarrow> l"
      by (auto simp: o_def)
    hence "((\<lambda>i. (f i)\<^sub>F n) o s o r) \<longlonglongrightarrow> l" using \<open>strict_mono r\<close>
      by (rule LIMSEQ_subseq_LIMSEQ)
    thus "\<exists>l. (\<lambda>i. ((f \<circ> (s \<circ> r)) i)\<^sub>F n) \<longlonglongrightarrow> l" by (auto simp add: o_def)
  qed
  hence "(\<lambda>i. ((f (diagseq (i + Suc n))))\<^sub>F n) \<longlonglongrightarrow> l" by (simp add: ac_simps)
  hence "(\<lambda>i. (f (diagseq i))\<^sub>F n) \<longlonglongrightarrow> l" by (rule LIMSEQ_offset)
  thus ?thesis ..
qed

subsection \<open>Daniell-Kolmogorov Theorem\<close>

text \<open>Existence of Projective Limit\<close>

locale polish_projective = projective_family I P "\<lambda>_. borel::'a::polish_space measure"
  for I::"'i set" and P
begin

lemma emeasure_lim_emb:
  assumes X: "J \<subseteq> I" "finite J" "X \<in> sets (\<Pi>\<^sub>M i\<in>J. borel)"
  shows "lim (emb I J X) = P J X"
proof (rule emeasure_lim)
  write mu_G ("\<mu>G")
  interpret generator: algebra "space (PiM I (\<lambda>i. borel))" generator
    by (rule algebra_generator)

  fix J and B :: "nat \<Rightarrow> ('i \<Rightarrow> 'a) set"
  assume J: "\<And>n. finite (J n)" "\<And>n. J n \<subseteq> I" "\<And>n. B n \<in> sets (\<Pi>\<^sub>M i\<in>J n. borel)" "incseq J"
    and B: "decseq (\<lambda>n. emb I (J n) (B n))"
    and "0 < (INF i. P (J i) (B i))" (is "0 < ?a")
  moreover have "?a \<le> 1"
    using J by (auto intro!: INF_lower2[of 0] prob_space_P[THEN prob_space.measure_le_1])
  ultimately obtain r where r: "?a = ennreal r" "0 < r" "r \<le> 1"
    by (cases "?a") (auto simp: top_unique)
  define Z where "Z n = emb I (J n) (B n)" for n
  have Z_mono: "n \<le> m \<Longrightarrow> Z m \<subseteq> Z n" for n m
    unfolding Z_def using B[THEN antimonoD, of n m] .
  have J_mono: "\<And>n m. n \<le> m \<Longrightarrow> J n \<subseteq> J m"
    using \<open>incseq J\<close> by (force simp: incseq_def)
  note [simp] = \<open>\<And>n. finite (J n)\<close>
  interpret prob_space "P (J i)" for i using J prob_space_P by simp

  have P_eq[simp]:
      "sets (P (J i)) = sets (\<Pi>\<^sub>M i\<in>J i. borel)" "space (P (J i)) = space (\<Pi>\<^sub>M i\<in>J i. borel)" for i
    using J by (auto simp: sets_P space_P)

  have "Z i \<in> generator" for i
    unfolding Z_def by (auto intro!: generator.intros J)

  have countable_UN_J: "countable (\<Union>n. J n)" by (simp add: countable_finite)
  define Utn where "Utn = to_nat_on (\<Union>n. J n)"
  interpret function_to_finmap "J n" Utn "from_nat_into (\<Union>n. J n)" for n
    by unfold_locales (auto simp: Utn_def intro: from_nat_into_to_nat_on[OF countable_UN_J])
  have inj_on_Utn: "inj_on Utn (\<Union>n. J n)"
    unfolding Utn_def using countable_UN_J by (rule inj_on_to_nat_on)
  hence inj_on_Utn_J: "\<And>n. inj_on Utn (J n)" by (rule subset_inj_on) auto
  define P' where "P' n = mapmeasure n (P (J n)) (\<lambda>_. borel)" for n
  interpret P': prob_space "P' n" for n
    unfolding P'_def mapmeasure_def using J
    by (auto intro!: prob_space_distr fm_measurable simp: measurable_cong_sets[OF sets_P])

  let ?SUP = "\<lambda>n. SUP K \<in> {K. K \<subseteq> fm n ` (B n) \<and> compact K}. emeasure (P' n) K"
  { fix n
    have "emeasure (P (J n)) (B n) = emeasure (P' n) (fm n ` (B n))"
      using J by (auto simp: P'_def mapmeasure_PiM space_P sets_P)
    also
    have "\<dots> = ?SUP n"
    proof (rule inner_regular)
      show "sets (P' n) = sets borel" by (simp add: borel_eq_PiF_borel P'_def)
    next
      show "fm n ` B n \<in> sets borel"
        unfolding borel_eq_PiF_borel by (auto simp: P'_def fm_image_measurable_finite sets_P J(3))
    qed simp
    finally have *: "emeasure (P (J n)) (B n) = ?SUP n" .
    have "?SUP n \<noteq> \<infinity>"
      unfolding *[symmetric] by simp
    note * this
  } note R = this
  have "\<forall>n. \<exists>K. emeasure (P (J n)) (B n) - emeasure (P' n) K \<le> 2 powr (-n) * ?a \<and> compact K \<and> K \<subseteq> fm n ` B n"
  proof
    fix n show "\<exists>K. emeasure (P (J n)) (B n) - emeasure (P' n) K \<le> ennreal (2 powr - real n) * ?a \<and>
        compact K \<and> K \<subseteq> fm n ` B n"
      unfolding R[of n]
    proof (rule ccontr)
      assume H: "\<nexists>K'. ?SUP n - emeasure (P' n) K' \<le> ennreal (2 powr - real n)  * ?a \<and>
        compact K' \<and> K' \<subseteq> fm n ` B n"
      have "?SUP n + 0 < ?SUP n + 2 powr (-n) * ?a"
        using R[of n] unfolding ennreal_add_left_cancel_less ennreal_zero_less_mult_iff
        by (auto intro: \<open>0 < ?a\<close>)
      also have "\<dots> = (SUP K\<in>{K. K \<subseteq> fm n ` B n \<and> compact K}. emeasure (P' n) K + 2 powr (-n) * ?a)"
        by (rule ennreal_SUP_add_left[symmetric]) auto
      also have "\<dots> \<le> ?SUP n"
      proof (intro SUP_least)
        fix K assume "K \<in> {K. K \<subseteq> fm n ` B n \<and> compact K}"
        with H have "2 powr (-n) * ?a < ?SUP n - emeasure (P' n) K"
          by auto
        then show "emeasure (P' n) K + (2 powr (-n)) * ?a \<le> ?SUP n"
          by (subst (asm) less_diff_eq_ennreal) (auto simp: less_top[symmetric] R(1)[symmetric] ac_simps)
      qed
      finally show False by simp
    qed
  qed
  then obtain K' where K':
    "\<And>n. emeasure (P (J n)) (B n) - emeasure (P' n) (K' n) \<le> ennreal (2 powr - real n) * ?a"
    "\<And>n. compact (K' n)" "\<And>n. K' n \<subseteq> fm n ` B n"
    unfolding choice_iff by blast
  define K where "K n = fm n -` K' n \<inter> space (Pi\<^sub>M (J n) (\<lambda>_. borel))" for n
  have K_sets: "\<And>n. K n \<in> sets (Pi\<^sub>M (J n) (\<lambda>_. borel))"
    unfolding K_def
    using compact_imp_closed[OF \<open>compact (K' _)\<close>]
    by (intro measurable_sets[OF fm_measurable, of _ "Collect finite"])
       (auto simp: borel_eq_PiF_borel[symmetric])
  have K_B: "\<And>n. K n \<subseteq> B n"
  proof
    fix x n assume "x \<in> K n"
    then have fm_in: "fm n x \<in> fm n ` B n"
      using K' by (force simp: K_def)
    show "x \<in> B n"
      using \<open>x \<in> K n\<close> K_sets sets.sets_into_space J(1,2,3)[of n] inj_on_image_mem_iff[OF inj_on_fm]
    by (metis (no_types) Int_iff K_def fm_in space_borel)
  qed
  define Z' where "Z' n = emb I (J n) (K n)" for n
  have Z': "\<And>n. Z' n \<subseteq> Z n"
    unfolding Z'_def Z_def
  proof (rule prod_emb_mono, safe)
    fix n x assume "x \<in> K n"
    hence "fm n x \<in> K' n" "x \<in> space (Pi\<^sub>M (J n) (\<lambda>_. borel))"
      by (simp_all add: K_def space_P)
    note this(1)
    also have "K' n \<subseteq> fm n ` B n" by (simp add: K')
    finally have "fm n x \<in> fm n ` B n" .
    thus "x \<in> B n"
    proof safe
      fix y assume y: "y \<in> B n"
      hence "y \<in> space (Pi\<^sub>M (J n) (\<lambda>_. borel))" using J sets.sets_into_space[of "B n" "P (J n)"]
        by (auto simp add: space_P sets_P)
      assume "fm n x = fm n y"
      note inj_onD[OF inj_on_fm[OF space_borel],
        OF \<open>fm n x = fm n y\<close> \<open>x \<in> space _\<close> \<open>y \<in> space _\<close>]
      with y show "x \<in> B n" by simp
    qed
  qed
  have "\<And>n. Z' n \<in> generator" using J K'(2) unfolding Z'_def
    by (auto intro!: generator.intros measurable_sets[OF fm_measurable[of _ "Collect finite"]]
             simp: K_def borel_eq_PiF_borel[symmetric] compact_imp_closed)
  define Y where "Y n = (\<Inter>i\<in>{1..n}. Z' i)" for n
  hence "\<And>n k. Y (n + k) \<subseteq> Y n" by (induct_tac k) (auto simp: Y_def)
  hence Y_mono: "\<And>n m. n \<le> m \<Longrightarrow> Y m \<subseteq> Y n" by (auto simp: le_iff_add)
  have Y_Z': "\<And>n. n \<ge> 1 \<Longrightarrow> Y n \<subseteq> Z' n" by (auto simp: Y_def)
  hence Y_Z: "\<And>n. n \<ge> 1 \<Longrightarrow> Y n \<subseteq> Z n" using Z' by auto

  have Y_notempty: "\<And>n. n \<ge> 1 \<Longrightarrow> (Y n) \<noteq> {}"
  proof -
    fix n::nat assume "n \<ge> 1" hence "Y n \<subseteq> Z n" by fact
    have "Y n = (\<Inter>i\<in>{1..n}. emb I (J n) (emb (J n) (J i) (K i)))" using J J_mono
      by (auto simp: Y_def Z'_def)
    also have "\<dots> = prod_emb I (\<lambda>_. borel) (J n) (\<Inter>i\<in>{1..n}. emb (J n) (J i) (K i))"
      using \<open>n \<ge> 1\<close>
      by (subst prod_emb_INT) auto
    finally
    have Y_emb:
      "Y n = prod_emb I (\<lambda>_. borel) (J n) (\<Inter>i\<in>{1..n}. prod_emb (J n) (\<lambda>_. borel) (J i) (K i))" .
    hence "Y n \<in> generator" using J J_mono K_sets \<open>n \<ge> 1\<close>
      by (auto simp del: prod_emb_INT intro!: generator.intros)
    have *: "\<mu>G (Z n) = P (J n) (B n)"
      unfolding Z_def using J by (intro mu_G_spec) auto
    then have "\<mu>G (Z n) \<noteq> \<infinity>" by auto
    note *
    moreover have *: "\<mu>G (Y n) = P (J n) (\<Inter>i\<in>{Suc 0..n}. prod_emb (J n) (\<lambda>_. borel) (J i) (K i))"
      unfolding Y_emb using J J_mono K_sets \<open>n \<ge> 1\<close> by (subst mu_G_spec) auto
    then have "\<mu>G (Y n) \<noteq> \<infinity>" by auto
    note *
    moreover have "\<mu>G (Z n - Y n) =
        P (J n) (B n - (\<Inter>i\<in>{Suc 0..n}. prod_emb (J n) (\<lambda>_. borel) (J i) (K i)))"
      unfolding Z_def Y_emb prod_emb_Diff[symmetric] using J J_mono K_sets \<open>n \<ge> 1\<close>
      by (subst mu_G_spec) (auto intro!: sets.Diff)
    ultimately
    have "\<mu>G (Z n) - \<mu>G (Y n) = \<mu>G (Z n - Y n)"
      using J J_mono K_sets \<open>n \<ge> 1\<close>
      by (simp only: emeasure_eq_measure Z_def)
         (auto dest!: bspec[where x=n] intro!: measure_Diff[symmetric] subsetD[OF K_B]
               intro!: arg_cong[where f=ennreal]
               simp: extensional_restrict emeasure_eq_measure prod_emb_iff sets_P space_P
                     ennreal_minus measure_nonneg)
    also have subs: "Z n - Y n \<subseteq> (\<Union>i\<in>{1..n}. (Z i - Z' i))"
      using \<open>n \<ge> 1\<close> unfolding Y_def UN_extend_simps(7) by (intro UN_mono Diff_mono Z_mono order_refl) auto
    have "Z n - Y n \<in> generator" "(\<Union>i\<in>{1..n}. (Z i - Z' i)) \<in> generator"
      using \<open>Z' _ \<in> generator\<close> \<open>Z _ \<in> generator\<close> \<open>Y _ \<in> generator\<close> by auto
    hence "\<mu>G (Z n - Y n) \<le> \<mu>G (\<Union>i\<in>{1..n}. (Z i - Z' i))"
      using subs generator.additive_increasing[OF positive_mu_G additive_mu_G]
      unfolding increasing_def by auto
    also have "\<dots> \<le> (\<Sum> i\<in>{1..n}. \<mu>G (Z i - Z' i))" using \<open>Z _ \<in> generator\<close> \<open>Z' _ \<in> generator\<close>
      by (intro generator.subadditive[OF positive_mu_G additive_mu_G]) auto
    also have "\<dots> \<le> (\<Sum> i\<in>{1..n}. 2 powr -real i * ?a)"
    proof (rule sum_mono)
      fix i assume "i \<in> {1..n}" hence "i \<le> n" by simp
      have "\<mu>G (Z i - Z' i) = \<mu>G (prod_emb I (\<lambda>_. borel) (J i) (B i - K i))"
        unfolding Z'_def Z_def by simp
      also have "\<dots> = P (J i) (B i - K i)"
        using J K_sets by (subst mu_G_spec) auto
      also have "\<dots> = P (J i) (B i) - P (J i) (K i)"
        using K_sets J \<open>K _ \<subseteq> B _\<close> by (simp add: emeasure_Diff)
      also have "\<dots> = P (J i) (B i) - P' i (K' i)"
        unfolding K_def P'_def
        by (auto simp: mapmeasure_PiF borel_eq_PiF_borel[symmetric]
          compact_imp_closed[OF \<open>compact (K' _)\<close>] space_PiM PiE_def)
      also have "\<dots> \<le> ennreal (2 powr - real i) * ?a" using K'(1)[of i] .
      finally show "\<mu>G (Z i - Z' i) \<le> (2 powr - real i) * ?a" .
    qed
    also have "\<dots> = ennreal ((\<Sum> i\<in>{1..n}. (2 powr -enn2real i)) * enn2real ?a)"
      using r by (simp add: sum_distrib_right ennreal_mult[symmetric])
    also have "\<dots> < ennreal (1 * enn2real ?a)"
    proof (intro ennreal_lessI mult_strict_right_mono)
      have "(\<Sum>i = 1..n. 2 powr - real i) = (\<Sum>i = 1..<Suc n. (1/2) ^ i)"
        by (rule sum.cong) (auto simp: powr_realpow powr_divide power_divide powr_minus_divide)
      also have "{1..<Suc n} = {..<Suc n} - {0}" by auto
      also have "sum ((^) (1 / 2::real)) ({..<Suc n} - {0}) =
        sum ((^) (1 / 2)) ({..<Suc n}) - 1" by (auto simp: sum_diff1)
      also have "\<dots> < 1" by (subst geometric_sum) auto
      finally show "(\<Sum>i = 1..n. 2 powr - enn2real i) < 1" by simp
    qed (auto simp: r enn2real_positive_iff)
    also have "\<dots> = ?a" by (auto simp: r)
    also have "\<dots> \<le> \<mu>G (Z n)"
      using J by (auto intro: INF_lower simp: Z_def mu_G_spec)
    finally have "\<mu>G (Z n) - \<mu>G (Y n) < \<mu>G (Z n)" .
    hence R: "\<mu>G (Z n) < \<mu>G (Z n) + \<mu>G (Y n)"
      using \<open>\<mu>G (Y n) \<noteq> \<infinity>\<close> by (auto simp: zero_less_iff_neq_zero)
    then have "\<mu>G (Y n) > 0"
      by simp
    thus "Y n \<noteq> {}" using positive_mu_G by (auto simp add: positive_def)
  qed
  hence "\<forall>n\<in>{1..}. \<exists>y. y \<in> Y n" by auto
  then obtain y where y: "\<And>n. n \<ge> 1 \<Longrightarrow> y n \<in> Y n" unfolding bchoice_iff by force
  {
    fix t and n m::nat
    assume "1 \<le> n" "n \<le> m" hence "1 \<le> m" by simp
    from Y_mono[OF \<open>m \<ge> n\<close>] y[OF \<open>1 \<le> m\<close>] have "y m \<in> Y n" by auto
    also have "\<dots> \<subseteq> Z' n" using Y_Z'[OF \<open>1 \<le> n\<close>] .
    finally
    have "fm n (restrict (y m) (J n)) \<in> K' n"
      unfolding Z'_def K_def prod_emb_iff by (simp add: Z'_def K_def prod_emb_iff)
    moreover have "finmap_of (J n) (restrict (y m) (J n)) = finmap_of (J n) (y m)"
      using J by (simp add: fm_def)
    ultimately have "fm n (y m) \<in> K' n" by simp
  } note fm_in_K' = this
  interpret finmap_seqs_into_compact "\<lambda>n. K' (Suc n)" "\<lambda>k. fm (Suc k) (y (Suc k))" borel
  proof
    fix n show "compact (K' n)" by fact
  next
    fix n
    from Y_mono[of n "Suc n"] y[of "Suc n"] have "y (Suc n) \<in> Y (Suc n)" by auto
    also have "\<dots> \<subseteq> Z' (Suc n)" using Y_Z' by auto
    finally
    have "fm (Suc n) (restrict (y (Suc n)) (J (Suc n))) \<in> K' (Suc n)"
      unfolding Z'_def K_def prod_emb_iff by (simp add: Z'_def K_def prod_emb_iff)
    thus "K' (Suc n) \<noteq> {}" by auto
    fix k
    assume "k \<in> K' (Suc n)"
    with K'[of "Suc n"] sets.sets_into_space have "k \<in> fm (Suc n) ` B (Suc n)" by auto
    then obtain b where "k = fm (Suc n) b" by auto
    thus "domain k = domain (fm (Suc n) (y (Suc n)))"
      by (simp_all add: fm_def)
  next
    fix t and n m::nat
    assume "n \<le> m" hence "Suc n \<le> Suc m" by simp
    assume "t \<in> domain (fm (Suc n) (y (Suc n)))"
    then obtain j where j: "t = Utn j" "j \<in> J (Suc n)" by auto
    hence "j \<in> J (Suc m)" using J_mono[OF \<open>Suc n \<le> Suc m\<close>] by auto
    have img: "fm (Suc n) (y (Suc m)) \<in> K' (Suc n)" using \<open>n \<le> m\<close>
      by (intro fm_in_K') simp_all
    show "(fm (Suc m) (y (Suc m)))\<^sub>F t \<in> (\<lambda>k. (k)\<^sub>F t) ` K' (Suc n)"
      apply (rule image_eqI[OF _ img])
      using \<open>j \<in> J (Suc n)\<close> \<open>j \<in> J (Suc m)\<close>
      unfolding j by (subst proj_fm, auto)+
  qed
  have "\<forall>t. \<exists>z. (\<lambda>i. (fm (Suc (diagseq i)) (y (Suc (diagseq i))))\<^sub>F t) \<longlonglongrightarrow> z"
    using diagonal_tendsto ..
  then obtain z where z:
    "\<And>t. (\<lambda>i. (fm (Suc (diagseq i)) (y (Suc (diagseq i))))\<^sub>F t) \<longlonglongrightarrow> z t"
    unfolding choice_iff by blast
  {
    fix n :: nat assume "n \<ge> 1"
    have "\<And>i. domain (fm n (y (Suc (diagseq i)))) = domain (finmap_of (Utn ` J n) z)"
      by simp
    moreover
    {
      fix t
      assume t: "t \<in> domain (finmap_of (Utn ` J n) z)"
      hence "t \<in> Utn ` J n" by simp
      then obtain j where j: "t = Utn j" "j \<in> J n" by auto
      have "(\<lambda>i. (fm n (y (Suc (diagseq i))))\<^sub>F t) \<longlonglongrightarrow> z t"
        apply (subst (2) tendsto_iff, subst eventually_sequentially)
      proof safe
        fix e :: real assume "0 < e"
        { fix i and x :: "'i \<Rightarrow> 'a" assume i: "i \<ge> n"
          assume "t \<in> domain (fm n x)"
          hence "t \<in> domain (fm i x)" using J_mono[OF \<open>i \<ge> n\<close>] by auto
          with i have "(fm i x)\<^sub>F t = (fm n x)\<^sub>F t"
            using j by (auto simp: proj_fm dest!: inj_onD[OF inj_on_Utn])
        } note index_shift = this
        have I: "\<And>i. i \<ge> n \<Longrightarrow> Suc (diagseq i) \<ge> n"
          apply (rule le_SucI)
          apply (rule order_trans) apply simp
          apply (rule seq_suble[OF subseq_diagseq])
          done
        from z
        have "\<exists>N. \<forall>i\<ge>N. dist ((fm (Suc (diagseq i)) (y (Suc (diagseq i))))\<^sub>F t) (z t) < e"
          unfolding tendsto_iff eventually_sequentially using \<open>0 < e\<close> by auto
        then obtain N where N: "\<And>i. i \<ge> N \<Longrightarrow>
          dist ((fm (Suc (diagseq i)) (y (Suc (diagseq i))))\<^sub>F t) (z t) < e" by auto
        show "\<exists>N. \<forall>na\<ge>N. dist ((fm n (y (Suc (diagseq na))))\<^sub>F t) (z t) < e "
        proof (rule exI[where x="max N n"], safe)
          fix na assume "max N n \<le> na"
          hence  "dist ((fm n (y (Suc (diagseq na))))\<^sub>F t) (z t) =
                  dist ((fm (Suc (diagseq na)) (y (Suc (diagseq na))))\<^sub>F t) (z t)" using t
            by (subst index_shift[OF I]) auto
          also have "\<dots> < e" using \<open>max N n \<le> na\<close> by (intro N) simp
          finally show "dist ((fm n (y (Suc (diagseq na))))\<^sub>F t) (z t) < e" .
        qed
      qed
      hence "(\<lambda>i. (fm n (y (Suc (diagseq i))))\<^sub>F t) \<longlonglongrightarrow> (finmap_of (Utn ` J n) z)\<^sub>F t"
        by (simp add: tendsto_intros)
    } ultimately
    have "(\<lambda>i. fm n (y (Suc (diagseq i)))) \<longlonglongrightarrow> finmap_of (Utn ` J n) z"
      by (rule tendsto_finmap)
    hence "((\<lambda>i. fm n (y (Suc (diagseq i)))) o (\<lambda>i. i + n)) \<longlonglongrightarrow> finmap_of (Utn ` J n) z"
      by (rule LIMSEQ_subseq_LIMSEQ) (simp add: strict_mono_def)
    moreover
    have "(\<forall>i. ((\<lambda>i. fm n (y (Suc (diagseq i)))) o (\<lambda>i. i + n)) i \<in> K' n)"
      apply (auto simp add: o_def intro!: fm_in_K' \<open>1 \<le> n\<close> le_SucI)
      apply (rule le_trans)
      apply (rule le_add2)
      using seq_suble[OF subseq_diagseq]
      apply auto
      done
    moreover
    from \<open>compact (K' n)\<close> have "closed (K' n)" by (rule compact_imp_closed)
    ultimately
    have "finmap_of (Utn ` J n) z \<in> K' n"
      unfolding closed_sequential_limits by blast
    also have "finmap_of (Utn ` J n) z  = fm n (\<lambda>i. z (Utn i))"
      unfolding finmap_eq_iff
    proof clarsimp
      fix i assume i: "i \<in> J n"
      hence "from_nat_into (\<Union>n. J n) (Utn i) = i"
        unfolding Utn_def
        by (subst from_nat_into_to_nat_on[OF countable_UN_J]) auto
      with i show "z (Utn i) = (fm n (\<lambda>i. z (Utn i)))\<^sub>F (Utn i)"
        by (simp add: finmap_eq_iff fm_def compose_def)
    qed
    finally have "fm n (\<lambda>i. z (Utn i)) \<in> K' n" .
    moreover
    let ?J = "\<Union>n. J n"
    have "(?J \<inter> J n) = J n" by auto
    ultimately have "restrict (\<lambda>i. z (Utn i)) (?J \<inter> J n) \<in> K n"
      unfolding K_def by (auto simp: space_P space_PiM)
    hence "restrict (\<lambda>i. z (Utn i)) ?J \<in> Z' n" unfolding Z'_def
      using J by (auto simp: prod_emb_def PiE_def extensional_def)
    also have "\<dots> \<subseteq> Z n" using Z' by simp
    finally have "restrict (\<lambda>i. z (Utn i)) ?J \<in> Z n" .
  } note in_Z = this
  hence "(\<Inter>i\<in>{1..}. Z i) \<noteq> {}" by auto
  thus "(\<Inter>i. Z i) \<noteq> {}"
    using INT_decseq_offset[OF antimonoI[OF Z_mono]] by simp
qed fact+

lemma measure_lim_emb:
  "J \<subseteq> I \<Longrightarrow> finite J \<Longrightarrow> X \<in> sets (\<Pi>\<^sub>M i\<in>J. borel) \<Longrightarrow> measure lim (emb I J X) = measure (P J) X"
  unfolding measure_def by (subst emeasure_lim_emb) auto

end

hide_const (open) PiF
hide_const (open) Pi\<^sub>F
hide_const (open) Pi'
hide_const (open) finmap_of
hide_const (open) proj
hide_const (open) domain
hide_const (open) basis_finmap

sublocale polish_projective \<subseteq> P: prob_space lim
proof
  have *: "emb I {} {\<lambda>x. undefined} = space (\<Pi>\<^sub>M i\<in>I. borel)"
    by (auto simp: prod_emb_def space_PiM)
  interpret prob_space "P {}"
    using prob_space_P by simp
  show "emeasure lim (space lim) = 1"
    using emeasure_lim_emb[of "{}" "{\<lambda>x. undefined}"] emeasure_space_1
    by (simp add: * PiM_empty space_P)
qed

locale polish_product_prob_space =
  product_prob_space "\<lambda>_. borel::('a::polish_space) measure" I for I::"'i set"

sublocale polish_product_prob_space \<subseteq> P: polish_projective I "\<lambda>J. PiM J (\<lambda>_. borel::('a) measure)"
  ..

lemma (in polish_product_prob_space) limP_eq_PiM: "lim = PiM I (\<lambda>_. borel)"
  by (rule PiM_eq) (auto simp: emeasure_PiM emeasure_lim_emb)

end


(*
    File:        FinCard.thy
    Time-stamp:  <2020-06-22T03:36:42Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory FinCard imports ZF.Finite ZF.Cardinal begin

lemma Fin_subset2:
  assumes "X: Fin(A)"
      and "X <= B"
    shows "X: Fin(B)"
apply (rule assms(2) [THEN rev_mp])
apply (rule assms(1) [THEN Fin_induct])
apply (rule impI)
apply (rule Fin.emptyI)
apply (rule impI)
apply (erule cons_subsetE)
apply (rule Fin.consI)
apply (drule_tac [2] mp)
apply assumption+
done

lemma Fin_domainI [TC]:
    "X: Fin(A*B) ==> domain(X): Fin(A)"
apply (erule Fin_induct)
apply (erule_tac [2] SigmaE)
apply simp_all
done

lemma Fin_rangeI [TC]:
    "X: Fin(A*B) ==> range(X): Fin(B)"
apply (erule Fin_induct)
apply (erule_tac [2] SigmaE)
apply simp_all
done

lemma Fin_RepFunI [TC]:
    "[| X: Fin(A); !!x. x: A ==> f(x): B |] ==> {f(x). x: X}: Fin(B)"
apply (erule Fin_induct)
apply simp_all
done

lemmas Fin_imp_Finite = Fin_into_Finite
lemmas Finite_imp_Fin = Finite_into_Fin

lemma Finite_imp_card_nat [TC]:
    "Finite(A) ==> |A|: nat"
apply (unfold Finite_def)
apply (erule bexE)
apply (drule cardinal_cong)
apply (erule ssubst)
apply (rule lt_nat_in_nat)
apply (rule Ord_cardinal_le)
apply (erule nat_into_Ord)
apply (erule nat_succI)
done

lemma Fin_complete_induct_lemma:
 "n: nat ==> (ALL X: Fin(A). |X| = n -->
   (ALL x: Fin(A). (ALL y. y: Fin(A) & |y| < |x| --> P(y)) --> P(x))
   --> P(X))"
apply (erule complete_induct)
apply clarsimp
apply (erule bspec [THEN mp])
apply assumption
apply clarsimp
apply (drule ltD)
apply simp
done

lemma Fin_complete_induct:
  assumes major: "X: Fin(A)"
  and indstep: "!!x. [| x: Fin(A);
                       ALL y. y: Fin(A) & |y| < |x| --> P(y)
                     |] ==> P(x)"
  shows "P(X)"
apply (rule major [THEN Fin_into_Finite, THEN Finite_imp_card_nat,
                   THEN Fin_complete_induct_lemma,
                   THEN bspec, THEN mp, THEN mp])
apply ((rule major refl ballI impI indstep) | assumption)+
done

lemma Finite_lepoll_imp_le:
  assumes major: "A \<lesssim> B"
  and prem: "Finite(B)"
  shows "|A| \<le> |B|"
apply (insert lepoll_Finite [OF major prem] prem major)
apply (unfold Finite_def cardinal_def)
apply clarify
apply (rule le_trans)
apply (rule Least_le)
apply (erule eqpoll_sym)
apply (erule nat_into_Ord)
apply (rule_tac P="%x. n \<le> x" in ssubst)
apply (rule Least_equality)
apply (erule eqpoll_sym)
apply (erule nat_into_Ord)
apply (rule notI)
apply (drule eqpoll_trans, assumption)
apply (frule lt_nat_in_nat)
apply assumption
apply (drule nat_eqpoll_iff [THEN iffD1], assumption, assumption)
apply hypsubst
apply (erule lt_irrefl)
apply (rule nat_lepoll_imp_le)
apply assumption+
apply (rule lepoll_trans)
apply (rule eqpoll_sym [THEN eqpoll_imp_lepoll], assumption)
apply (rule lepoll_trans, assumption)
apply (erule eqpoll_imp_lepoll)
done

lemma Finite_cardinal_succ:
    "Finite(A) ==> |succ(A)| = succ(|A|)"
apply (unfold Finite_def)
apply (erule bexE)
apply (rule_tac b="|succ(n)|" in trans)
apply (rule cardinal_cong)
apply (simp only: succ_def)
apply (blast elim!: mem_irrefl intro: cons_eqpoll_cong)
apply (drule cardinal_cong)
apply (simp add: nat_into_Card [THEN Card_cardinal_eq])
done

lemma Finite_cardinal_cons:
  assumes major: "Finite(A)"
  shows "a ~: A ==> |cons(a, A)| = succ(|A|)"
apply (rule major [THEN Finite_cardinal_succ, THEN [2] trans])
apply (rule cardinal_cong)
apply (unfold succ_def)
apply (blast elim!: mem_irrefl intro: eqpoll_refl cons_eqpoll_cong)
done

lemmas FinCard_simps = Finite_cardinal_cons cons_absorb cardinal_0

end


(*  Title:      HOL/HOLCF/FOCUS/Stream_adm.thy
    Author:     David von Oheimb, TU Muenchen
*)

section \<open>Admissibility for streams\<close>

theory Stream_adm
imports "~~/src/HOL/HOLCF/Library/Stream" "~~/src/HOL/Library/Order_Continuity"
begin

definition
  stream_monoP  :: "(('a stream) set \<Rightarrow> ('a stream) set) \<Rightarrow> bool" where
  "stream_monoP F = (\<exists>Q i. \<forall>P s. enat i \<le> #s \<longrightarrow>
                    (s \<in> F P) = (stream_take i\<cdot>s \<in> Q \<and> iterate i\<cdot>rt\<cdot>s \<in> P))"

definition
  stream_antiP  :: "(('a stream) set \<Rightarrow> ('a stream) set) \<Rightarrow> bool" where
  "stream_antiP F = (\<forall>P x. \<exists>Q i.
                (#x  < enat i \<longrightarrow> (\<forall>y. x \<sqsubseteq> y \<longrightarrow> y \<in> F P \<longrightarrow> x \<in> F P)) \<and>
                (enat i <= #x \<longrightarrow> (\<forall>y. x \<sqsubseteq> y \<longrightarrow>
                (y \<in> F P) = (stream_take i\<cdot>y \<in> Q \<and> iterate i\<cdot>rt\<cdot>y \<in> P))))"

definition
  antitonP :: "'a set => bool" where
  "antitonP P = (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> y\<in>P \<longrightarrow> x\<in>P)"

(* ----------------------------------------------------------------------- *)

section "admissibility"

lemma infinite_chain_adm_lemma:
  "\<lbrakk>Porder.chain Y; \<forall>i. P (Y i);
    \<And>Y. \<lbrakk>Porder.chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
      \<Longrightarrow> P (\<Squnion>i. Y i)"
apply (case_tac "finite_chain Y")
prefer 2 apply fast
apply (unfold finite_chain_def)
apply safe
apply (erule lub_finch1 [THEN lub_eqI, THEN ssubst])
apply assumption
apply (erule spec)
done

lemma increasing_chain_adm_lemma:
  "\<lbrakk>Porder.chain Y;  \<forall>i. P (Y i); \<And>Y. \<lbrakk>Porder.chain Y; \<forall>i. P (Y i);
    \<forall>i. \<exists>j>i. Y i \<noteq> Y j \<and> Y i \<sqsubseteq> Y j\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
      \<Longrightarrow> P (\<Squnion>i. Y i)"
apply (erule infinite_chain_adm_lemma)
apply assumption
apply (erule thin_rl)
apply (unfold finite_chain_def)
apply (unfold max_in_chain_def)
apply (fast dest: le_imp_less_or_eq elim: chain_mono_less)
done

lemma flatstream_adm_lemma:
  assumes 1: "Porder.chain Y"
  assumes 2: "!i. P (Y i)"
  assumes 3: "(!!Y. [| Porder.chain Y; !i. P (Y i); !k. ? j. enat k < #((Y j)::'a::flat stream)|]
  ==> P(LUB i. Y i))"
  shows "P(LUB i. Y i)"
apply (rule increasing_chain_adm_lemma [OF 1 2])
apply (erule 3, assumption)
apply (erule thin_rl)
apply (rule allI)
apply (case_tac "!j. stream_finite (Y j)")
apply ( rule chain_incr)
apply ( rule allI)
apply ( drule spec)
apply ( safe)
apply ( rule exI)
apply ( rule slen_strict_mono)
apply (   erule spec)
apply (  assumption)
apply ( assumption)
apply (metis enat_ord_code(4) slen_infinite)
done

(* should be without reference to stream length? *)
lemma flatstream_admI: "[|(!!Y. [| Porder.chain Y; !i. P (Y i);
 !k. ? j. enat k < #((Y j)::'a::flat stream)|] ==> P(LUB i. Y i))|]==> adm P"
apply (unfold adm_def)
apply (intro strip)
apply (erule (1) flatstream_adm_lemma)
apply (fast)
done

(* context (theory "Extended_Nat");*)
lemma ile_lemma: "enat (i + j) <= x ==> enat i <= x"
  by (rule order_trans) auto

lemma stream_monoP2I:
"!!X. stream_monoP F ==> !i. ? l. !x y.
  enat l <= #x --> (x::'a::flat stream) << y --> x:(F ^^ i) top --> y:(F ^^ i) top"
apply (unfold stream_monoP_def)
apply (safe)
apply (rule_tac x="i*ia" in exI)
apply (induct_tac "ia")
apply ( simp)
apply (simp)
apply (intro strip)
apply (erule allE, erule all_dupE, drule mp, erule ile_lemma)
apply (drule_tac P="%x. x" in subst, assumption)
apply (erule allE, drule mp, rule ile_lemma) back
apply ( erule order_trans)
apply ( erule slen_mono)
apply (erule ssubst)
apply (safe)
apply ( erule (2) ile_lemma [THEN slen_take_lemma3, THEN subst])
apply (erule allE)
apply (drule mp)
apply ( erule slen_rt_mult)
apply (erule allE)
apply (drule mp)
apply (erule monofun_rt_mult)
apply (drule (1) mp)
apply (assumption)
done

lemma stream_monoP2_gfp_admI: "[| !i. ? l. !x y.
 enat l <= #x --> (x::'a::flat stream) << y --> x:(F ^^ i) top --> y:(F ^^ i) top;
    inf_continuous F |] ==> adm (%x. x:gfp F)"
apply (erule inf_continuous_gfp[of F, THEN ssubst])
apply (simp (no_asm))
apply (rule adm_lemmas)
apply (rule flatstream_admI)
apply (erule allE)
apply (erule exE)
apply (erule allE, erule exE)
apply (erule allE, erule allE, drule mp) (* stream_monoP *)
apply ( drule ileI1)
apply ( drule order_trans)
apply (  rule ile_eSuc)
apply ( drule eSuc_ile_mono [THEN iffD1])
apply ( assumption)
apply (drule mp)
apply ( erule is_ub_thelub)
apply (fast)
done

lemmas fstream_gfp_admI = stream_monoP2I [THEN stream_monoP2_gfp_admI]

lemma stream_antiP2I:
"!!X. [|stream_antiP (F::(('a::flat stream)set => ('a stream set)))|]
  ==> !i x y. x << y --> y:(F ^^ i) top --> x:(F ^^ i) top"
apply (unfold stream_antiP_def)
apply (rule allI)
apply (induct_tac "i")
apply ( simp)
apply (simp)
apply (intro strip)
apply (erule allE, erule all_dupE, erule exE, erule exE)
apply (erule conjE)
apply (case_tac "#x < enat i")
apply ( fast)
apply (unfold linorder_not_less)
apply (drule (1) mp)
apply (erule all_dupE, drule mp, rule below_refl)
apply (erule ssubst)
apply (erule allE, drule (1) mp)
apply (drule_tac P="%x. x" in subst, assumption)
apply (erule conjE, rule conjI)
apply ( erule slen_take_lemma3 [THEN ssubst], assumption)
apply ( assumption)
apply (erule allE, erule allE, drule mp, erule monofun_rt_mult)
apply (drule (1) mp)
apply (assumption)
done

lemma stream_antiP2_non_gfp_admI:
"!!X. [|!i x y. x << y --> y:(F ^^ i) top --> x:(F ^^ i) top; inf_continuous F |]
  ==> adm (%u. ~ u:gfp F)"
apply (unfold adm_def)
apply (simp add: inf_continuous_gfp)
apply (fast dest!: is_ub_thelub)
done

lemmas fstream_non_gfp_admI = stream_antiP2I [THEN stream_antiP2_non_gfp_admI]

(**new approach for adm********************************************************)

section "antitonP"

lemma antitonPD: "[| antitonP P; y:P; x<<y |] ==> x:P"
apply (unfold antitonP_def)
apply auto
done

lemma antitonPI: "!x y. y:P --> x<<y --> x:P ==> antitonP P"
apply (unfold antitonP_def)
apply (fast)
done

lemma antitonP_adm_non_P: "antitonP P ==> adm (%u. u~:P)"
apply (unfold adm_def)
apply (auto dest: antitonPD elim: is_ub_thelub)
done

lemma def_gfp_adm_nonP: "P \<equiv> gfp F \<Longrightarrow> {y. \<exists>x::'a::pcpo. y \<sqsubseteq> x \<and> x \<in> P} \<subseteq> F {y. \<exists>x. y \<sqsubseteq> x \<and> x \<in> P} \<Longrightarrow>
  adm (\<lambda>u. u\<notin>P)"
apply (simp)
apply (rule antitonP_adm_non_P)
apply (rule antitonPI)
apply (drule gfp_upperbound)
apply (fast)
done

lemma adm_set:
"{\<Squnion>i. Y i |Y. Porder.chain Y & (\<forall>i. Y i \<in> P)} \<subseteq> P \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
apply (unfold adm_def)
apply (fast)
done

lemma def_gfp_admI: "P \<equiv> gfp F \<Longrightarrow> {\<Squnion>i. Y i |Y. Porder.chain Y \<and> (\<forall>i. Y i \<in> P)} \<subseteq>
  F {\<Squnion>i. Y i |Y. Porder.chain Y \<and> (\<forall>i. Y i \<in> P)} \<Longrightarrow> adm (\<lambda>x. x\<in>P)"
apply (simp)
apply (rule adm_set)
apply (erule gfp_upperbound)
done

end


(* Authors: F. Maric, M. Spasic *)
section \<open>Auxiliary Results\<close>
theory Simplex_Auxiliary
  imports
    "HOL-Library.Mapping"
begin

(* -------------------------------------------------------------------------- *)
(* MoreList *)
(* -------------------------------------------------------------------------- *)
lemma map_reindex:
  assumes "\<forall> i < length l. g (l ! i) = f i"
  shows "map f [0..<length l] = map g l"
  using assms
  by (induct l rule: rev_induct) (auto simp add: nth_append split: if_splits)

lemma map_parametrize_idx:
  "map f l = map (\<lambda>i. f (l ! i)) [0..<length l]"
  by (induct l rule: rev_induct) (auto simp add: nth_append)

lemma last_tl:
  assumes "length l > 1"
  shows "last (tl l) = last l"
  using assms
  by (induct l) auto

lemma hd_tl:
  assumes "length l > 1"
  shows "hd (tl l) = l ! 1"
  using assms
  by (induct l) (auto simp add: hd_conv_nth)

lemma butlast_empty_conv_length:
  shows "(butlast l = []) = (length l \<le> 1)"
  by (induct l) (auto split: if_splits)

lemma butlast_nth:
  assumes "n + 1 < length l"
  shows "butlast l ! n = l ! n"
  using assms
  by (induct l rule: rev_induct) (auto simp add: nth_append)

lemma last_take_conv_nth:
  assumes "0 < n" "n \<le> length l"
  shows "last (take n l) = l ! (n - 1)"
  using assms
  by (cases "l = []") (auto simp add: last_conv_nth min_def)

lemma tl_nth:
  assumes "l \<noteq> []"
  shows "tl l ! n = l ! (n + 1)"
  using assms
  by (induct l) auto

lemma interval_3split:
  assumes "i < n"
  shows "[0..<n] = [0..<i] @ [i] @ [i+1..<n]"
proof-
  have "[0..<n] = [0..<i + 1] @ [i + 1..<n]"
    using upt_add_eq_append[of 0 "i + 1" "n - i - 1"]
    using \<open>i < n\<close>
    by (auto simp del: upt_Suc)
  then show ?thesis
    by simp
qed

abbreviation "list_min l \<equiv> foldl min (hd l) (tl l)"
lemma list_min_Min[simp]: "l \<noteq> [] \<Longrightarrow> list_min l = Min (set l)"
proof (induct l rule: rev_induct)
  case (snoc a l')
  then show ?case
    by (cases "l' = []") (auto simp add: ac_simps)
qed simp

(* Minimal element of a list satisfying the given property *)

definition min_satisfying :: "(('a::linorder) \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option" where
  "min_satisfying P l \<equiv>
    let xs = filter P l in
    if xs = [] then None else Some (list_min xs)"

lemma min_satisfying_None:
  "min_satisfying P l = None \<longrightarrow>
    (\<forall> x \<in> set l. \<not> P x)"
  unfolding min_satisfying_def Let_def
  by (simp add: filter_empty_conv)

lemma min_satisfying_Some:
  "min_satisfying P l = Some x \<longrightarrow>
      x \<in> set l \<and> P x \<and> (\<forall> x' \<in> set l. x' < x \<longrightarrow> \<not> P x')"
proof (safe)
  let ?xs = "filter P l"
  assume "min_satisfying P l = Some x"
  then have "set ?xs \<noteq> {}" "x = Min (set ?xs)"
    unfolding min_satisfying_def Let_def
    by (auto split: if_splits simp add: filter_empty_conv)
  then show "x \<in> set l" "P x"
    using Min_in[of "set ?xs"]
    by simp_all
  fix x'
  assume "x' \<in> set l" "P x'" "x' < x"
  have "x' \<notin> set ?xs"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "x' \<ge> x"
      using \<open>x = Min (set ?xs)\<close>
      by simp
    then show False
      using \<open>x' < x\<close>
      by simp
  qed
  then show "False"
    using \<open>x' \<in> set l\<close> \<open>P x'\<close>
    by simp
qed

(* -------------------------------------------------------------------------- *)
(* MoreNat *)
(* -------------------------------------------------------------------------- *)

lemma min_element:
  fixes k :: nat
  assumes "\<exists> (m::nat). P m"
  shows "\<exists> mm. P mm \<and> (\<forall> m'. m' < mm \<longrightarrow> \<not> P m')"
proof-
  from assms obtain m where "P m"
    by auto
  show ?thesis
  proof (cases "\<forall>m'<m. \<not> P m'")
    case True
    then show ?thesis
      using \<open>P m\<close>
      by auto
  next
    case False
    then show ?thesis
    proof (induct m)
      case 0
      then show ?case
        by auto
    next
      case (Suc m')
      then show ?case
        by (cases "\<not> (\<forall>m'a<m'. \<not> P m'a)") auto
    qed
  qed
qed

(* -------------------------------------------------------------------------- *)
(* MoreFun *)
(* -------------------------------------------------------------------------- *)

lemma finite_fun_args:
  assumes "finite A" "\<forall> a \<in> A. finite (B a)"
  shows "finite {f. (\<forall> a. if a \<in> A then f a \<in> B a else f a = f0 a)}" (is "finite (?F A)")
  using assms
proof (induct)
  case empty
  have "?F {} = {\<lambda> x. f0 x}"
    by auto
  then show ?case
    by auto
next
  case (insert a A')
  then have "finite (?F A')"
    by auto
  let ?f = "\<lambda> f. {f'. (\<forall> a'. if a = a' then f' a \<in> B a else f' a' = f a')}"
  have "\<forall> f \<in> ?F A'. finite (?f f)"
  proof
    fix f
    assume "f \<in> ?F A'"
    then have "?f f = (\<lambda> b. f (a := b)) ` B a"
      by (force split: if_splits)
    then show "finite (?f f)"
      using \<open>\<forall>a\<in>insert a A'. finite (B a)\<close>
      by auto
  qed
  then have "finite (\<Union> (?f ` (?F A')))"
    using \<open>finite (?F A')\<close>
    by auto
  moreover
  have "?F (insert a A') = \<Union> (?f ` (?F A'))"
  proof
    show "?F (insert a A') \<subseteq> \<Union> (?f ` (?F A'))"
    proof
      fix f
      assume "f \<in> ?F (insert a A')"
      then have "f \<in> ?f (f (a := f0 a))" "f (a := f0 a) \<in> ?F A'"
        using \<open>a \<notin> A'\<close>
        by auto
      then show "f \<in> \<Union> (?f ` (?F A'))"
        by blast
    qed
  next
    show "\<Union> (?f ` (?F A')) \<subseteq> ?F (insert a A')"
    proof
      fix f
      assume "f \<in> \<Union> (?f ` (?F A'))"
      then obtain f0 where "f0 \<in> ?F A'" "f \<in> ?f f0"
        by auto
      then show "f \<in> ?F (insert a A')"
        using \<open>a \<notin> A'\<close>
        by (force split: if_splits)
    qed
  qed
  ultimately
  show ?case
    by simp
qed

(* -------------------------------------------------------------------------- *)
(* MoreMapping *)
(* -------------------------------------------------------------------------- *)

lemma foldl_mapping_update:
  assumes "X \<in> set l" "distinct (map f l)"
  shows "Mapping.lookup (foldl (\<lambda>m a. Mapping.update (f a) (g a) m) i l) (f X) = Some (g X)"
  using assms
proof(induct l rule:rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc h t)
  show ?case
  proof (cases "f h = f X")
    case True
    then show ?thesis using snoc by (auto simp: lookup_update)
  next
    case False
    show ?thesis by (simp add: lookup_update' False, rule snoc, insert False snoc, auto)
  qed
qed

end