(*  Title:      Sort.thy
    Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)

header {* Verification of Functional Heap Sort *}

theory HeapFunctional
imports Heap
begin

text{* As we
said before, maximum element of the heap is its root. So, finding
maximum element is not difficulty. But, this element should also be
removed and remainder after deleting this element is two trees, left
and right branch of original heap. Those branches are also heaps by
the definition of the heap. To maintain consistency, branches should
be combined into one tree that satisfies heap condition: *}

function merge :: "'a::linorder Tree \<Rightarrow> 'a Tree \<Rightarrow> 'a Tree" where
  "merge t1 E = t1"
| "merge E t2 = t2"
| "merge (T v1 l1 r1) (T v2 l2 r2) =
     (if v1 \<ge> v2 then T v1 (merge l1 (T v2 l2 r2)) r1
      else T v2 (merge l2 (T v1 l1 r1)) r2)"
by (pat_completeness) auto
termination
proof (relation "measure (\<lambda> (t1, t2). size t1 + size t2)")
  fix v1 l1 r1 v2 l2 r2
  assume "v2 \<le> v1"
  thus "((l1, T v2 l2 r2), T v1 l1 r1, T v2 l2 r2) \<in>
        measure (\<lambda>(t1, t2). Heap.size t1 + Heap.size t2)"
    by auto
next
  fix v1 l1 r1 v2 l2 r2
  assume "\<not> v2 \<le> v1"
  thus "((l2, T v1 l1 r1), T v1 l1 r1, T v2 l2 r2) \<in>
        measure (\<lambda>(t1, t2). Heap.size t1 + Heap.size t2)"
    by auto
qed simp

lemma merge_val:
  "val(merge l r) = val l \<or> val(merge l r) = val r"
proof(induct l r rule:merge.induct)
  case (1 l)
  thus ?case
    by auto
next
  case (2 r)
  thus ?case
    by auto
next
  case (3 v1 l1 r1 v2 l2 r2)
  thus ?case
  proof(cases "v2 \<le> v1")
    case True
    hence "val (merge (T v1 l1 r1) (T v2 l2 r2)) = val (T v1 l1 r1)"
      by auto
    thus ?thesis
      by auto
  next
    case False
    hence "val (merge (T v1 l1 r1) (T v2 l2 r2)) = val (T v2 l2 r2)"
      by auto
    thus ?thesis
      by auto
  qed
qed

text{* Function {\em merge} merges two heaps into one: *}

lemma merge_heap_is_heap:
  assumes "is_heap l" "is_heap r"
  shows "is_heap (merge l r)"
using assms
proof(induct l r rule:merge.induct)
  case (1 l)
  thus ?case
    by auto
next
  case (2 r)
  thus ?case
    by auto
next
  case (3 v1 l1 r1 v2 l2 r2)
  thus ?case
  proof(cases "v2 \<le> v1")
    case True
    have "is_heap l1"
      using `is_heap (T v1 l1 r1)`
      by (metis Tree.exhaust is_heap.simps(1) is_heap.simps(4) is_heap.simps(5))
    hence "is_heap (merge l1 (T v2 l2 r2))"
      using True `is_heap (T v2 l2 r2)`  3
      by auto
    have "val (merge l1 (T v2 l2 r2)) = val l1 \<or> val(merge l1 (T v2 l2 r2)) = v2"
      using merge_val[of l1 "T v2 l2 r2"]
      by auto
    show ?thesis
    proof(cases "r1 = E")
      case True
      show ?thesis
      proof(cases "l1 = E")
        case True
        hence "merge (T v1 l1 r1) (T v2 l2 r2) = T v1 (T v2 l2 r2) E"
          using `r1 = E` `v2 \<le> v1`
          by auto
        thus ?thesis
          using 3
          using `v2 \<le> v1`
          by auto
      next
        case False
        hence "v1 \<ge> val l1"
          using 3(3)
          by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
        thus ?thesis
          using `r1 = E` `v1 \<ge> v2`
          using `val (merge l1 (T v2 l2 r2)) = val l1
                     \<or> val(merge l1 (T v2 l2 r2)) = v2`
          using `is_heap (merge l1 (T v2 l2 r2))`
          by (metis False Tree.exhaust is_heap.simps(2)
              is_heap.simps(4) merge.simps(3) val.simps)
      qed
    next
      case False
      hence "v1 \<ge> val r1"
        using 3(3)
        by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
      show ?thesis
      proof(cases "l1 = E")
        case True
        hence "merge (T v1 l1 r1) (T v2 l2 r2) = T v1 (T v2 l2 r2) r1"
          using `v2 \<le> v1`
          by auto
        thus ?thesis
          using 3 `v1 \<ge> val r1`
          using `v2 \<le> v1`
          by (metis False Tree.exhaust Tree.inject Tree.simps(3)
              True is_heap.simps(3) is_heap.simps(6) merge.simps(2)
              merge.simps(3) order_eq_iff val.simps)
      next
        case False
        hence "v1 \<ge> val l1"
          using 3(3)
          by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
        have "merge l1 (T v2 l2 r2) \<noteq> E"
          using False
          by (metis Tree.exhaust Tree.simps(2) merge.simps(3))
        have "is_heap r1"
          using 3(3)
          by (metis False Tree.exhaust `r1 \<noteq> E` is_heap.simps(5))
        obtain ll1 lr1 lv1 where "r1 = T lv1 ll1 lr1"
          using `r1 \<noteq> E`
          by (metis Tree.exhaust)
        obtain rl1 rr1 rv1 where "merge l1 (T v2 l2 r2) = T rv1 rl1 rr1"
          using `merge l1 (T v2 l2 r2) \<noteq> E`
          by (metis Tree.exhaust)
        have "val (merge l1 (T v2 l2 r2)) \<le> v1"
          using `val (merge l1 (T v2 l2 r2)) = val l1 \<or>
                 val(merge l1 (T v2 l2 r2)) = v2`
          using `v1 \<ge> v2` `v1 \<ge> val l1`
          by auto
        hence "is_heap (T v1 (merge l1 (T v2 l2 r2)) r1)"
          using is_heap.simps(5)[of v1 lv1 ll1 lr1 rv1 rl1  rr1]
          using `r1 = T lv1 ll1 lr1` `merge l1 (T v2 l2 r2) = T rv1 rl1 rr1`
          using `is_heap r1` `is_heap (merge l1 (T v2 l2 r2))` `v1 \<ge> val r1`
          by auto
        thus ?thesis
          using `v2 \<le> v1`
          by auto
      qed
    qed
  next
    case False
    have "is_heap l2"
      using 3(4)
      by (metis Tree.exhaust is_heap.simps(1)
          is_heap.simps(4) is_heap.simps(5))
    hence "is_heap (merge l2 (T v1 l1 r1))"
      using False `is_heap (T v1 l1 r1)`  3
      by auto
    have "val (merge l2 (T v1 l1 r1)) = val l2 \<or>
          val(merge l2 (T v1 l1 r1)) = v1"
      using merge_val[of l2 "T v1 l1 r1"]
      by auto
    show ?thesis
    proof(cases "r2 = E")
      case True
      show ?thesis
      proof(cases "l2 = E")
        case True
        hence "merge (T v1 l1 r1) (T v2 l2 r2) = T v2 (T v1 l1 r1) E"
          using `r2 = E` `\<not> v2 \<le> v1`
          by auto
        thus ?thesis
          using 3
          using `\<not> v2 \<le> v1`
          by auto
      next
        case False
        hence "v2 \<ge> val l2"
          using 3(4)
          by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
        thus ?thesis
          using `r2 = E` `\<not> v1 \<ge> v2`
          using `is_heap (merge l2 (T v1 l1 r1))`
          using `val (merge l2 (T v1 l1 r1)) = val l2 \<or>
                 val(merge l2 (T v1 l1 r1)) = v1`
          by (metis False Tree.exhaust is_heap.simps(2)
              is_heap.simps(4) linorder_linear merge.simps(3) val.simps)
      qed
    next
      case False
      hence "v2 \<ge> val r2"
        using 3(4)
        by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
      show ?thesis
      proof(cases "l2 = E")
        case True
        hence "merge (T v1 l1 r1) (T v2 l2 r2) = T v2 (T v1 l1 r1) r2"
          using `\<not> v2 \<le> v1`
          by auto
        thus ?thesis
          using 3 `v2 \<ge> val r2`
          using `\<not> v2 \<le> v1`
          by (metis False Tree.exhaust Tree.simps(3) is_heap.simps(3)
              is_heap.simps(5) linorder_linear val.simps)
      next
        case False
        hence "v2 \<ge> val l2"
          using 3(4)
          by (metis Tree.exhaust in_tree.simps(2) is_heap_max val.simps)
        have "merge l2 (T v1 l1 r1) \<noteq> E"
          using False
          by (metis Tree.exhaust Tree.simps(2) merge.simps(3))
        have "is_heap r2"
          using 3(4)
          by (metis False Tree.exhaust `r2 \<noteq> E` is_heap.simps(5))
        obtain ll1 lr1 lv1 where "r2 = T lv1 ll1 lr1"
          using `r2 \<noteq> E`
          by (metis Tree.exhaust)
        obtain rl1 rr1 rv1 where "merge l2 (T v1 l1 r1) = T rv1 rl1 rr1"
          using `merge l2 (T v1 l1 r1) \<noteq> E`
          by (metis Tree.exhaust)
        have "val (merge l2 (T v1 l1 r1)) \<le> v2"
          using `val (merge l2 (T v1 l1 r1)) = val l2 \<or>
                 val(merge l2 (T v1 l1 r1)) = v1`
          using `\<not> v1 \<ge> v2` `v2 \<ge> val l2`
          by auto
        hence "is_heap (T v2 (merge l2 (T v1 l1 r1)) r2)"
          using is_heap.simps(5)[of v1 lv1 ll1 lr1 rv1 rl1 rr1]
          using `r2 = T lv1 ll1 lr1` `merge l2 (T v1 l1 r1) = T rv1 rl1 rr1`
          using `is_heap r2` `is_heap (merge l2 (T v1 l1 r1))` `v2 \<ge> val r2`
          by auto
        thus ?thesis
          using `\<not> v2 \<le> v1`
          by auto
      qed
    qed
  qed
qed

definition insert :: "'a::linorder \<Rightarrow> 'a Tree \<Rightarrow> 'a Tree" where
  "insert v t =  merge t (T v E E)"

primrec hs_of_list where
  "hs_of_list [] = E"
| "hs_of_list (v # l) = insert v (hs_of_list l)"

definition hs_is_empty where
[simp]: "hs_is_empty t \<longleftrightarrow>  t = E"

text{* Definition of function {\em remove\_max}: *}

fun hs_remove_max:: "'a::linorder Tree \<Rightarrow> 'a \<times> 'a Tree"  where
  "hs_remove_max (T v l r) = (v, merge l r)"

lemma merge_multiset:
  "multiset l + multiset g = multiset (merge l g)"
proof(induct l g rule:merge.induct)
  case (1 l)
  thus ?case
    by auto
next
  case (2 g)
  thus ?case
    by auto
next
  case (3 v1 l1 r1 v2 l2 r2)
  thus ?case
  proof(cases "v2 \<le> v1")
    case  True
    hence "multiset (merge (T v1 l1 r1) (T v2 l2 r2)) =
           {#v1#} + multiset (merge l1 (T v2 l2 r2)) +  multiset r1"
      by auto (metis union_commute)
    hence "multiset (merge (T v1 l1 r1) (T v2 l2 r2)) =
           {#v1#} + multiset l1 + multiset (T v2 l2 r2) + multiset r1"
      using 3 True
      by (metis union_assoc)
    hence "multiset (merge (T v1 l1 r1) (T v2 l2 r2)) =
           {#v1#} + multiset l1 + multiset r1 + multiset (T v2 l2 r2)"
      by (metis union_commute union_lcomm)
    thus ?thesis
      by auto (metis union_commute)
  next
    case False
    hence "multiset (merge (T v1 l1 r1) (T v2 l2 r2)) =
           {#v2#} + multiset (merge l2 (T v1 l1 r1)) + multiset r2"
      by auto (metis union_commute)
    hence "multiset (merge (T v1 l1 r1) (T v2 l2 r2)) =
           {#v2#} + multiset l2 + multiset r2 +  multiset (T v1 l1 r1)"
      using 3 False
      by (metis union_commute union_lcomm)
    thus ?thesis
      by (metis multiset.simps(2) union_commute)
  qed
qed

text{* Proof that defined functions are interpretation of abstract functions from locale {\em Collection}: *}

interpretation HS: Collection "E" hs_is_empty hs_of_list multiset
proof
   fix t
  assume "hs_is_empty t"
  thus "t = E"
    by auto
next
  show "hs_is_empty E"
    by auto
next
  show "multiset E = {#}"
    by auto
next
  fix l
  show "multiset (hs_of_list l) = multiset_of l"
  proof(induct l)
    case Nil
    thus ?case
      by auto
  next
    case (Cons a l)
    have "multiset (hs_of_list (a # l)) = multiset (hs_of_list l) + {#a#}"
      using merge_multiset[of "hs_of_list l" "T a E E"]
      apply auto
      unfolding insert_def
      by auto
    thus ?case
      using Cons
      by auto
  qed
qed

text{* Proof that defined functions are interpretation of abstract functions from locale {\em Heap}: *}

interpretation Heap "E" hs_is_empty hs_of_list multiset id hs_remove_max
proof
  fix l
  show "multiset l = Heap.multiset (id l)"
    by auto
next
  fix l
  show "is_heap (id (hs_of_list l))"
  proof(induct l)
    case Nil
    thus ?case
      by auto
  next
    case (Cons a l)
    have "hs_of_list (a # l) = merge (hs_of_list l) (T a E E)"
      apply auto
      unfolding insert_def
      by auto
    have "is_heap (T a E E)"
      by auto
    hence "is_heap (merge (hs_of_list l) (T a E E))"
      using Cons merge_heap_is_heap[of "hs_of_list l" "T a E E"]
      by auto
    thus ?case
      using `hs_of_list (a # l) = merge (hs_of_list l) (T a E E)`
      by auto
  qed
next
  fix t
  show " (id t = E) = hs_is_empty t"
    by auto
next
  fix t m t'
  assume "\<not> hs_is_empty t" "(m, t') = hs_remove_max t"
  then obtain l r where "t = T m l r"
    by (metis Pair_inject Tree.exhaust hs_is_empty_def hs_remove_max.simps)
  thus "multiset t' + {#m#} = multiset t"
    using merge_multiset[of l r]
    using `(m, t') = hs_remove_max t`
    by (metis Pair_eq multiset.simps(2) hs_remove_max.simps
        union_assoc union_commute)
next
  fix t m t'
  assume "\<not> hs_is_empty t" "is_heap (id t)" "(m, t') = hs_remove_max t"
  then obtain v l r where "t = T v l r"
    by (metis Tree.exhaust hs_is_empty_def)
  hence "t' = merge l r"
    using `(m, t') = hs_remove_max t`
    by auto
  have "is_heap l \<and> is_heap r"
    using `is_heap (id t)`
    using `t = T v l r`
    by (metis Tree.exhaust id_apply is_heap.simps(1)
        is_heap.simps(3) is_heap.simps(4) is_heap.simps(5))
  thus "is_heap (id t')"
    using `t' = merge l r`
    using merge_heap_is_heap
    by auto
next
  fix t m t'
  assume "\<not> hs_is_empty t" "(m, t') = hs_remove_max t"
  thus "m = val (id t)"
    by (metis Pair_inject Tree.exhaust hs_is_empty_def
        hs_remove_max.simps id_apply val.simps)
qed

end


(*
    Authors:    Jose Divasón
                Sebastiaan Joosten
                René Thiemann
                Akihisa Yamada
    License:    BSD
*)

section \<open>Executable dvdm operation\<close>

text \<open>This theory contains some results about division of integer polynomials which are not part of
  Polynomial\_Factorization.Dvd\_Int\_Poly.thy.

  Essentially, we give an executable implementation of division modulo m.
\<close>

theory Missing_Dvd_Int_Poly
imports
  Berlekamp_Zassenhaus.Poly_Mod_Finite_Field
  Berlekamp_Zassenhaus.Polynomial_Record_Based
  Berlekamp_Zassenhaus.Hensel_Lifting (* for thm pdivmod_monic, should be moved *)
  Subresultants.Subresultant (* for abbreviation pdivmod *)
  Perron_Frobenius.Cancel_Card_Constraint
begin

(*In mathematics, this lemma also works if q = 0 since degree 0 = -\<infinity>, but in Isabelle degree 0 = 0.*)
lemma degree_div_mod_smult:
  fixes g::"int poly"
  assumes g: "degree g < j"
  and r: "degree r < d"
  and u: "degree u = d"
  and g1: "g = q * u + smult m r"
  and q: "q \<noteq> 0" and m_not0: "m \<noteq> 0"
shows "degree q < j - d"
proof -
  have u_not0: "u\<noteq>0" using u r by auto
  have d_uq: "d \<le> degree (u*q)" using u degree_mult_right_le[OF q] by auto
  have j: "j > degree (q* u + smult m r)" using g1 g by auto
  have "degree (smult m r) < d" using degree_smult_eq m_not0 r by auto
  also have "... \<le> degree (u*q)" using d_uq by auto
  finally have deg_mr_uq: "degree (smult m r) < degree (q*u)"
    by (simp add: mult.commute)
  have j2: "degree (q* u + smult m r) = degree (q*u)"
    by (rule degree_add_eq_left[OF deg_mr_uq])
  also have "... = degree q + degree u"
    by (rule degree_mult_eq[OF q u_not0])
  finally have "degree q = degree g - degree u" using g1 by auto
  thus ?thesis
    using j j2 \<open>degree (q * u) = degree q + degree u\<close> u
    by linarith
qed

subsection \<open>Uniqueness of division algorithm for polynomials\<close>

lemma uniqueness_algorithm_division_poly:
  fixes f::"'a::{comm_ring,semiring_1_no_zero_divisors} poly"
  assumes f1: "f = g * q1 + r1"
      and f2: "f = g * q2 + r2"
      and g: "g \<noteq> 0"
      and r1: "r1 = 0 \<or> degree r1 < degree g"
      and r2: "r2 = 0 \<or> degree r2 < degree g"
    shows "q1 = q2 \<and> r1 = r2"
proof -
  have "0 =  g * q1 + r1 - (g * q2 + r2)" using f1 f2 by auto
  also have "... = g * (q1 - q2) + r1 - r2"
    by (simp add: right_diff_distrib)
  finally have eq: "g * (q1 - q2) = r2 - r1" by auto
  have q_eq: "q1 = q2"
  proof (rule ccontr)
    assume q1_not_q2: "q1 \<noteq> q2"
    hence nz: "g * (q1 - q2) \<noteq> 0" using g by auto
    hence "degree (g * (q1 - q2)) \<ge> degree g"
      by (simp add: degree_mult_right_le)
    moreover have "degree (r2 - r1) < degree g"
      using eq nz degree_diff_less r1 r2 by auto
    ultimately show False using eq by auto
  qed
  moreover have "r1 = r2" using eq q_eq by auto
  ultimately show ?thesis by simp
qed

lemma pdivmod_eq_pdivmod_monic:
  assumes g: "monic g"
  shows "pdivmod f g = pdivmod_monic f g"
proof -
  obtain q r where qr: "pdivmod f g = (q,r)" by simp
  obtain Q R where QR: "pdivmod_monic f g = (Q,R)" by (meson surj_pair)
  have g0: "g \<noteq> 0" using g by auto
  have f1: "f = g * q + r"
    by (metis Pair_inject mult_div_mod_eq qr)
  have r: "r=0 \<or> degree r < degree g"
    by (metis Pair_inject assms degree_mod_less leading_coeff_0_iff qr zero_neq_one)
  have f2: "f = g * Q + R"
    by (simp add: QR assms pdivmod_monic(1))
  have R: "R=0 \<or> degree R < degree g"
    by (rule pdivmod_monic[OF g QR])
  have "q=Q \<and> r=R" by (rule uniqueness_algorithm_division_poly[OF f1 f2 g0 r R])
  thus ?thesis using qr QR by auto
qed

context poly_mod
begin

definition "pdivmod2 f g = (if Mp g = 0 then (0, f)
 else let ilc = inverse_p m ((lead_coeff (Mp g)));
      h = Polynomial.smult ilc (Mp g); (q, r) = pseudo_divmod (Mp f) (Mp h)
      in (Polynomial.smult ilc q, r))"
end

context poly_mod_prime_type
begin

lemma dvdm_iff_pdivmod0:
  assumes f: "(F :: 'a mod_ring poly) = of_int_poly f"
  and g: "(G :: 'a mod_ring poly) = of_int_poly g"
  shows "g dvdm f = (snd (pdivmod F G) = 0)"
proof -
  have [transfer_rule]: "MP_Rel f F" unfolding MP_Rel_def
    by (simp add: Mp_f_representative f)
  have [transfer_rule]: "MP_Rel g G" unfolding MP_Rel_def
    by (simp add: Mp_f_representative g)
  have "(snd (pdivmod F G) = 0) = (G dvd F)"
    unfolding dvd_eq_mod_eq_0 by auto
  from this [untransferred] show ?thesis by simp
qed

lemma of_int_poly_Mp_0[simp]: "(of_int_poly (Mp a) = (0:: 'a mod_ring poly)) = (Mp a = 0)"
  by (auto, metis Mp_f_representative map_poly_0 poly_mod.Mp_Mp)

lemma uniqueness_algorithm_division_of_int_poly:
  assumes g0: "Mp g \<noteq> 0"
  and f: "(F :: 'a mod_ring poly) = of_int_poly f"
  and g: "(G :: 'a mod_ring poly) = of_int_poly g"
  and F: "F = G * Q + R"
  and R: "R = 0 \<or> degree R < degree G"
  and Mp_f: "Mp f = Mp g * q + r"
  and r: "r = 0 \<or> degree r < degree (Mp g)"
shows "Q = of_int_poly q \<and> R = of_int_poly r"
proof (rule uniqueness_algorithm_division_poly[OF F _ _ R])
  have f': "Mp f = to_int_poly F" unfolding f
    by (simp add: Mp_f_representative)
  have g': "Mp g = to_int_poly G" unfolding g
    by (simp add: Mp_f_representative)
  have f'': "of_int_poly (Mp f) = F"
    by (metis (no_types, lifting) Dp_Mp_eq Mp_f_representative
        Mp_smult_m_0 add_cancel_left_right f map_poly_zero of_int_hom.map_poly_hom_add
        to_int_mod_ring_hom.hom_zero to_int_mod_ring_hom.injectivity)
  have g'': "of_int_poly (Mp g) = G"
    by (metis (no_types, lifting) Dp_Mp_eq Mp_f_representative
        Mp_smult_m_0 add_cancel_left_right g map_poly_zero of_int_hom.map_poly_hom_add
        to_int_mod_ring_hom.hom_zero to_int_mod_ring_hom.injectivity)
  have "F = of_int_poly (Mp g * q + r)" using Mp_f  f'' by auto
  also have "... = G * of_int_poly q + of_int_poly r"
    by (simp add: g'' of_int_poly_hom.hom_add of_int_poly_hom.hom_mult)
  finally show "F = G * of_int_poly q + of_int_poly r" .
  show "of_int_poly r = 0 \<or> degree (of_int_poly r::'a mod_ring poly) < degree G"
  proof (cases "r = 0")
    case True
    hence "of_int_poly r = 0" by auto
    then show ?thesis by auto
  next
    case False
    have "degree (of_int_poly r::'a mod_ring poly) \<le> degree (r)"
    by (simp add: degree_map_poly_le)
    also have "... < degree (Mp g)" using r False by auto
    also have "... = degree G" by (simp add: g')
    finally show ?thesis by auto
  qed
  show "G \<noteq> 0" using g0 unfolding g''[symmetric] by simp
qed

corollary uniqueness_algorithm_division_to_int_poly:
  assumes g0: "Mp g \<noteq> 0"
  and f: "(F :: 'a mod_ring poly) = of_int_poly f"
  and g: "(G :: 'a mod_ring poly) = of_int_poly g"
  and F: "F = G * Q + R"
  and R: "R = 0 \<or> degree R < degree G"
  and Mp_f: "Mp f = Mp g * q + r"
  and r: "r = 0 \<or> degree r < degree (Mp g)"
  shows "Mp q = to_int_poly Q \<and> Mp r = to_int_poly R"
  using uniqueness_algorithm_division_of_int_poly[OF assms]
  by (auto simp add: Mp_f_representative)

lemma uniqueness_algorithm_division_Mp_Rel:
  assumes monic_Mpg: "monic (Mp g)"
    and f: "(F :: 'a mod_ring poly) = of_int_poly f"
  and g: "(G :: 'a mod_ring poly) = of_int_poly g"
  and qr: "pseudo_divmod (Mp f) (Mp g) = (q,r)"
  and QR: "pseudo_divmod F G = (Q,R)"
shows "MP_Rel q Q \<and> MP_Rel r R "
proof (unfold MP_Rel_def, rule uniqueness_algorithm_division_to_int_poly[OF _ f g])
  show f_gq_r: "Mp f = Mp g * q + r"
    by (rule pdivmod_monic(1)[OF monic_Mpg], simp add: pdivmod_monic_pseudo_divmod qr monic_Mpg)
  have monic_G: "monic G" using monic_Mpg
    using Mp_f_representative g by auto
  show "F = G * Q + R"
    by (rule pdivmod_monic(1)[OF monic_G], simp add: pdivmod_monic_pseudo_divmod QR monic_G)
  show "Mp g \<noteq> 0" using monic_Mpg by auto
  show "R = 0 \<or> degree R < degree G"
    by (rule pdivmod_monic(2)[OF monic_G],
        auto simp add: pdivmod_monic_pseudo_divmod monic_G intro: QR)
  show "r = 0 \<or> degree r < degree (Mp g)"
    by (rule pdivmod_monic(2)[OF monic_Mpg],
        auto simp add: pdivmod_monic_pseudo_divmod monic_Mpg intro: qr)
qed

definition "MP_Rel_Pair A B \<equiv> (let (a,b) = A; (c,d) = B in MP_Rel a c \<and> MP_Rel b d)"

lemma pdivmod2_rel[transfer_rule]:
  "(MP_Rel ===> MP_Rel ===> MP_Rel_Pair) (pdivmod2) (pdivmod)"
proof (auto simp add: rel_fun_def MP_Rel_Pair_def)
  interpret pm: prime_field m
    using m unfolding prime_field_def mod_ring_locale_def by auto
  have p: "prime_field TYPE('a) m"
    using m unfolding prime_field_def mod_ring_locale_def by auto
  fix f F g G a b
  assume 1[transfer_rule]: "MP_Rel f F"
     and 2[transfer_rule]: "MP_Rel g G"
     and 3: "pdivmod2 f g = (a, b)"
  have "MP_Rel a (F div G) \<and> MP_Rel b (F mod G)"
  proof (cases "Mp g \<noteq> 0")
    case True note Mp_g = True
    have G: "G \<noteq> 0" using Mp_g 2 unfolding MP_Rel_def by auto
    have gG[transfer_rule]: "pm.mod_ring_rel (lead_coeff (Mp g)) (lead_coeff G)"
      using 2
      unfolding pm.mod_ring_rel_def MP_Rel_def
      by auto
    have [transfer_rule]: "(pm.mod_ring_rel ===> pm.mod_ring_rel) (inverse_p m) inverse"
      by (rule prime_field.mod_ring_inverse[OF p])
    hence rel_inverse_p[transfer_rule]:
      "pm.mod_ring_rel (inverse_p m ((lead_coeff (Mp g)))) (inverse (lead_coeff G))"
      using gG unfolding rel_fun_def by auto
    let ?h= "(Polynomial.smult (inverse_p m (lead_coeff (Mp g))) g)"
    define h where h: "h = Polynomial.smult (inverse_p m (lead_coeff (Mp g))) (Mp g)"
    define H where H: "H = Polynomial.smult (inverse (lead_coeff G)) G"
    have hH': "MP_Rel ?h H" unfolding MP_Rel_def unfolding H
      by (metis (mono_tags, hide_lams) "2" MP_Rel_def M_to_int_mod_ring Mp_f_representative
         rel_inverse_p functional_relation left_total_MP_Rel of_int_hom.map_poly_hom_smult
         pm.mod_ring_rel_def right_unique_MP_Rel to_int_mod_ring_hom.injectivity to_int_mod_ring_of_int_M)
     have "Mp (Polynomial.smult (inverse_p m (lead_coeff (Mp g))) g)
      = Mp (Polynomial.smult (inverse_p m (lead_coeff (Mp g))) (Mp g))" by simp
    hence hH: "MP_Rel h H" using hH' h unfolding MP_Rel_def by auto
    obtain q x where pseudo_fh: "pseudo_divmod (Mp f) (Mp h) = (q, x)" by (meson surj_pair)
    hence lc_G: "(lead_coeff G) \<noteq> 0" using G by auto
    have a: "a = Polynomial.smult (inverse_p m ((lead_coeff (Mp g)))) q"
      using 3 pseudo_fh Mp_g
      unfolding pdivmod2_def Let_def h by auto
    have b: "b = x" using 3 pseudo_fh Mp_g
      unfolding pdivmod2_def Let_def h by auto
    have Mp_Rel_FH: "MP_Rel q (F div H) \<and> MP_Rel x (F mod H)"
    proof (rule uniqueness_algorithm_division_Mp_Rel)
      show "monic (Mp h)"
      proof -
        have aux: "(inverse_p m (lead_coeff (Mp g))) = to_int_mod_ring (inverse (lead_coeff G))"
          using rel_inverse_p unfolding pm.mod_ring_rel_def by auto
        hence "M (inverse_p m (M (poly.coeff g (degree (Mp g)))))
          = to_int_mod_ring (inverse (lead_coeff G))"
          by (simp add: M_to_int_mod_ring Mp_coeff)
        thus ?thesis unfolding h unfolding Mp_coeff by auto
          (metis (no_types, lifting) "2" H MP_Rel_def Mp_coeff aux degree_smult_eq gG hH'
          inverse_zero_imp_zero lc_G left_inverse pm.mod_ring_rel_def to_int_mod_ring_hom.degree_map_poly_hom
          to_int_mod_ring_hom.hom_one to_int_mod_ring_times)
      qed
      hence monic_H: "monic H" using hH H lc_G by auto
      show f: "F = of_int_poly f"
        using 1 unfolding MP_Rel_def
        by (simp add: Mp_f_representative poly_eq_iff)
      have "pdivmod F H = pdivmod_monic F H"
        by (rule pdivmod_eq_pdivmod_monic[OF monic_H])
      also have "... = pseudo_divmod F H"
        by (rule pdivmod_monic_pseudo_divmod[OF monic_H])
      finally show "pseudo_divmod F H = (F div H, F mod H)" by simp
      show "H = of_int_poly h"
        by (meson MP_Rel_def Mp_f_representative hH right_unique_MP_Rel right_unique_def)
      show "pseudo_divmod (Mp f) (Mp h) = (q, x)" by (rule pseudo_fh)
    qed
    hence Mp_Rel_F_div_H: "MP_Rel q (F div H)" and Mp_Rel_F_mod_H: "MP_Rel x (F mod H)" by auto
    have "F div H = Polynomial.smult (lead_coeff G) (F div G)"
      unfolding H using div_smult_right[OF lc_G] inverse_inverse_eq
      by (metis div_smult_right inverse_zero)
    hence F_div_G: "(F div G) = Polynomial.smult (inverse (lead_coeff G)) (F div H)"
      using lc_G by auto
    have "MP_Rel a (F div G)"
    proof -
      have "of_int_poly (Polynomial.smult (inverse_p m ((lead_coeff (Mp g)))) q)
        = smult (inverse (lead_coeff G)) (F div H)"
        by (metis (mono_tags) MP_Rel_def M_to_int_mod_ring Mp_Rel_F_div_H Mp_f_representative
            of_int_hom.map_poly_hom_smult pm.mod_ring_rel_def rel_inverse_p right_unique_MP_Rel
            right_unique_def to_int_mod_ring_hom.injectivity to_int_mod_ring_of_int_M)
      thus ?thesis
      using Mp_Rel_F_div_H
      unfolding MP_Rel_def a F_div_G Mp_f_representative by auto
    qed
    moreover have "MP_Rel b (F mod G)"
      using Mp_Rel_F_mod_H b H inverse_zero_imp_zero lc_G
      by (metis mod_smult_right)
    ultimately show ?thesis by auto
  next
    assume Mp_g_0: "\<not> Mp g \<noteq> 0"
    hence "pdivmod2 f g = (0, f)" unfolding pdivmod2_def by auto
    hence a: "a = 0" and b: "b = f" using 3 by auto
    have G0: "G = 0" using Mp_g_0 2 unfolding MP_Rel_def by auto
    have "MP_Rel a (F div G)" unfolding MP_Rel_def G0 a by auto
    moreover have "MP_Rel b (F mod G)" using 1 unfolding MP_Rel_def G0 a b by auto
    ultimately show ?thesis by simp
  qed
  thus "MP_Rel a (F div G)" and "MP_Rel b (F mod G)" by auto
qed

subsection \<open>Executable division operation modulo $m$ for polynomials\<close>

lemma dvdm_iff_Mp_pdivmod2:
  shows "g dvdm f = (Mp (snd (pdivmod2 f g)) = 0)"
proof -
  let ?F="(of_int_poly f)::'a mod_ring poly"
  let ?G="(of_int_poly g)::'a mod_ring poly"
  have a[transfer_rule]: "MP_Rel f ?F"
    by (simp add: MP_Rel_def Mp_f_representative)
  have b[transfer_rule]: "MP_Rel g ?G"
    by (simp add: MP_Rel_def Mp_f_representative)
  have "MP_Rel_Pair (pdivmod2 f g) (pdivmod ?F ?G)"
    using pdivmod2_rel unfolding rel_fun_def using a b by auto
  hence "MP_Rel (snd (pdivmod2 f g)) (snd (pdivmod ?F ?G))"
    unfolding MP_Rel_Pair_def by auto
  hence "(Mp (snd (pdivmod2 f g)) = 0) = (snd (pdivmod ?F ?G) = 0)"
    unfolding MP_Rel_def by auto
  thus ?thesis using dvdm_iff_pdivmod0 by auto
qed

end

lemmas (in poly_mod_prime) dvdm_pdivmod = poly_mod_prime_type.dvdm_iff_Mp_pdivmod2
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set,
   unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemma (in poly_mod) dvdm_code:
   "g dvdm f = (if prime m then Mp (snd (pdivmod2 f g)) = 0
    else Code.abort (STR ''dvdm error: m is not a prime number'') (\<lambda> _. g dvdm f))"
  using poly_mod_prime.dvdm_pdivmod[unfolded poly_mod_prime_def]
  by auto

declare poly_mod.pdivmod2_def[code]
declare poly_mod.dvdm_code[code]

end


(*
  File:    Product_PMF.thy
  Authors: Manuel Eberl, Max W. Haslbeck
*)
section \<open>Indexed products of PMFs\<close>
theory Product_PMF
  imports Probability_Mass_Function Independent_Family
begin

subsection \<open>Preliminaries\<close>

lemma pmf_expectation_eq_infsetsum: "measure_pmf.expectation p f = infsetsum (\<lambda>x. pmf p x * f x) UNIV"
  unfolding infsetsum_def measure_pmf_eq_density by (subst integral_density) simp_all

lemma measure_pmf_prob_product:
  assumes "countable A" "countable B"
  shows "measure_pmf.prob (pair_pmf M N) (A \<times> B) = measure_pmf.prob M A * measure_pmf.prob N B"
proof -
  have "measure_pmf.prob (pair_pmf M N) (A \<times> B) = (\<Sum>\<^sub>a(a, b)\<in>A \<times> B. pmf M a * pmf N b)"
    by (auto intro!: infsetsum_cong simp add: measure_pmf_conv_infsetsum pmf_pair)
  also have "\<dots> = measure_pmf.prob M A * measure_pmf.prob N B"
    using assms by (subst infsetsum_product) (auto simp add: measure_pmf_conv_infsetsum)
  finally show ?thesis
    by simp
qed

subsection \<open>Definition\<close>

text \<open>
  In analogy to @{const PiM}, we define an indexed product of PMFs. In the literature, this
  is typically called taking a vector of independent random variables. Note that the components
  do not have to be identically distributed.

  The operation takes an explicit index set \<^term>\<open>A :: 'a set\<close> and a function \<^term>\<open>f :: 'a \<Rightarrow> 'b pmf\<close>
  that maps each element from \<^term>\<open>A\<close> to a PMF and defines the product measure
  $\bigotimes_{i\in A} f(i)$ , which is represented as a \<^typ>\<open>('a \<Rightarrow> 'b) pmf\<close>.

  Note that unlike @{const PiM}, this only works for \<^emph>\<open>finite\<close> index sets. It could
  be extended to countable sets and beyond, but the construction becomes somewhat more involved.
\<close>
definition Pi_pmf :: "'a set \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b pmf) \<Rightarrow> ('a \<Rightarrow> 'b) pmf" where
  "Pi_pmf A dflt p =
     embed_pmf (\<lambda>f. if (\<forall>x. x \<notin> A \<longrightarrow> f x = dflt) then \<Prod>x\<in>A. pmf (p x) (f x) else 0)"

text \<open>
  A technical subtlety that needs to be addressed is this: Intuitively, the functions in the
  support of a product distribution have domain \<open>A\<close>. However, since HOL is a total logic, these
  functions must still return \<^emph>\<open>some\<close> value for inputs outside \<open>A\<close>. The product measure
  @{const PiM} simply lets these functions return @{const undefined} in these cases. We chose a
  different solution here, which is to supply a default value \<^term>\<open>dflt :: 'b\<close> that is returned
  in these cases.

  As one possible application, one could model the result of \<open>n\<close> different independent coin
  tosses as @{term "Pi_pmf {0..<n} False (\<lambda>_. bernoulli_pmf (1 / 2))"}. This returns a function
  of type \<^typ>\<open>nat \<Rightarrow> bool\<close> that maps every natural number below \<open>n\<close> to the result of the
  corresponding coin toss, and every other natural number to \<^term>\<open>False\<close>.
\<close>

lemma pmf_Pi:
  assumes A: "finite A"
  shows   "pmf (Pi_pmf A dflt p) f =
             (if (\<forall>x. x \<notin> A \<longrightarrow> f x = dflt) then \<Prod>x\<in>A. pmf (p x) (f x) else 0)"
  unfolding Pi_pmf_def
proof (rule pmf_embed_pmf, goal_cases)
  case 2
  define S where "S = {f. \<forall>x. x \<notin> A \<longrightarrow> f x = dflt}"
  define B where "B = (\<lambda>x. set_pmf (p x))"

  have neutral_left: "(\<Prod>xa\<in>A. pmf (p xa) (f xa)) = 0"
    if "f \<in> PiE A B - (\<lambda>f. restrict f A) ` S" for f
  proof -
    have "restrict (\<lambda>x. if x \<in> A then f x else dflt) A \<in> (\<lambda>f. restrict f A) ` S"
      by (intro imageI) (auto simp: S_def)
    also have "restrict (\<lambda>x. if x \<in> A then f x else dflt) A = f"
      using that by (auto simp: PiE_def Pi_def extensional_def fun_eq_iff)
    finally show ?thesis using that by blast
  qed
  have neutral_right: "(\<Prod>xa\<in>A. pmf (p xa) (f xa)) = 0"
    if "f \<in> (\<lambda>f. restrict f A) ` S - PiE A B" for f
  proof -
    from that obtain f' where f': "f = restrict f' A" "f' \<in> S" by auto
    moreover from this and that have "restrict f' A \<notin> PiE A B" by simp
    then obtain x where "x \<in> A" "pmf (p x) (f' x) = 0" by (auto simp: B_def set_pmf_eq)
    with f' and A show ?thesis by auto
  qed

  have "(\<lambda>f. \<Prod>x\<in>A. pmf (p x) (f x)) abs_summable_on PiE A B"
    by (intro abs_summable_on_prod_PiE A) (auto simp: B_def)
  also have "?this \<longleftrightarrow> (\<lambda>f. \<Prod>x\<in>A. pmf (p x) (f x)) abs_summable_on (\<lambda>f. restrict f A) ` S"
    by (intro abs_summable_on_cong_neutral neutral_left neutral_right) auto
  also have "\<dots> \<longleftrightarrow> (\<lambda>f. \<Prod>x\<in>A. pmf (p x) (restrict f A x)) abs_summable_on S"
    by (rule abs_summable_on_reindex_iff [symmetric]) (force simp: inj_on_def fun_eq_iff S_def)
  also have "\<dots> \<longleftrightarrow> (\<lambda>f. if \<forall>x. x \<notin> A \<longrightarrow> f x = dflt then \<Prod>x\<in>A. pmf (p x) (f x) else 0)
                          abs_summable_on UNIV"
    by (intro abs_summable_on_cong_neutral) (auto simp: S_def)
  finally have summable: \<dots> .

  have "1 = (\<Prod>x\<in>A. 1::real)" by simp
  also have "(\<Prod>x\<in>A. 1) = (\<Prod>x\<in>A. \<Sum>\<^sub>ay\<in>B x. pmf (p x) y)"
    unfolding B_def by (subst infsetsum_pmf_eq_1) auto
  also have "(\<Prod>x\<in>A. \<Sum>\<^sub>ay\<in>B x. pmf (p x) y) = (\<Sum>\<^sub>af\<in>Pi\<^sub>E A B. \<Prod>x\<in>A. pmf (p x) (f x))"
    by (intro infsetsum_prod_PiE [symmetric] A) (auto simp: B_def)
  also have "\<dots> = (\<Sum>\<^sub>af\<in>(\<lambda>f. restrict f A) ` S. \<Prod>x\<in>A. pmf (p x) (f x))" using A
    by (intro infsetsum_cong_neutral neutral_left neutral_right refl)
  also have "\<dots> = (\<Sum>\<^sub>af\<in>S. \<Prod>x\<in>A. pmf (p x) (restrict f A x))"
    by (rule infsetsum_reindex) (force simp: inj_on_def fun_eq_iff S_def)
  also have "\<dots> = (\<Sum>\<^sub>af\<in>S. \<Prod>x\<in>A. pmf (p x) (f x))"
    by (intro infsetsum_cong) (auto simp: S_def)
  also have "\<dots> = (\<Sum>\<^sub>af. if \<forall>x. x \<notin> A \<longrightarrow> f x = dflt then \<Prod>x\<in>A. pmf (p x) (f x) else 0)"
    by (intro infsetsum_cong_neutral) (auto simp: S_def)
  also have "ennreal \<dots> = (\<integral>\<^sup>+f. ennreal (if \<forall>x. x \<notin> A \<longrightarrow> f x = dflt
                             then \<Prod>x\<in>A. pmf (p x) (f x) else 0) \<partial>count_space UNIV)"
    by (intro nn_integral_conv_infsetsum [symmetric] summable) (auto simp: prod_nonneg)
  finally show ?case by simp
qed (auto simp: prod_nonneg)

lemma Pi_pmf_cong:
  assumes "A = A'" "dflt = dflt'" "\<And>x. x \<in> A \<Longrightarrow> f x = f' x"
  shows   "Pi_pmf A dflt f = Pi_pmf A' dflt' f'"
proof -
  have "(\<lambda>fa. if \<forall>x. x \<notin> A \<longrightarrow> fa x = dflt then \<Prod>x\<in>A. pmf (f x) (fa x) else 0) =
        (\<lambda>f. if \<forall>x. x \<notin> A' \<longrightarrow> f x = dflt' then \<Prod>x\<in>A'. pmf (f' x) (f x) else 0)"
    using assms by (intro ext) (auto intro!: prod.cong)
  thus ?thesis
    by (simp only: Pi_pmf_def)
qed

lemma pmf_Pi':
  assumes "finite A" "\<And>x. x \<notin> A \<Longrightarrow> f x = dflt"
  shows   "pmf (Pi_pmf A dflt p) f = (\<Prod>x\<in>A. pmf (p x) (f x))"
  using assms by (subst pmf_Pi) auto

lemma pmf_Pi_outside:
  assumes "finite A" "\<exists>x. x \<notin> A \<and> f x \<noteq> dflt"
  shows   "pmf (Pi_pmf A dflt p) f = 0"
  using assms by (subst pmf_Pi) auto

lemma pmf_Pi_empty [simp]: "Pi_pmf {} dflt p = return_pmf (\<lambda>_. dflt)"
  by (intro pmf_eqI, subst pmf_Pi) (auto simp: indicator_def)

lemma set_Pi_pmf_subset: "finite A \<Longrightarrow> set_pmf (Pi_pmf A dflt p) \<subseteq> {f. \<forall>x. x \<notin> A \<longrightarrow> f x = dflt}"
  by (auto simp: set_pmf_eq pmf_Pi)

subsection \<open>Dependent product sets with a default\<close>

text \<open>
  The following describes a dependent product of sets where the functions are required to return
  the default value \<^term>\<open>dflt\<close> outside their domain, in analogy to @{const PiE}, which uses
  @{const undefined}.
\<close>
definition PiE_dflt
  where "PiE_dflt A dflt B = {f. \<forall>x. (x \<in> A \<longrightarrow> f x \<in> B x) \<and> (x \<notin> A \<longrightarrow> f x = dflt)}"

lemma restrict_PiE_dflt: "(\<lambda>h. restrict h A) ` PiE_dflt A dflt B = PiE A B"
proof (intro equalityI subsetI)
  fix h assume "h \<in> (\<lambda>h. restrict h A) ` PiE_dflt A dflt B"
  thus "h \<in> PiE A B"
    by (auto simp: PiE_dflt_def)
next
  fix h assume h: "h \<in> PiE A B"
  hence "restrict (\<lambda>x. if x \<in> A then h x else dflt) A \<in> (\<lambda>h. restrict h A) ` PiE_dflt A dflt B"
    by (intro imageI) (auto simp: PiE_def extensional_def PiE_dflt_def)
  also have "restrict (\<lambda>x. if x \<in> A then h x else dflt) A = h"
    using h by (auto simp: fun_eq_iff)
  finally show "h \<in> (\<lambda>h. restrict h A) ` PiE_dflt A dflt B" .
qed

lemma dflt_image_PiE: "(\<lambda>h x. if x \<in> A then h x else dflt) ` PiE A B = PiE_dflt A dflt B"
  (is "?f ` ?X = ?Y")
proof (intro equalityI subsetI)
  fix h assume "h \<in> ?f ` ?X"
  thus "h \<in> ?Y"
    by (auto simp: PiE_dflt_def PiE_def)
next
  fix h assume h: "h \<in> ?Y"
  hence "?f (restrict h A) \<in> ?f ` ?X"
    by (intro imageI) (auto simp: PiE_def extensional_def PiE_dflt_def)
  also have "?f (restrict h A) = h"
    using h by (auto simp: fun_eq_iff PiE_dflt_def)
  finally show "h \<in> ?f ` ?X" .
qed

lemma finite_PiE_dflt [intro]:
  assumes "finite A" "\<And>x. x \<in> A \<Longrightarrow> finite (B x)"
  shows   "finite (PiE_dflt A d B)"
proof -
  have "PiE_dflt A d B = (\<lambda>f x. if x \<in> A then f x else d) ` PiE A B"
    by (rule dflt_image_PiE [symmetric])
  also have "finite \<dots>"
    by (intro finite_imageI finite_PiE assms)
  finally show ?thesis .
qed

lemma card_PiE_dflt:
  assumes "finite A" "\<And>x. x \<in> A \<Longrightarrow> finite (B x)"
  shows   "card (PiE_dflt A d B) = (\<Prod>x\<in>A. card (B x))"
proof -
  from assms have "(\<Prod>x\<in>A. card (B x)) = card (PiE A B)"
    by (intro card_PiE [symmetric]) auto
  also have "PiE A B = (\<lambda>f. restrict f A) ` PiE_dflt A d B"
    by (rule restrict_PiE_dflt [symmetric])
  also have "card \<dots> = card (PiE_dflt A d B)"
    by (intro card_image) (force simp: inj_on_def restrict_def fun_eq_iff PiE_dflt_def)
  finally show ?thesis ..
qed

lemma PiE_dflt_empty_iff [simp]: "PiE_dflt A dflt B = {} \<longleftrightarrow> (\<exists>x\<in>A. B x = {})"
  by (simp add: dflt_image_PiE [symmetric] PiE_eq_empty_iff)

lemma set_Pi_pmf_subset':
  assumes "finite A"
  shows   "set_pmf (Pi_pmf A dflt p) \<subseteq> PiE_dflt A dflt (set_pmf \<circ> p)"
  using assms by (auto simp: set_pmf_eq pmf_Pi PiE_dflt_def)

lemma set_Pi_pmf:
  assumes "finite A"
  shows   "set_pmf (Pi_pmf A dflt p) = PiE_dflt A dflt (set_pmf \<circ> p)"
proof (rule equalityI)
  show "PiE_dflt A dflt (set_pmf \<circ> p) \<subseteq> set_pmf (Pi_pmf A dflt p)"
  proof safe
    fix f assume f: "f \<in> PiE_dflt A dflt (set_pmf \<circ> p)"
    hence "pmf (Pi_pmf A dflt p) f = (\<Prod>x\<in>A. pmf (p x) (f x))"
      using assms by (auto simp: pmf_Pi PiE_dflt_def)
    also have "\<dots> > 0"
      using f by (intro prod_pos) (auto simp: PiE_dflt_def set_pmf_eq)
    finally show "f \<in> set_pmf (Pi_pmf A dflt p)"
      by (auto simp: set_pmf_eq)
  qed
qed (use set_Pi_pmf_subset'[OF assms, of dflt p] in auto)

text \<open>
  The probability of an independent combination of events is precisely the product
  of the probabilities of each individual event.
\<close>
lemma measure_Pi_pmf_PiE_dflt:
  assumes [simp]: "finite A"
  shows   "measure_pmf.prob (Pi_pmf A dflt p) (PiE_dflt A dflt B) =
             (\<Prod>x\<in>A. measure_pmf.prob (p x) (B x))"
proof -
  define B' where "B' = (\<lambda>x. B x \<inter> set_pmf (p x))"
  have "measure_pmf.prob (Pi_pmf A dflt p) (PiE_dflt A dflt B) =
          (\<Sum>\<^sub>ah\<in>PiE_dflt A dflt B. pmf (Pi_pmf A dflt p) h)"
    by (rule measure_pmf_conv_infsetsum)
  also have "\<dots> = (\<Sum>\<^sub>ah\<in>PiE_dflt A dflt B. \<Prod>x\<in>A. pmf (p x) (h x))"
    by (intro infsetsum_cong, subst pmf_Pi') (auto simp: PiE_dflt_def)
  also have "\<dots> = (\<Sum>\<^sub>ah\<in>(\<lambda>h. restrict h A) ` PiE_dflt A dflt B. \<Prod>x\<in>A. pmf (p x) (h x))"
    by (subst infsetsum_reindex) (force simp: inj_on_def PiE_dflt_def fun_eq_iff)+
  also have "(\<lambda>h. restrict h A) ` PiE_dflt A dflt B = PiE A B"
    by (rule restrict_PiE_dflt)
  also have "(\<Sum>\<^sub>ah\<in>PiE A B. \<Prod>x\<in>A. pmf (p x) (h x)) = (\<Sum>\<^sub>ah\<in>PiE A B'. \<Prod>x\<in>A. pmf (p x) (h x))"
    by (intro infsetsum_cong_neutral) (auto simp: B'_def set_pmf_eq)
  also have "(\<Sum>\<^sub>ah\<in>PiE A B'. \<Prod>x\<in>A. pmf (p x) (h x)) = (\<Prod>x\<in>A. infsetsum (pmf (p x)) (B' x))"
    by (intro infsetsum_prod_PiE) (auto simp: B'_def)
  also have "\<dots> = (\<Prod>x\<in>A. infsetsum (pmf (p x)) (B x))"
    by (intro prod.cong infsetsum_cong_neutral) (auto simp: B'_def set_pmf_eq)
  also have "\<dots> = (\<Prod>x\<in>A. measure_pmf.prob (p x) (B x))"
    by (subst measure_pmf_conv_infsetsum) (rule refl)
  finally show ?thesis .
qed

lemma measure_Pi_pmf_Pi:
  fixes t::nat
  assumes [simp]: "finite A"
  shows   "measure_pmf.prob (Pi_pmf A dflt p) (Pi A B) =
             (\<Prod>x\<in>A. measure_pmf.prob (p x) (B x))" (is "?lhs = ?rhs")
proof -
  have "?lhs = measure_pmf.prob (Pi_pmf A dflt p) (PiE_dflt A dflt B)"
    by (intro measure_prob_cong_0)
       (auto simp: PiE_dflt_def PiE_def intro!: pmf_Pi_outside)+
  also have "\<dots> = ?rhs"
    using assms by (simp add: measure_Pi_pmf_PiE_dflt)
  finally show ?thesis
    by simp
qed

subsection \<open>Common PMF operations on products\<close>

text \<open>
  @{const Pi_pmf} distributes over the `bind' operation in the Giry monad:
\<close>
lemma Pi_pmf_bind:
  assumes "finite A"
  shows   "Pi_pmf A d (\<lambda>x. bind_pmf (p x) (q x)) =
             do {f \<leftarrow> Pi_pmf A d' p; Pi_pmf A d (\<lambda>x. q x (f x))}" (is "?lhs = ?rhs")
proof (rule pmf_eqI, goal_cases)
  case (1 f)
  show ?case
  proof (cases "\<exists>x\<in>-A. f x \<noteq> d")
    case False
    define B where "B = (\<lambda>x. set_pmf (p x))"
    have [simp]: "countable (B x)" for x by (auto simp: B_def)

    {
      fix x :: 'a
      have "(\<lambda>a. pmf (p x) a * 1) abs_summable_on B x"
        by (simp add: pmf_abs_summable)
      moreover have "norm (pmf (p x) a * 1) \<ge> norm (pmf (p x) a * pmf (q x a) (f x))" for a
        unfolding norm_mult by (intro mult_left_mono) (auto simp: pmf_le_1)
      ultimately have "(\<lambda>a. pmf (p x) a * pmf (q x a) (f x)) abs_summable_on B x"
        by (rule abs_summable_on_comparison_test)
    } note summable = this

    have "pmf ?rhs f = (\<Sum>\<^sub>ag. pmf (Pi_pmf A d' p) g * (\<Prod>x\<in>A. pmf (q x (g x)) (f x)))"
      by (subst pmf_bind, subst pmf_Pi')
         (insert assms False, simp_all add: pmf_expectation_eq_infsetsum)
    also have "\<dots> = (\<Sum>\<^sub>ag\<in>PiE_dflt A d' B.
                      pmf (Pi_pmf A d' p) g * (\<Prod>x\<in>A. pmf (q x (g x)) (f x)))" unfolding B_def
      using assms by (intro infsetsum_cong_neutral) (auto simp: pmf_Pi PiE_dflt_def set_pmf_eq)
    also have "\<dots> = (\<Sum>\<^sub>ag\<in>PiE_dflt A d' B.
                      (\<Prod>x\<in>A. pmf (p x) (g x) * pmf (q x (g x)) (f x)))"
      using assms by (intro infsetsum_cong) (auto simp: pmf_Pi PiE_dflt_def prod.distrib)
    also have "\<dots> = (\<Sum>\<^sub>ag\<in>(\<lambda>g. restrict g A) ` PiE_dflt A d' B.
                      (\<Prod>x\<in>A. pmf (p x) (g x) * pmf (q x (g x)) (f x)))"
      by (subst infsetsum_reindex) (force simp: PiE_dflt_def inj_on_def fun_eq_iff)+
    also have "(\<lambda>g. restrict g A) ` PiE_dflt A d' B = PiE A B"
      by (rule restrict_PiE_dflt)
    also have "(\<Sum>\<^sub>ag\<in>\<dots>. (\<Prod>x\<in>A. pmf (p x) (g x) * pmf (q x (g x)) (f x))) =
                 (\<Prod>x\<in>A. \<Sum>\<^sub>aa\<in>B x. pmf (p x) a * pmf (q x a) (f x))"
      using assms summable by (subst infsetsum_prod_PiE) simp_all
    also have "\<dots> = (\<Prod>x\<in>A. \<Sum>\<^sub>aa. pmf (p x) a * pmf (q x a) (f x))"
      by (intro prod.cong infsetsum_cong_neutral) (auto simp: B_def set_pmf_eq)
    also have "\<dots> = pmf ?lhs f"
      using False assms by (subst pmf_Pi') (simp_all add: pmf_bind pmf_expectation_eq_infsetsum)
    finally show ?thesis ..
  next
    case True
    have "pmf ?rhs f =
            measure_pmf.expectation (Pi_pmf A d' p) (\<lambda>x. pmf (Pi_pmf A d (\<lambda>xa. q xa (x xa))) f)"
      using assms by (simp add: pmf_bind)
    also have "\<dots> = measure_pmf.expectation (Pi_pmf A d' p) (\<lambda>x. 0)"
      using assms True by (intro Bochner_Integration.integral_cong pmf_Pi_outside) auto
    also have "\<dots> = pmf ?lhs f"
      using assms True by (subst pmf_Pi_outside) auto
    finally show ?thesis ..
  qed
qed

lemma Pi_pmf_return_pmf [simp]:
  assumes "finite A"
  shows   "Pi_pmf A dflt (\<lambda>x. return_pmf (f x)) = return_pmf (\<lambda>x. if x \<in> A then f x else dflt)"
  using assms by (intro pmf_eqI) (auto simp: pmf_Pi simp: indicator_def split: if_splits)

text \<open>
  Analogously any componentwise mapping can be pulled outside the product:
\<close>
lemma Pi_pmf_map:
  assumes [simp]: "finite A" and "f dflt = dflt'"
  shows   "Pi_pmf A dflt' (\<lambda>x. map_pmf f (g x)) = map_pmf (\<lambda>h. f \<circ> h) (Pi_pmf A dflt g)"
proof -
  have "Pi_pmf A dflt' (\<lambda>x. map_pmf f (g x)) =
          Pi_pmf A dflt' (\<lambda>x. g x \<bind> (\<lambda>x. return_pmf (f x)))"
    using assms by (simp add: map_pmf_def Pi_pmf_bind)
  also have "\<dots> = Pi_pmf A dflt g \<bind> (\<lambda>h. return_pmf (\<lambda>x. if x \<in> A then f (h x) else dflt'))"
   by (subst Pi_pmf_bind[where d' = dflt]) auto
  also have "\<dots> = map_pmf (\<lambda>h. f \<circ> h) (Pi_pmf A dflt g)"
    unfolding map_pmf_def using set_Pi_pmf_subset'[of A dflt g]
    by (intro bind_pmf_cong refl arg_cong[of _ _ return_pmf])
       (auto dest: simp: fun_eq_iff PiE_dflt_def assms(2))
  finally show ?thesis .
qed

text \<open>
  We can exchange the default value in a product of PMFs like this:
\<close>
lemma Pi_pmf_default_swap:
  assumes "finite A"
  shows   "map_pmf (\<lambda>f x. if x \<in> A then f x else dflt') (Pi_pmf A dflt p) =
             Pi_pmf A dflt' p" (is "?lhs = ?rhs")
proof (rule pmf_eqI, goal_cases)
  case (1 f)
  let ?B = "(\<lambda>f x. if x \<in> A then f x else dflt') -` {f} \<inter> PiE_dflt A dflt (\<lambda>_. UNIV)"
  show ?case
  proof (cases "\<exists>x\<in>-A. f x \<noteq> dflt'")
    case False
    let ?f' = "\<lambda>x. if x \<in> A then f x else dflt"
    from False have "pmf ?lhs f = measure_pmf.prob (Pi_pmf A dflt p) ?B"
      using assms unfolding pmf_map
      by (intro measure_prob_cong_0) (auto simp: PiE_dflt_def pmf_Pi_outside)
    also from False have "?B = {?f'}"
      by (auto simp: fun_eq_iff PiE_dflt_def)
    also have "measure_pmf.prob (Pi_pmf A dflt p) {?f'} = pmf (Pi_pmf A dflt p) ?f'"
      by (simp add: measure_pmf_single)
    also have "\<dots> = pmf ?rhs f"
      using False assms by (subst (1 2) pmf_Pi) auto
    finally show ?thesis .
  next
    case True
    have "pmf ?lhs f = measure_pmf.prob (Pi_pmf A dflt p) ?B"
      using assms unfolding pmf_map
      by (intro measure_prob_cong_0) (auto simp: PiE_dflt_def pmf_Pi_outside)
    also from True have "?B = {}" by auto
    also have "measure_pmf.prob (Pi_pmf A dflt p) \<dots> = 0"
      by simp
    also have "0 = pmf ?rhs f"
      using True assms by (intro pmf_Pi_outside [symmetric]) auto
    finally show ?thesis .
  qed
qed

text \<open>
  The following rule allows reindexing the product:
\<close>
lemma Pi_pmf_bij_betw:
  assumes "finite A" "bij_betw h A B" "\<And>x. x \<notin> A \<Longrightarrow> h x \<notin> B"
  shows "Pi_pmf A dflt (\<lambda>_. f) = map_pmf (\<lambda>g. g \<circ> h) (Pi_pmf B dflt (\<lambda>_. f))"
    (is "?lhs = ?rhs")
proof -
  have B: "finite B"
    using assms bij_betw_finite by auto
  have "pmf ?lhs g = pmf ?rhs g" for g
  proof (cases "\<forall>a. a \<notin> A \<longrightarrow> g a = dflt")
    case True
    define h' where "h' = the_inv_into A h"
    have h': "h' (h x) = x" if "x \<in> A" for x
      unfolding h'_def using that assms by (auto simp add: bij_betw_def the_inv_into_f_f)
    have h: "h (h' x) = x" if "x \<in> B" for x
      unfolding h'_def using that assms f_the_inv_into_f_bij_betw by fastforce
    have "pmf ?rhs g = measure_pmf.prob (Pi_pmf B dflt (\<lambda>_. f)) ((\<lambda>g. g \<circ> h) -` {g})"
      unfolding pmf_map by simp
    also have "\<dots> = measure_pmf.prob (Pi_pmf B dflt (\<lambda>_. f))
                                (((\<lambda>g. g \<circ> h) -` {g}) \<inter> PiE_dflt B dflt (\<lambda>_. UNIV))"
      using B by (intro measure_prob_cong_0) (auto simp: PiE_dflt_def pmf_Pi_outside)
    also have "\<dots> = pmf (Pi_pmf B dflt (\<lambda>_. f)) (\<lambda>x. if x \<in> B then g (h' x) else dflt)"
    proof -
      have "(if h x \<in> B then g (h' (h x)) else dflt) = g x" for x
        using h' assms True by (cases "x \<in> A") (auto simp add: bij_betwE)
      then have "(\<lambda>g. g \<circ> h) -` {g} \<inter> PiE_dflt B dflt (\<lambda>_. UNIV) =
            {(\<lambda>x. if x \<in> B then g (h' x) else dflt)}"
        using assms h' h True unfolding PiE_dflt_def by auto
      then show ?thesis
        by (simp add: measure_pmf_single)
    qed
    also have "\<dots> = pmf (Pi_pmf A dflt (\<lambda>_. f)) g"
      using B assms True  h'_def
      by (auto simp add: pmf_Pi intro!: prod.reindex_bij_betw bij_betw_the_inv_into)
    finally show ?thesis
      by simp
  next
    case False
    have "pmf ?rhs g = infsetsum (pmf (Pi_pmf B dflt (\<lambda>_. f))) ((\<lambda>g. g \<circ> h) -` {g})"
      using assms by (auto simp add: measure_pmf_conv_infsetsum pmf_map)
    also have "\<dots> = infsetsum (\<lambda>_. 0) ((\<lambda>g x. g (h x)) -` {g})"
      using B False assms by (intro infsetsum_cong pmf_Pi_outside) fastforce+
    also have "\<dots> = 0"
      by simp
    finally show ?thesis
      using assms False by (auto simp add: pmf_Pi pmf_map)
  qed
  then show ?thesis
    by (rule pmf_eqI)
qed

text \<open>
  A product of uniform random choices is again a uniform distribution.
\<close>
lemma Pi_pmf_of_set:
  assumes "finite A" "\<And>x. x \<in> A \<Longrightarrow> finite (B x)" "\<And>x. x \<in> A \<Longrightarrow> B x \<noteq> {}"
  shows   "Pi_pmf A d (\<lambda>x. pmf_of_set (B x)) = pmf_of_set (PiE_dflt A d B)" (is "?lhs = ?rhs")
proof (rule pmf_eqI, goal_cases)
  case (1 f)
  show ?case
  proof (cases "\<exists>x. x \<notin> A \<and> f x \<noteq> d")
    case True
    hence "pmf ?lhs f = 0"
      using assms by (intro pmf_Pi_outside) (auto simp: PiE_dflt_def)
    also from True have "f \<notin> PiE_dflt A d B"
      by (auto simp: PiE_dflt_def)
    hence "0 = pmf ?rhs f"
      using assms by (subst pmf_of_set) auto
    finally show ?thesis .
  next
    case False
    hence "pmf ?lhs f = (\<Prod>x\<in>A. pmf (pmf_of_set (B x)) (f x))"
      using assms by (subst pmf_Pi') auto
    also have "\<dots> = (\<Prod>x\<in>A. indicator (B x) (f x) / real (card (B x)))"
      by (intro prod.cong refl, subst pmf_of_set) (use assms False in auto)
    also have "\<dots> = (\<Prod>x\<in>A. indicator (B x) (f x)) / real (\<Prod>x\<in>A. card (B x))"
      by (subst prod_dividef) simp_all
    also have "(\<Prod>x\<in>A. indicator (B x) (f x) :: real) = indicator (PiE_dflt A d B) f"
      using assms False by (auto simp: indicator_def PiE_dflt_def)
    also have "(\<Prod>x\<in>A. card (B x)) = card (PiE_dflt A d B)"
      using assms by (intro card_PiE_dflt [symmetric]) auto
    also have "indicator (PiE_dflt A d B) f / \<dots> = pmf ?rhs f"
      using assms by (intro pmf_of_set [symmetric]) auto
    finally show ?thesis .
  qed
qed

subsection \<open>Merging and splitting PMF products\<close>

text \<open>
  The following lemma shows that we can add a single PMF to a product:
\<close>
lemma Pi_pmf_insert:
  assumes "finite A" "x \<notin> A"
  shows   "Pi_pmf (insert x A) dflt p = map_pmf (\<lambda>(y,f). f(x:=y)) (pair_pmf (p x) (Pi_pmf A dflt p))"
proof (intro pmf_eqI)
  fix f
  let ?M = "pair_pmf (p x) (Pi_pmf A dflt p)"
  have "pmf (map_pmf (\<lambda>(y, f). f(x := y)) ?M) f =
          measure_pmf.prob ?M ((\<lambda>(y, f). f(x := y)) -` {f})"
    by (subst pmf_map) auto
  also have "((\<lambda>(y, f). f(x := y)) -` {f}) = (\<Union>y'. {(f x, f(x := y'))})"
    by (auto simp: fun_upd_def fun_eq_iff)
  also have "measure_pmf.prob ?M \<dots> = measure_pmf.prob ?M {(f x, f(x := dflt))}"
    using assms by (intro measure_prob_cong_0) (auto simp: pmf_pair pmf_Pi split: if_splits)
  also have "\<dots> = pmf (p x) (f x) * pmf (Pi_pmf A dflt p) (f(x := dflt))"
    by (simp add: measure_pmf_single pmf_pair pmf_Pi)
  also have "\<dots> = pmf (Pi_pmf (insert x A) dflt p) f"
  proof (cases "\<forall>y. y \<notin> insert x A \<longrightarrow> f y = dflt")
    case True
    with assms have "pmf (p x) (f x) * pmf (Pi_pmf A dflt p) (f(x := dflt)) =
                       pmf (p x) (f x) * (\<Prod>xa\<in>A. pmf (p xa) ((f(x := dflt)) xa))"
      by (subst pmf_Pi') auto
    also have "(\<Prod>xa\<in>A. pmf (p xa) ((f(x := dflt)) xa)) = (\<Prod>xa\<in>A. pmf (p xa) (f xa))"
      using assms by (intro prod.cong) auto
    also have "pmf (p x) (f x) * \<dots> = pmf (Pi_pmf (insert x A) dflt p) f"
      using assms True by (subst pmf_Pi') auto
    finally show ?thesis .
  qed (insert assms, auto simp: pmf_Pi)
  finally show "\<dots> = pmf (map_pmf (\<lambda>(y, f). f(x := y)) ?M) f" ..
qed

lemma Pi_pmf_insert':
  assumes "finite A"  "x \<notin> A"
  shows   "Pi_pmf (insert x A) dflt p =
             do {y \<leftarrow> p x; f \<leftarrow> Pi_pmf A dflt p; return_pmf (f(x := y))}"
  using assms
  by (subst Pi_pmf_insert)
     (auto simp add: map_pmf_def pair_pmf_def case_prod_beta' bind_return_pmf bind_assoc_pmf)

lemma Pi_pmf_singleton:
  "Pi_pmf {x} dflt p = map_pmf (\<lambda>a b. if b = x then a else dflt) (p x)"
proof -
  have "Pi_pmf {x} dflt p = map_pmf (fun_upd (\<lambda>_. dflt) x) (p x)"
    by (subst Pi_pmf_insert) (simp_all add: pair_return_pmf2 pmf.map_comp o_def)
  also have "fun_upd (\<lambda>_. dflt) x = (\<lambda>z y. if y = x then z else dflt)"
    by (simp add: fun_upd_def fun_eq_iff)
  finally show ?thesis .
qed

text \<open>
  Projecting a product of PMFs onto a component yields the expected result:
\<close>
lemma Pi_pmf_component:
  assumes "finite A"
  shows   "map_pmf (\<lambda>f. f x) (Pi_pmf A dflt p) = (if x \<in> A then p x else return_pmf dflt)"
proof (cases "x \<in> A")
  case True
  define A' where "A' = A - {x}"
  from assms and True have A': "A = insert x A'"
    by (auto simp: A'_def)
  from assms have "map_pmf (\<lambda>f. f x) (Pi_pmf A dflt p) = p x" unfolding A'
    by (subst Pi_pmf_insert)
       (auto simp: A'_def pmf.map_comp o_def case_prod_unfold map_fst_pair_pmf)
  with True show ?thesis by simp
next
  case False
  have "map_pmf (\<lambda>f. f x) (Pi_pmf A dflt p) = map_pmf (\<lambda>_. dflt) (Pi_pmf A dflt p)"
    using assms False set_Pi_pmf_subset[of A dflt p]
    by (intro pmf.map_cong refl) (auto simp: set_pmf_eq pmf_Pi_outside)
  with False show ?thesis by simp
qed

text \<open>
  We can take merge two PMF products on disjoint sets like this:
\<close>
lemma Pi_pmf_union:
  assumes "finite A" "finite B" "A \<inter> B = {}"
  shows   "Pi_pmf (A \<union> B) dflt p =
             map_pmf (\<lambda>(f,g) x. if x \<in> A then f x else g x)
             (pair_pmf (Pi_pmf A dflt p) (Pi_pmf B dflt p))" (is "_ = map_pmf (?h A) (?q A)")
  using assms(1,3)
proof (induction rule: finite_induct)
  case (insert x A)
  have "map_pmf (?h (insert x A)) (?q (insert x A)) =
          do {v \<leftarrow> p x; (f, g) \<leftarrow> pair_pmf (Pi_pmf A dflt p) (Pi_pmf B dflt p);
              return_pmf (\<lambda>y. if y \<in> insert x A then (f(x := v)) y else g y)}"
    by (subst Pi_pmf_insert)
       (insert insert.hyps insert.prems,
        simp_all add: pair_pmf_def map_bind_pmf bind_map_pmf bind_assoc_pmf bind_return_pmf)
  also have "\<dots> = do {v \<leftarrow> p x; (f, g) \<leftarrow> ?q A; return_pmf ((?h A (f,g))(x := v))}"
    by (intro bind_pmf_cong refl) (auto simp: fun_eq_iff)
  also have "\<dots> = do {v \<leftarrow> p x; f \<leftarrow> map_pmf (?h A) (?q A); return_pmf (f(x := v))}"
    by (simp add: bind_map_pmf map_bind_pmf case_prod_unfold cong: if_cong)
  also have "\<dots> = do {v \<leftarrow> p x; f \<leftarrow> Pi_pmf (A \<union> B) dflt p; return_pmf (f(x := v))}"
    using insert.hyps and insert.prems by (intro bind_pmf_cong insert.IH [symmetric] refl) auto
  also have "\<dots> = Pi_pmf (insert x (A \<union> B)) dflt p"
    by (subst Pi_pmf_insert)
       (insert assms insert.hyps insert.prems, auto simp: pair_pmf_def map_bind_pmf)
  also have "insert x (A \<union> B) = insert x A \<union> B"
    by simp
  finally show ?case ..
qed (simp_all add: case_prod_unfold map_snd_pair_pmf)

text \<open>
  We can also project a product to a subset of the indices by mapping all the other
  indices to the default value:
\<close>
lemma Pi_pmf_subset:
  assumes "finite A" "A' \<subseteq> A"
  shows   "Pi_pmf A' dflt p = map_pmf (\<lambda>f x. if x \<in> A' then f x else dflt) (Pi_pmf A dflt p)"
proof -
  let ?P = "pair_pmf (Pi_pmf A' dflt p) (Pi_pmf (A - A') dflt p)"
  from assms have [simp]: "finite A'"
    by (blast dest: finite_subset)
  from assms have "A = A' \<union> (A - A')"
    by blast
  also have "Pi_pmf \<dots> dflt p = map_pmf (\<lambda>(f,g) x. if x \<in> A' then f x else g x) ?P"
    using assms by (intro Pi_pmf_union) auto
  also have "map_pmf (\<lambda>f x. if x \<in> A' then f x else dflt) \<dots> = map_pmf fst ?P"
    unfolding map_pmf_comp o_def case_prod_unfold
    using set_Pi_pmf_subset[of A' dflt p] by (intro map_pmf_cong refl) (auto simp: fun_eq_iff)
  also have "\<dots> = Pi_pmf A' dflt p"
    by (simp add: map_fst_pair_pmf)
  finally show ?thesis ..
qed

lemma Pi_pmf_subset':
  fixes f :: "'a \<Rightarrow> 'b pmf"
  assumes "finite A" "B \<subseteq> A" "\<And>x. x \<in> A - B \<Longrightarrow> f x = return_pmf dflt"
  shows "Pi_pmf A dflt f = Pi_pmf B dflt f"
proof -
  have "Pi_pmf (B \<union> (A - B)) dflt f =
          map_pmf (\<lambda>(f, g) x. if x \<in> B then f x else g x)
                  (pair_pmf (Pi_pmf B dflt f) (Pi_pmf (A - B) dflt f))"
    using assms by (intro Pi_pmf_union) (auto dest: finite_subset)
  also have "Pi_pmf (A - B) dflt f = Pi_pmf (A - B) dflt (\<lambda>_. return_pmf dflt)"
    using assms by (intro Pi_pmf_cong) auto
  also have "\<dots> = return_pmf (\<lambda>_. dflt)"
    using assms by simp
  also have "map_pmf (\<lambda>(f, g) x. if x \<in> B then f x else g x)
                  (pair_pmf (Pi_pmf B dflt f) (return_pmf (\<lambda>_. dflt))) =
             map_pmf (\<lambda>f x. if x \<in> B then f x else dflt) (Pi_pmf B dflt f)"
    by (simp add: map_pmf_def pair_pmf_def bind_assoc_pmf bind_return_pmf bind_return_pmf')
  also have "\<dots> = Pi_pmf B dflt f"
    using assms by (intro Pi_pmf_default_swap) (auto dest: finite_subset)
  also have "B \<union> (A - B) = A"
    using assms by auto
  finally show ?thesis .
qed

lemma Pi_pmf_if_set:
  assumes "finite A"
  shows "Pi_pmf A dflt (\<lambda>x. if b x then f x else return_pmf dflt) =
           Pi_pmf {x\<in>A. b x} dflt f"
proof -
  have "Pi_pmf A dflt (\<lambda>x. if b x then f x else return_pmf dflt) =
          Pi_pmf {x\<in>A. b x} dflt (\<lambda>x. if b x then f x else return_pmf dflt)"
    using assms by (intro Pi_pmf_subset') auto
  also have "\<dots> = Pi_pmf {x\<in>A. b x} dflt f"
    by (intro Pi_pmf_cong) auto
  finally show ?thesis .
qed

lemma Pi_pmf_if_set':
  assumes "finite A"
  shows "Pi_pmf A dflt (\<lambda>x. if b x then return_pmf dflt else f x) =
         Pi_pmf {x\<in>A. \<not>b x} dflt f"
proof -
  have "Pi_pmf A dflt (\<lambda>x. if b x then return_pmf dflt else  f x) =
          Pi_pmf {x\<in>A. \<not>b x} dflt (\<lambda>x. if b x then return_pmf dflt else  f x)"
    using assms by (intro Pi_pmf_subset') auto
  also have "\<dots> = Pi_pmf {x\<in>A. \<not>b x} dflt f"
    by (intro Pi_pmf_cong) auto
  finally show ?thesis .
qed

text \<open>
  Lastly, we can delete a single component from a product:
\<close>
lemma Pi_pmf_remove:
  assumes "finite A"
  shows   "Pi_pmf (A - {x}) dflt p = map_pmf (\<lambda>f. f(x := dflt)) (Pi_pmf A dflt p)"
proof -
  have "Pi_pmf (A - {x}) dflt p =
          map_pmf (\<lambda>f xa. if xa \<in> A - {x} then f xa else dflt) (Pi_pmf A dflt p)"
    using assms by (intro Pi_pmf_subset) auto
  also have "\<dots> = map_pmf (\<lambda>f. f(x := dflt)) (Pi_pmf A dflt p)"
    using set_Pi_pmf_subset[of A dflt p] assms
    by (intro map_pmf_cong refl) (auto simp: fun_eq_iff)
  finally show ?thesis .
qed

subsection \<open>Additional properties\<close>

lemma nn_integral_prod_Pi_pmf:
  assumes "finite A"
  shows   "nn_integral (Pi_pmf A dflt p) (\<lambda>y. \<Prod>x\<in>A. f x (y x)) = (\<Prod>x\<in>A. nn_integral (p x) (f x))"
  using assms
proof (induction rule: finite_induct)
  case (insert x A)
  have "nn_integral (Pi_pmf (insert x A) dflt p) (\<lambda>y. \<Prod>z\<in>insert x A. f z (y z)) =
          (\<integral>\<^sup>+a. \<integral>\<^sup>+b. f x a * (\<Prod>z\<in>A. f z (if z = x then a else b z)) \<partial>Pi_pmf A dflt p \<partial>p x)"
    using insert by (auto simp: Pi_pmf_insert case_prod_unfold nn_integral_pair_pmf' cong: if_cong)
  also have "(\<lambda>a b. \<Prod>z\<in>A. f z (if z = x then a else b z)) = (\<lambda>a b. \<Prod>z\<in>A. f z (b z))"
    by (intro ext prod.cong) (use insert.hyps in auto)
  also have "(\<integral>\<^sup>+a. \<integral>\<^sup>+b. f x a * (\<Prod>z\<in>A. f z (b z)) \<partial>Pi_pmf A dflt p \<partial>p x) =
             (\<integral>\<^sup>+y. f x y \<partial>(p x)) * (\<integral>\<^sup>+y. (\<Prod>z\<in>A. f z (y z)) \<partial>(Pi_pmf A dflt p))"
    by (simp add: nn_integral_multc nn_integral_cmult)
  also have "(\<integral>\<^sup>+y. (\<Prod>z\<in>A. f z (y z)) \<partial>(Pi_pmf A dflt p)) = (\<Prod>x\<in>A. nn_integral (p x) (f x))"
    by (rule insert.IH)
  also have "(\<integral>\<^sup>+y. f x y \<partial>(p x)) * \<dots> = (\<Prod>x\<in>insert x A. nn_integral (p x) (f x))"
    using insert.hyps by simp
  finally show ?case .
qed auto

lemma integrable_prod_Pi_pmf:
  fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c :: {real_normed_field, second_countable_topology, banach}"
  assumes "finite A" and "\<And>x. x \<in> A \<Longrightarrow> integrable (measure_pmf (p x)) (f x)"
  shows   "integrable (measure_pmf (Pi_pmf A dflt p)) (\<lambda>h. \<Prod>x\<in>A. f x (h x))"
proof (intro integrableI_bounded)
  have "(\<integral>\<^sup>+ x. ennreal (norm (\<Prod>xa\<in>A. f xa (x xa))) \<partial>measure_pmf (Pi_pmf A dflt p)) =
        (\<integral>\<^sup>+ x. (\<Prod>y\<in>A. ennreal (norm (f y (x y)))) \<partial>measure_pmf (Pi_pmf A dflt p))"
    by (simp flip: prod_norm prod_ennreal)
  also have "\<dots> = (\<Prod>x\<in>A. \<integral>\<^sup>+ a. ennreal (norm (f x a)) \<partial>measure_pmf (p x))"
    by (intro nn_integral_prod_Pi_pmf) fact
  also have "(\<integral>\<^sup>+a. ennreal (norm (f i a)) \<partial>measure_pmf (p i)) \<noteq> top" if i: "i \<in> A" for i
    using assms(2)[OF i] by (simp add: integrable_iff_bounded)
  hence "(\<Prod>x\<in>A. \<integral>\<^sup>+ a. ennreal (norm (f x a)) \<partial>measure_pmf (p x)) \<noteq> top"
    by (subst ennreal_prod_eq_top) auto
  finally show "(\<integral>\<^sup>+ x. ennreal (norm (\<Prod>xa\<in>A. f xa (x xa))) \<partial>measure_pmf (Pi_pmf A dflt p)) < \<infinity>"
    by (simp add: top.not_eq_extremum)
qed auto

lemma expectation_prod_Pi_pmf:
  fixes f :: "_ \<Rightarrow> _ \<Rightarrow> real"
  assumes "finite A"
  assumes "\<And>x. x \<in> A \<Longrightarrow> integrable (measure_pmf (p x)) (f x)"
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> set_pmf (p x) \<Longrightarrow> f x y \<ge> 0"
  shows   "measure_pmf.expectation (Pi_pmf A dflt p) (\<lambda>y. \<Prod>x\<in>A. f x (y x)) =
             (\<Prod>x\<in>A. measure_pmf.expectation (p x) (\<lambda>v. f x v))"
proof -
  have nonneg: "measure_pmf.expectation (p x) (f x) \<ge> 0" if "x \<in> A" for x
    using that by (intro Bochner_Integration.integral_nonneg_AE AE_pmfI assms)
  have nonneg': "0 \<le> measure_pmf.expectation (Pi_pmf A dflt p) (\<lambda>y. \<Prod>x\<in>A. f x (y x))"
    by (intro Bochner_Integration.integral_nonneg_AE AE_pmfI assms prod_nonneg)
       (use assms in \<open>auto simp: set_Pi_pmf PiE_dflt_def\<close>)

  have "ennreal (measure_pmf.expectation (Pi_pmf A dflt p) (\<lambda>y. \<Prod>x\<in>A. f x (y x))) =
          nn_integral (Pi_pmf A dflt p) (\<lambda>y. ennreal (\<Prod>x\<in>A. f x (y x)))" using assms
    by (intro nn_integral_eq_integral [symmetric] assms integrable_prod_Pi_pmf)
       (auto simp: AE_measure_pmf_iff set_Pi_pmf PiE_dflt_def prod_nonneg)
  also have "\<dots> = nn_integral (Pi_pmf A dflt p) (\<lambda>y. (\<Prod>x\<in>A. ennreal (f x (y x))))"
    by (intro nn_integral_cong_AE AE_pmfI prod_ennreal [symmetric])
       (use assms(1) in \<open>auto simp: set_Pi_pmf PiE_dflt_def intro!: assms(3)\<close>)
  also have "\<dots> = (\<Prod>x\<in>A. \<integral>\<^sup>+ a. ennreal (f x a) \<partial>measure_pmf (p x))"
    by (rule nn_integral_prod_Pi_pmf) fact+
  also have "\<dots> = (\<Prod>x\<in>A. ennreal (measure_pmf.expectation (p x) (f x)))"
    by (intro prod.cong nn_integral_eq_integral assms AE_pmfI) auto
  also have "\<dots> = ennreal (\<Prod>x\<in>A. measure_pmf.expectation (p x) (f x))"
    by (intro prod_ennreal nonneg)
  finally show ?thesis
    using nonneg nonneg' by (subst (asm) ennreal_inj) (auto intro!: prod_nonneg)
qed

lemma indep_vars_Pi_pmf:
  assumes fin: "finite I"
  shows   "prob_space.indep_vars (measure_pmf (Pi_pmf I dflt p))
             (\<lambda>_. count_space UNIV) (\<lambda>x f. f x) I"
proof (cases "I = {}")
  case True
  show ?thesis
    by (subst prob_space.indep_vars_def [OF measure_pmf.prob_space_axioms],
        subst prob_space.indep_sets_def [OF measure_pmf.prob_space_axioms]) (simp_all add: True)
next
  case [simp]: False
  show ?thesis
  proof (subst prob_space.indep_vars_iff_distr_eq_PiM')
    show "distr (measure_pmf (Pi_pmf I dflt p)) (Pi\<^sub>M I (\<lambda>i. count_space UNIV)) (\<lambda>x. restrict x I) =
          Pi\<^sub>M I (\<lambda>i. distr (measure_pmf (Pi_pmf I dflt p)) (count_space UNIV) (\<lambda>f. f i))"
    proof (rule product_sigma_finite.PiM_eqI, goal_cases)
      case 1
      interpret product_prob_space "\<lambda>i. distr (measure_pmf (Pi_pmf I dflt p)) (count_space UNIV) (\<lambda>f. f i)"
        by (intro product_prob_spaceI prob_space.prob_space_distr measure_pmf.prob_space_axioms)
           simp_all
      show ?case by unfold_locales
    next
      case 3
      have "sets (Pi\<^sub>M I (\<lambda>i. distr (measure_pmf (Pi_pmf I dflt p)) (count_space UNIV) (\<lambda>f. f i))) =
            sets (Pi\<^sub>M I (\<lambda>_. count_space UNIV))"
        by (intro sets_PiM_cong) simp_all
      thus ?case by simp
    next
      case (4 A)
      have "Pi\<^sub>E I A \<in> sets (Pi\<^sub>M I (\<lambda>i. count_space UNIV))"
        using 4 by (intro sets_PiM_I_finite fin) auto
      hence "emeasure (distr (measure_pmf (Pi_pmf I dflt p)) (Pi\<^sub>M I (\<lambda>i. count_space UNIV))
              (\<lambda>x. restrict x I)) (Pi\<^sub>E I A) =
             emeasure (measure_pmf (Pi_pmf I dflt p)) ((\<lambda>x. restrict x I) -` Pi\<^sub>E I A)"
        using 4 by (subst emeasure_distr) (auto simp: space_PiM)
      also have "\<dots> = emeasure (measure_pmf (Pi_pmf I dflt p)) (PiE_dflt I dflt A)"
        by (intro emeasure_eq_AE AE_pmfI) (auto simp: PiE_dflt_def set_Pi_pmf fin)
      also have "\<dots> = (\<Prod>i\<in>I. emeasure (measure_pmf (p i)) (A i))"
        by (simp add: measure_pmf.emeasure_eq_measure measure_Pi_pmf_PiE_dflt fin prod_ennreal)
      also have "\<dots> = (\<Prod>i\<in>I. emeasure (measure_pmf (map_pmf (\<lambda>f. f i) (Pi_pmf I dflt p))) (A i))"
        by (intro prod.cong refl, subst Pi_pmf_component) (auto simp: fin)
      finally show ?case
        by (simp add: map_pmf_rep_eq)
    qed fact+
  qed (simp_all add: measure_pmf.prob_space_axioms)
qed

lemma
  fixes h :: "'a :: comm_monoid_add \<Rightarrow> 'b::{banach, second_countable_topology}"
  assumes fin: "finite I"
  assumes integrable: "\<And>i. i \<in> I \<Longrightarrow> integrable (measure_pmf (D i)) h"
  shows   integrable_sum_Pi_pmf: "integrable (Pi_pmf I dflt D) (\<lambda>g. \<Sum>i\<in>I. h (g i))"
    and   expectation_sum_Pi_pmf:
            "measure_pmf.expectation (Pi_pmf I dflt D) (\<lambda>g. \<Sum>i\<in>I. h (g i)) =
             (\<Sum>i\<in>I. measure_pmf.expectation (D i) h)"
proof -
  have integrable': "integrable (Pi_pmf I dflt D) (\<lambda>g. h (g i))" if i: "i \<in> I" for i
  proof -
    have "integrable (D i) h"
      using i by (rule assms)
    also have "D i = map_pmf (\<lambda>g. g i) (Pi_pmf I dflt D)"
      by (subst Pi_pmf_component) (use fin i in auto)
    finally show "integrable (measure_pmf (Pi_pmf I dflt D)) (\<lambda>x. h (x i))"
      by simp
  qed
  thus "integrable (Pi_pmf I dflt D) (\<lambda>g. \<Sum>i\<in>I. h (g i))"
    by (intro Bochner_Integration.integrable_sum)

  have "measure_pmf.expectation (Pi_pmf I dflt D) (\<lambda>x. \<Sum>i\<in>I. h (x i)) =
               (\<Sum>i\<in>I. measure_pmf.expectation (map_pmf (\<lambda>x. x i) (Pi_pmf I dflt D)) h)"
    using integrable' by (subst Bochner_Integration.integral_sum) auto
  also have "\<dots> = (\<Sum>i\<in>I. measure_pmf.expectation (D i) h)"
    by (intro sum.cong refl, subst Pi_pmf_component) (use fin in auto)
  finally show "measure_pmf.expectation (Pi_pmf I dflt D) (\<lambda>g. \<Sum>i\<in>I. h (g i)) =
                  (\<Sum>i\<in>I. measure_pmf.expectation (D i) h)" .
qed

subsection \<open>Applications\<close>

text \<open>
  Choosing a subset of a set uniformly at random is equivalent to tossing a fair coin
  independently for each element and collecting all the elements that came up heads.
\<close>
lemma pmf_of_set_Pow_conv_bernoulli:
  assumes "finite (A :: 'a set)"
  shows "map_pmf (\<lambda>b. {x\<in>A. b x}) (Pi_pmf A P (\<lambda>_. bernoulli_pmf (1/2))) = pmf_of_set (Pow A)"
proof -
  have "Pi_pmf A P (\<lambda>_. bernoulli_pmf (1/2)) = pmf_of_set (PiE_dflt A P (\<lambda>x. UNIV))"
    using assms by (simp add: bernoulli_pmf_half_conv_pmf_of_set Pi_pmf_of_set)
  also have "map_pmf (\<lambda>b. {x\<in>A. b x}) \<dots> = pmf_of_set (Pow A)"
  proof -
    have "bij_betw (\<lambda>b. {x \<in> A. b x}) (PiE_dflt A P (\<lambda>_. UNIV)) (Pow A)"
      by (rule bij_betwI[of _ _ _ "\<lambda>B b. if b \<in> A then b \<in> B else P"]) (auto simp add: PiE_dflt_def)
    then show ?thesis
      using assms by (intro map_pmf_of_set_bij_betw) auto
  qed
  finally show ?thesis
    by simp
qed

text \<open>
  A binomial distribution can be seen as the number of successes in \<open>n\<close> independent coin tosses.
\<close>
lemma binomial_pmf_altdef':
  fixes A :: "'a set"
  assumes "finite A" and "card A = n" and p: "p \<in> {0..1}"
  shows   "binomial_pmf n p =
             map_pmf (\<lambda>f. card {x\<in>A. f x}) (Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p))" (is "?lhs = ?rhs")
proof -
  from assms have "?lhs = binomial_pmf (card A) p"
    by simp
  also have "\<dots> = ?rhs"
  using assms(1)
  proof (induction rule: finite_induct)
    case empty
    with p show ?case by (simp add: binomial_pmf_0)
  next
    case (insert x A)
    from insert.hyps have "card (insert x A) = Suc (card A)"
      by simp
    also have "binomial_pmf \<dots> p = do {
                                     b \<leftarrow> bernoulli_pmf p;
                                     f \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
                                     return_pmf ((if b then 1 else 0) + card {y \<in> A. f y})
                                   }"
      using p by (simp add: binomial_pmf_Suc insert.IH bind_map_pmf)
    also have "\<dots> = do {
                      b \<leftarrow> bernoulli_pmf p;
                      f \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
                      return_pmf (card {y \<in> insert x A. (f(x := b)) y})
                    }"
    proof (intro bind_pmf_cong refl, goal_cases)
      case (1 b f)
      have "(if b then 1 else 0) + card {y\<in>A. f y} = card ((if b then {x} else {}) \<union> {y\<in>A. f y})"
        using insert.hyps by auto
      also have "(if b then {x} else {}) \<union> {y\<in>A. f y} = {y\<in>insert x A. (f(x := b)) y}"
        using insert.hyps by auto
      finally show ?case by simp
    qed
    also have "\<dots> = map_pmf (\<lambda>f. card {y\<in>insert x A. f y})
                      (Pi_pmf (insert x A) dflt (\<lambda>_. bernoulli_pmf p))"
      using insert.hyps by (subst Pi_pmf_insert) (simp_all add: pair_pmf_def map_bind_pmf)
    finally show ?case .
  qed
  finally show ?thesis .
qed

end


theory Metric_Point_Structure
  imports Interval
begin

(* Conversion from the abstract time domain (Definition 4.1) introduced
   in the paper ``Specifying Real-Time Properties with Metric Temporal Logic''
   (Koymans, 1990) to our time-stamps. *)

(* Metric domain. *)

class metric_domain = plus + zero + ord +
  assumes \<Delta>1: "x + x' = x' + x"
    and \<Delta>2: "(x + x') + x'' = x + (x' + x'')"
    and \<Delta>3: "x + 0 = x"
    and \<Delta>3': "x = 0 + x"
    and \<Delta>4: "x + x' = x + x'' \<Longrightarrow> x' = x''"
    and \<Delta>4': "x + x'' = x' + x'' \<Longrightarrow> x = x'"
    and \<Delta>5: "x + x' = 0 \<Longrightarrow> x = 0"
    and \<Delta>5': "x + x' = 0 \<Longrightarrow> x' = 0"
    and \<Delta>6: "\<exists>x''. x = x' + x'' \<or> x' = x + x''"
    and metric_domain_le_def: "x \<le> x' \<longleftrightarrow> (\<exists>x''. x' = x + x'')"
    and metric_domain_lt_def: "x < x' \<longleftrightarrow> (\<exists>x''. x'' \<noteq> 0 \<and> x' = x + x'')"
begin

lemma metric_domain_pos: "x \<ge> 0"
  using \<Delta>3' local.metric_domain_le_def by auto

lemma less_eq_le_neq: "x < x' \<longleftrightarrow> (x \<le> x' \<and> x \<noteq> x')"
  apply (auto simp: metric_domain_le_def metric_domain_lt_def)
   apply (metis \<Delta>3 \<Delta>4)
  apply (metis \<Delta>3)
  done

end

(* Metric domain extended with embedding of natural numbers and syntactically extended with sup, tfin. *)

class metric_domain_timestamp = metric_domain + sup + embed_nat + tfin +
  assumes metric_domain_sup_def: "sup x x' = (if x \<le> x' then x' else x)"
    and metric_domain_\<iota>_mono: "\<And>i j. i \<le> j \<Longrightarrow> \<iota> i \<le> \<iota> j"
    and metric_domain_\<iota>_progressing: "\<exists>j. \<not>\<iota> j \<le> \<iota> i + x"
    and metric_domain_tfin_def: "tfin = UNIV"

subclass (in metric_domain_timestamp) timestamp
  apply unfold_locales
                  apply (auto simp: \<Delta>2)[1]
                 apply (auto simp: \<Delta>1)[1]
                apply (auto simp: \<Delta>3'[symmetric])[1]
  subgoal for x y
    apply (auto simp: metric_domain_le_def metric_domain_lt_def)
     apply (metis \<Delta>2 \<Delta>3 \<Delta>4 \<Delta>5)
    apply (metis \<Delta>2 \<Delta>3)
    done
  using \<Delta>6 apply (auto simp: metric_domain_le_def)[1]
  using \<Delta>2 apply (auto simp: metric_domain_le_def)[1]
  subgoal for x y
    apply (auto simp: metric_domain_le_def metric_domain_lt_def)
    apply (metis \<Delta>2 \<Delta>3 \<Delta>4 \<Delta>5)
    done
  using \<Delta>6 apply (fastforce simp: metric_domain_le_def metric_domain_sup_def)
  using \<Delta>6 apply (fastforce simp: metric_domain_le_def metric_domain_sup_def)
         apply (auto simp: metric_domain_le_def metric_domain_sup_def)[1]
  using metric_domain_\<iota>_mono apply (auto simp: metric_domain_le_def)[1]
       apply (auto simp: metric_domain_tfin_def)[1]
  using metric_domain_\<iota>_progressing apply (auto simp: metric_domain_le_def)[1]
     apply (auto simp: metric_domain_tfin_def)[2]
  using \<Delta>2 apply (auto simp: metric_domain_le_def)[1]
  using \<Delta>1 \<Delta>3 apply (auto simp: metric_domain_lt_def)
  done

(* Metric point structure.
   We map Koymans' time-stamps t in a trace to d t0 t, where t0 is the initial time-stamp of the trace.
   Because Koymans assumes the strict precedence relation on time-stamps to be
   ``transitive, irreflexive and comparable'', the precedence relation is actually a partial order. *)

locale metric_point_structure =
  fixes d :: "'t :: {order} \<Rightarrow> 't \<Rightarrow> 'd :: metric_domain_timestamp"
  assumes d1: "d t t' = 0 \<longleftrightarrow> t = t'"
    and d2: "d t t' = d t' t"
    and d3: "t < t' \<Longrightarrow> t' < t'' \<Longrightarrow> d t t'' = d t t' + d t' t''"
    and d3': "t < t' \<Longrightarrow> t' < t'' \<Longrightarrow> d t'' t = d t'' t' + d t' t"
begin

lemma metric_point_structure_memL_aux: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> x \<le> d t t' \<longleftrightarrow> (d t0 t + x \<le> d t0 t')"
  apply (rule iffI)
   apply (metis \<Delta>1 add_0 add_mono_comm d1 d3 order_le_less)
  apply (cases "t0 < t"; cases "t < t'")
     apply (auto simp: metric_domain_le_def)
     apply (metis \<Delta>4 ab_semigroup_add_class.add_ac(1) d3)
    apply (metis comm_monoid_add_class.add_0 group_cancel.add1 metric_domain_lt_def nless_le)
   apply (metis \<Delta>3' d1)
  apply (metis add_0 d1)
  done

lemma metric_point_structure_memL_strict_aux: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> x < d t t' \<longleftrightarrow> (d t0 t + x < d t0 t')"
  using metric_point_structure_memL_aux[of t0 t t' x]
  apply auto
   apply (metis (no_types, lifting) \<Delta>1 \<Delta>3 \<Delta>4 antisym_conv2 d1 d3)
  apply (metis \<Delta>1 add_0 d1 d3 order.order_iff_strict order_less_irrefl)
  done

lemma metric_point_structure_memR_aux: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> d t t' \<le> x \<longleftrightarrow> (d t0 t' \<le> d t0 t + x)"
  apply auto
   apply (metis \<Delta>1 \<Delta>3 d1 d3 order_le_less add_mono)
  apply (smt (verit, ccfv_threshold) \<Delta>1 \<Delta>2 \<Delta>3 \<Delta>4 d1 d3 metric_domain_le_def order_le_less)
  done

lemma metric_point_structure_memR_strict_aux: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> d t t' < x \<longleftrightarrow> (d t0 t' < d t0 t + x)"
  by (auto simp add: metric_point_structure_memL_aux metric_point_structure_memR_aux less_le_not_le)

lemma metric_point_structure_le_mem: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> d t t' \<le> x \<longleftrightarrow> mem (d t0 t) (d t0 t') (interval 0 x True True)"
  unfolding mem_def
  apply (transfer fixing: d)
  using metric_point_structure_memR_aux
  apply (auto simp: metric_domain_le_def metric_domain_tfin_def)
  apply (metis add.right_neutral d3 order.order_iff_strict)
  done

lemma metric_point_structure_lt_mem: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> 0 < x \<Longrightarrow> d t t' < x \<longleftrightarrow> mem (d t0 t) (d t0 t') (interval 0 x True False)"
  unfolding mem_def
  apply (transfer fixing: d)
  using metric_point_structure_memR_strict_aux
  apply (auto simp: metric_domain_tfin_def)
  apply (metis \<Delta>3 metric_domain_pos metric_point_structure_memL_aux)
  done

lemma metric_point_structure_eq_mem: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> d t t' = x \<longleftrightarrow> mem (d t0 t) (d t0 t') (interval x x True True)"
  unfolding mem_def
  apply (transfer fixing: d)
  subgoal for t0 t t' x
    using metric_point_structure_memL_aux[of t0 t t' x] metric_point_structure_memR_aux[of t0 t t' x] metric_domain_pos
    by (auto simp: metric_domain_tfin_def)
  done

lemma metric_point_structure_ge_mem: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> x \<le> d t t' \<longleftrightarrow> mem (Some (d t0 t)) (Some (d t0 t')) (interval (Some x) None True True)"
  unfolding mem_def
  apply (transfer fixing: d)
  using metric_point_structure_memL_aux by (auto simp: tfin_option_def zero_option_def plus_option_def less_eq_option_def metric_domain_le_def metric_domain_tfin_def split: option.splits)

lemma metric_point_structure_gt_mem: "t0 \<le> t \<Longrightarrow> t \<le> t' \<Longrightarrow> x < d t t' \<longleftrightarrow> mem (Some (d t0 t)) (Some (d t0 t')) (interval (Some x) None False True)"
  unfolding mem_def
  apply (transfer fixing: d)
  using metric_point_structure_memL_strict_aux by (auto simp: tfin_option_def zero_option_def plus_option_def less_option_def less_eq_option_def metric_domain_le_def metric_domain_tfin_def split: option.splits)

end

instantiation nat :: metric_domain_timestamp
begin

instance
  apply standard
               apply auto[8]
        apply (meson less_eqE timestamp_total)
  using nat_le_iff_add apply blast
  using less_imp_add_positive apply auto[1]
     apply (auto simp: sup_max)[1]
    apply (auto simp: \<iota>_nat_def)[1]
  subgoal for i x
    apply (auto simp: \<iota>_nat_def)
    using add_le_same_cancel1 by blast
  apply (auto simp: tfin_nat_def)
  done

end

interpretation nat_metric_point_structure: metric_point_structure "\<lambda>t :: nat. \<lambda>t'. if t \<le> t' then t' - t else t - t'"
  by unfold_locales auto

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_67
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun len :: "'a list => Nat" where
"len (nil2) = Z"
| "len (cons2 y xs) = S (len xs)"

fun butlast :: "'a list => 'a list" where
"butlast (nil2) = nil2"
| "butlast (cons2 y (nil2)) = nil2"
| "butlast (cons2 y (cons2 x2 x3)) =
     cons2 y (butlast (cons2 x2 x3))"

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

theorem property0 :
  "((len (butlast xs)) = (t2 (len xs) (S Z)))"
  oops

end


section \<open>Topology for Floating Point Numbers\<close>
theory Float_Topology
  imports
    "HOL-Analysis.Multivariate_Analysis"
    "HOL-Library.Float"
begin

text \<open>
This topology is totally disconnected and not complete, in which sense is it useful?
Perhaps for convergence of intervals?\<close>

unbundle float.lifting

instantiation float :: dist
begin

lift_definition dist_float :: "float \<Rightarrow> float \<Rightarrow> real" is dist .

lemma dist_float_eq_0_iff: "(dist x y = 0) = (x = y)" for x y::float
  by transfer simp

lemma dist_float_triangle2: "dist x y \<le> dist x z + dist y z" for x y z::float
  by transfer (rule dist_triangle2)

instance ..
end

instantiation float :: uniformity
begin

definition uniformity_float :: "(float \<times> float) filter"
  where "uniformity_float = (INF e\<in>{0<..}. principal {(x, y). dist x y < e})"

instance ..
end

lemma float_dense_in_real:
  fixes x :: real
  assumes "x < y"
  shows "\<exists>r\<in>float. x < r \<and> r < y"
proof -
  from \<open>x < y\<close> have "0 < y - x" by simp
  with reals_Archimedean obtain q' :: nat where q': "inverse (real q') < y - x" and "0 < q'"
    by blast
  define q::nat where "q \<equiv> 2 ^ nat \<bar>bitlen q'\<bar>"
  from bitlen_bounds[of q'] \<open>0 < q'\<close> have "q' < q"
    by (auto simp: q_def)
  then have "inverse q < inverse q'"
    using \<open>0 < q'\<close>
    by (auto simp: divide_simps)
  with \<open>q' < q\<close> q' have q: "inverse (real q) < y - x" and "0 < q"
    by (auto simp: split: if_splits)
  define p where "p = \<lceil>y * real q\<rceil> - 1"
  define r where "r = of_int p / real q"
  from q have "x < y - inverse (real q)"
    by simp
  also from \<open>0 < q\<close> have "y - inverse (real q) \<le> r"
    by (simp add: r_def p_def le_divide_eq left_diff_distrib)
  finally have "x < r" .
  moreover from \<open>0 < q\<close> have "r < y"
    by (simp add: r_def p_def divide_less_eq diff_less_eq less_ceiling_iff [symmetric])
  moreover have "r \<in> float"
    by (simp add: r_def q_def)
  ultimately show ?thesis by blast
qed

lemma real_of_float_dense:
  fixes x y :: real
  assumes "x < y"
  shows "\<exists>q :: float. x < real_of_float q \<and> real_of_float q < y"
  using float_dense_in_real [OF \<open>x < y\<close>]
  by (auto elim: real_of_float_cases)

instantiation float :: linorder_topology
begin

definition open_float::"float set \<Rightarrow> bool" where
  "open_float S = (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"

instance
proof (standard, intro ext iffI)
  fix U::"float set"
  assume "generate_topology (range lessThan \<union> range greaterThan) U"
  then show "open U"
    unfolding open_float_def uniformity_float_def
  proof (induction U)
    case UNIV
    then show ?case by (auto intro!: zero_less_one)
  next
    case (Int a b)
    show ?case
    proof safe
      fix x assume "x \<in> a" "x \<in> b"
      with Int(3,4) obtain e1 e2
        where "dist (y) (x) < e1 \<Longrightarrow> y \<in> a"
          and "dist (y) (x) < e2 \<Longrightarrow> y \<in> b"
          and "0 < e1" "0 < e2"
        for y
        by (auto dest!: bspec)
      then show "\<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: "x \<in> X" and X: "X \<in> K"
      from UN[OF X] x obtain e where
        "dist (y) (x) < e \<Longrightarrow> y \<in> X" "e > 0" for y
        by auto
      then show "\<exists>e>0. \<forall>y. dist (real_of_float y) (real_of_float x) < e \<longrightarrow> y \<in> \<Union>K"
        using x X
        by (auto intro!: exI[where x=e])
    qed
  next
    case (Basis s)
    then show ?case
    proof safe
      fix x u::float
      assume "x < u"
      then show "\<exists>e>0. \<forall>y. dist (real_of_float y) (real_of_float x) < e \<longrightarrow> y \<in> {..<u}"
        by (force simp add: eventually_principal dist_float_def
            dist_real_def abs_real_def
            intro!: exI[where x="(u - x)/2"])
    next
      fix x l::float
      assume "l < x"
      then show "\<exists>e>0. \<forall>y. dist (real_of_float y) (real_of_float x) < e \<longrightarrow> y \<in> {l<..}"
        by (force simp add: eventually_principal dist_float_def
            dist_real_def abs_real_def
            intro!: exI[where x="(x - l)/2"])
    qed
  qed
next
  fix U::"float set"
  assume "open U"
  then obtain e where e:
    "x \<in> U \<Longrightarrow> e x > 0"
    "x \<in> U \<Longrightarrow> dist ( y) ( x) < e x \<Longrightarrow> y \<in> U" for x y
    unfolding open_float_def uniformity_float_def
    by metis
  {
    fix x
    assume x: "x \<in> U"
    obtain e' where e': "e' > 0" "real_of_float e' < e x"
      using real_of_float_dense[of 0 "e x"]
      using e(1)[OF x]
      by auto
    then have "dist (y) ( x) < e' \<Longrightarrow> y \<in> U" for y
      by (intro e[OF x]) auto
    then have "\<exists>e'>0. \<forall>y. dist (y) ( x) < real_of_float e' \<longrightarrow> y \<in> U"
      using e'
      by auto
  } then
  obtain e' where e':
    "x \<in> U \<Longrightarrow> 0 < e' x"
    "x \<in> U \<Longrightarrow> dist y x < real_of_float (e' x) \<Longrightarrow> y \<in> U" for x y
    by metis
  then have "U = (\<Union>x\<in>U. greaterThan (x - e' x) \<inter> lessThan (x + e' x))"
    by (auto simp: dist_float_def dist_commute dist_real_def)
  also have "generate_topology (range lessThan \<union> range greaterThan) \<dots>"
    by (intro generate_topology_Union generate_topology.Int generate_topology.Basis) auto
  finally show "generate_topology (range lessThan \<union> range greaterThan) U" .
qed

end

instance float :: metric_space
proof standard
  fix U::"float set"
  show "open U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> U)"
    unfolding open_float_def open_dist uniformity_float_def uniformity_real_def
  proof safe
    fix x
    assume "\<forall>x\<in>U. \<exists>e>0. \<forall>y. dist (real_of_float y) (real_of_float x) < e \<longrightarrow> y \<in> U" "x \<in> U"
    then obtain e where "e > 0" "dist (y) (x) < e \<Longrightarrow> y \<in> U" for y
      by auto
    then show "\<forall>\<^sub>F (x', y) in INF e\<in>{0<..}. principal {(x, y). dist x y < e}. x' = x \<longrightarrow> y \<in> U"
      by (intro eventually_INF1[where i=e])
        (auto simp: eventually_principal dist_commute dist_float_def)
  next
    fix u
    assume "\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in INF e\<in>{0<..}. principal {(x, y). dist x y < e}. x' = x \<longrightarrow> y \<in> U"
      "u \<in> U"
    from this obtain E where E: "E \<subseteq> {0<..}" "finite E"
      "\<forall>(x', y)\<in>\<Inter>x\<in>E. {(y', y). dist y' y < x}. x' = u \<longrightarrow> y \<in> U"
      by (subst (asm) eventually_INF) (auto simp: INF_principal_finite eventually_principal)
    then show "\<exists>e>0. \<forall>y. dist (real_of_float y) (real_of_float u) < e \<longrightarrow> y \<in> U"
      by (intro exI[where x="if E = {} then 1 else Min E"])
        (auto simp: dist_commute dist_float_def)
  qed
qed (use dist_float_eq_0_iff dist_float_triangle2 in
    \<open>auto simp add: uniformity_float_def dist_float_def\<close>)

instance float::topological_ab_group_add
proof
  fix a b::float
  show "((\<lambda>x. fst x + snd x) \<longlongrightarrow> a + b) (nhds a \<times>\<^sub>F nhds b)"
  proof (rule tendstoI)
    fix e::real
    assume "e > 0"
    have 1: "(fst \<longlongrightarrow> a) (nhds a \<times>\<^sub>F nhds b)"
      and 2: "(snd \<longlongrightarrow> b) (nhds a \<times>\<^sub>F nhds b)"
      by (auto intro!: tendsto_eq_intros filterlim_ident simp: nhds_prod[symmetric])
    have "\<forall>\<^sub>F x in nhds a \<times>\<^sub>F nhds b. dist (fst x) (a) < e/2"
      by (rule tendstoD[OF 1]) (use \<open>e > 0\<close> in auto)
    moreover have "\<forall>\<^sub>F x in nhds a \<times>\<^sub>F nhds b. dist (snd x) (b) < e/2"
      by (rule tendstoD[OF 2]) (use \<open>e > 0\<close> in auto)
    ultimately show "\<forall>\<^sub>F x in nhds a \<times>\<^sub>F nhds b. dist (fst x + snd x) (a + b) < e"
    proof eventually_elim
      case (elim x)
      then show ?case
        by (auto simp: dist_float_def) norm
    qed
  qed
  show "(uminus \<longlongrightarrow> - a) (nhds a)"
    using filterlim_ident[of "nhds a"]
    by (auto intro!: tendstoI dest!: tendstoD simp: dist_float_def dist_minus)
qed

lifting_update float.lifting
lifting_forget float.lifting

end


theory subspace imports topological_space   begin

definition (in topological_space)
  subspace_topology :: "'a set \<Rightarrow>'a set set" where
(* "subspace_topology  S  \<equiv>   { \<forall>t \<in> T. S \<inter> t }  "*)
  "subspace_topology  S = {a .\<exists>u\<in>T. a = S \<inter> u }"
thm topological_space.subspace_topology_def

lemma  (in topological_space) subspace_inter[simp ,intro]:
  assumes    a1 : "S \<subseteq> X"
  and        a2 : "x \<in> {a. \<exists>u\<in>T. a = S \<inter> u}"
  and        a3 : "y \<in> {a. \<exists>u\<in>T. a = S \<inter> u}"
  shows   "x \<inter> y \<in> {a. \<exists>u\<in>T. a = S \<inter> u}"

proof-
  from a2  have b : "\<exists>u1\<in>T. x = S \<inter> u1   "  apply simp done
  from a3 have c : "\<exists>u2\<in>T. y = S \<inter> u2   "  apply simp done
  from b c have d : "\<exists>u1\<in>T. \<exists>u2\<in> T. x \<inter> y = S \<inter> (u1 \<inter> u2)" apply blast  done
  from  d have e : "\<exists>u1\<in>T. \<exists>u2\<in> T. x \<inter> y = S \<inter> (u1 \<inter> u2) \<and> (u1 \<inter> u2 \<in> T)"
            apply  (simp add:topological_space_def) done
 from e have  f : "\<exists>u3\<in>T. x \<inter> y = S \<inter> u3  "  apply blast done
 from a1 a2 a3  f  show ?thesis apply blast  done
qed

definition (in topological_space) map_B :: "['a set , 'a set  ]\<Rightarrow> 'a set " where
   " map_B S a  = \<Union>{u.  a = S \<inter>  u \<and> u \<in> T}"

lemma (in topological_space) subspace_in_T[simp,intro]:
 "{u. a=S \<inter> u \<and> u \<in> T} \<subseteq> T "
apply blast
done

lemma (in topological_space)subspace_union[simp,intro]:
  assumes  a1:  "S \<subseteq> X"
  and      a2:  " A \<subseteq> {a. \<exists>u\<in>T. a = S \<inter> u}"
(*  and      a3:  "\<And>a. \<lbrakk>a\<in>A\<rbrakk>  \<Longrightarrow> B a \<in> T  "
  and      a4:  "\<And>a. \<lbrakk>a\<in>A\<rbrakk>  \<Longrightarrow> ( a = (S \<inter> (B a)))"*)
  shows    "\<exists>u\<in>T. \<Union>A = S \<inter> u"
proof-
  from  a2  have s1:  "\<Union>A = \<Union>{a. a\<in>A}"  apply (simp) done
  from  a2   have s2 : "\<Union>{a. a\<in>A}= \<Union>{c. \<exists>a\<in>A. c =a }" apply (simp) done
  from  a1 a2  have s3: "\<And>a. \<lbrakk> a\<in>A \<rbrakk> \<Longrightarrow>  (map_B S a ) \<in> T"
             apply(simp add:map_B_def subspace_in_T)   done
             (*apply blast  done*)
 from a2 s3 have s4: "\<And>a. \<lbrakk>a\<in>A\<rbrakk>  \<Longrightarrow> ( a = (S \<inter> (map_B S a)))" apply (simp add:map_B_def) apply blast done
  from  s4   have s5 : "{c. \<exists>a\<in>A. c=a}={c. \<exists>a\<in>A. c= S \<inter> map_B S a }  " apply  simp  done
  from s1 s2 s5 have s6 : "\<Union>A = \<Union>{c. \<exists>a\<in>A. c=S \<inter> map_B S  a } "  apply simp done
  from s3 s4 have s7  : "\<Union>{c. \<exists>a\<in>A. c= S \<inter> (map_B S a)} = \<Union>{u. \<exists>a\<in>A. u =(map_B S  a) } \<inter> S " apply blast done
  from a2 s3 s4  have  s8: "\<And>t. \<lbrakk>t\<in>{u. \<exists>a\<in>A. u =map_B S a}\<rbrakk> \<Longrightarrow> t \<in>  T"
        apply (simp add :Pi_def) apply blast done
  from s8 have  s9 : "{u. \<exists>a\<in>A. u =map_B S a} \<subseteq> T " apply blast done
  from s9 have  s10 : "\<Union>{u. \<exists>a\<in>A. u =map_B S a} \<in> T "
         apply(simp add:map_B_def subspace_in_T) done
  from s10 have s11 : "\<exists>u\<in>T. u=\<Union>{u. \<exists>a\<in>A. u =map_B S a}" apply simp done
  from s1 s2 s6 s7 have s12: "\<Union>A = \<Union>{u. \<exists>a\<in>A. u =map_B S a } \<inter> S " apply simp done
  from s11 s12 have s13 : "\<exists>u\<in>T. \<Union>A= u \<inter> S"   apply blast done
  have s14 : "\<forall>u\<in>T. u \<inter> S = S \<inter> u" apply blast done
  (*from m n  have o: "\<exists>u\<in>T. \<Union>A = S \<inter> u" apply simp  done*)
  from s13 s14  show  ?thesis apply simp done
qed

lemma (in topological_space)subspace_union_1[simp,intro]:
"\<lbrakk> S \<subseteq> X ; A \<subseteq> {a. \<exists>u\<in>T. a = S \<inter> u}\<rbrakk>  \<Longrightarrow> \<exists>u\<in>T. \<Union>A = S \<inter> u"
apply (blast intro: subspace_union)
done

lemma (in topological_space) empty_in_subspace:
"{} \<in> {a. \<exists>u\<in>T. a = S \<inter> u}"
apply simp
apply auto
done

lemma (in topological_space)S_in_subspace:
" S \<subseteq> X \<Longrightarrow> S \<in> {a. \<exists>u\<in>T. a = S \<inter> u}"
apply auto
done

thm topological_space.subspace_topology_def

lemma (in topological_space)
   subspace_is_top:
  "\<lbrakk>S \<subseteq> X\<rbrakk> \<Longrightarrow>
    topological_space S (subspace_topology S)"
apply (simp add:subspace_topology_def)
apply  (rule topological_space.intro)
apply  blast
apply  (rule empty_in_subspace)
apply (rule S_in_subspace,assumption+)
apply (erule subspace_inter,assumption+)
apply (simp add: subspace_union_1)
done

end


(*  Title:      HOL/Datatype_Examples/Lambda_Term.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Lambda-terms.
*)

section \<open>Lambda-Terms\<close>

theory Lambda_Term
imports "HOL-Library.FSet"
begin

section \<open>Datatype definition\<close>

datatype 'a trm =
  Var 'a |
  App "'a trm" "'a trm" |
  Lam 'a "'a trm" |
  Lt "('a \<times> 'a trm) fset" "'a trm"

subsection \<open>Example: The set of all variables varsOf and free variables fvarsOf of a term\<close>

primrec varsOf :: "'a trm \<Rightarrow> 'a set" where
  "varsOf (Var a) = {a}"
| "varsOf (App f x) = varsOf f \<union> varsOf x"
| "varsOf (Lam x b) = {x} \<union> varsOf b"
| "varsOf (Lt F t) = varsOf t \<union> (\<Union>{{x} \<union> X | x X. (x,X) |\<in>| fimage (map_prod id varsOf) F})"

primrec fvarsOf :: "'a trm \<Rightarrow> 'a set" where
  "fvarsOf (Var x) = {x}"
| "fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
| "fvarsOf (Lam x t) = fvarsOf t - {x}"
| "fvarsOf (Lt xts t) = fvarsOf t - {x | x X. (x,X) |\<in>| fimage (map_prod id varsOf) xts} \<union>
    (\<Union>{X | x X. (x,X) |\<in>| fimage (map_prod id varsOf) xts})"

lemma diff_Un_incl_triv: "\<lbrakk>A \<subseteq> D; C \<subseteq> E\<rbrakk> \<Longrightarrow> A - B \<union> C \<subseteq> D \<union> E" by blast

lemma in_fimage_map_prod_fset_iff[simp]:
  "(x, y) |\<in>| fimage (map_prod f g) xts \<longleftrightarrow> (\<exists> t1 t2. (t1, t2) |\<in>| xts \<and> x = f t1 \<and> y = g t2)"
  by force

lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
proof induct
  case (Lt xts t) thus ?case unfolding fvarsOf.simps varsOf.simps by (elim diff_Un_incl_triv) auto
qed auto

end