(*
Title: A Light-Weight Component for Kleene Algebra
Author: Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Kleene Algebra Light\<close>

theory "KA_light"
  imports Main

begin

text \<open>Here is a light-weight component for Kleene algebra. It could eventually be replaced by the AFP entry.\<close>

subsection \<open>Semilattices\<close>

class sup_semilattice = comm_monoid_add + ord +
  assumes add_idem: "x + x = x"
  and order_def: "(x \<le> y) = (x + y = y)"
  and strict_order_def: "(x < y) = (x \<le> y \<and> x \<noteq> y)"

begin

subclass order
  apply unfold_locales
     apply ( simp_all add: local.add_idem local.order_def local.strict_order_def add_commute)
   apply force
  by (metis add_assoc)

lemma zero_least: "0 \<le> x"
  by (simp add: local.order_def)

lemma add_isor: "x \<le> y \<Longrightarrow> x + z \<le> y + z"
  by (smt (verit, best) add_assoc add_commute local.add_idem local.order_def)

lemma add_iso: "x \<le> y \<Longrightarrow> x' \<le> y' \<Longrightarrow> x + x' \<le> y + y'"
  by (metis add_commute add_isor local.dual_order.trans)

lemma add_ubl: "x \<le> x + y"
  by (metis add_assoc local.add_idem local.order_def)

lemma add_ubr: "y \<le> x + y"
  using add_commute add_ubl by fastforce

lemma add_least: "x \<le> z \<Longrightarrow> y \<le> z \<Longrightarrow> x + y \<le> z"
  by (simp add: add_assoc local.order_def)

lemma add_lub: "(x + y \<le> z) = (x \<le> z \<and> y \<le> z)"
  using add_least add_ubl add_ubr dual_order.trans by blast

end

subsection \<open>Dioids\<close>

text \<open>Dioids are multiplicatively idempotent semirings.\<close>

notation times (infixl "\<cdot>" 70)

class dioid =  monoid_mult + sup_semilattice +
  assumes distl: "x \<cdot> (y + z) = x \<cdot> y + x \<cdot> z"
  and distr: "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"
  and annil [simp]: "0 \<cdot> x = 0"
  and annir [simp]: "x \<cdot> 0 = 0"

sublocale dioid \<subseteq> dd: dioid _ "\<lambda>x y. y \<cdot> x" _ _ _ _
  by (unfold_locales, simp_all add: mult_assoc local.distr local.distl)

class semiring_01 = semiring_0 + one +
  assumes onel [simp]: "1 \<cdot> x = x"
  and oner [simp]: "x \<cdot> 1 = x"

subclass (in dioid) semiring_01
  by (unfold_locales, simp_all add: local.distr local.distl)

text \<open>We do not use Isabelle's semirings because they require that 0 is not equal to 1.\<close>

lemma (in dioid) mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis local.distl local.order_def)

lemma (in dioid) mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (simp add: local.dd.mult_isol)

lemma (in dioid) mult_iso: "x \<le> y \<Longrightarrow> x' \<le> y' \<Longrightarrow> x \<cdot> x' \<le> y \<cdot> y'"
  using order_trans mult_isol mult_isor by blast

lemma (in dioid) power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x ^ i \<cdot> z \<le> y"
  apply (induct i)
   apply (simp add: local.add_lub)
  by (smt (verit, ccfv_SIG) dd.mult_assoc local.add_lub local.order_def local.power.power_Suc mult_isol)

lemma (in dioid) power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ i \<le> y"
  apply (induct i)
   apply (simp add: local.add_lub)
  by (smt (verit, ccfv_SIG) dd.mult_assoc local.add_lub local.order_def local.power_Suc2 mult_isor)

subsection \<open>Kleene Algebras\<close>

class star_op =
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)

class kleene_algebra = dioid + star_op +
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

sublocale kleene_algebra \<subseteq> dka: kleene_algebra _ "\<lambda>x y. y \<cdot> x" _ _ _ _ _
  by (unfold_locales, simp_all add: local.star_unfoldr local.star_unfoldl local.star_inductr local.star_inductl)

lemma (in kleene_algebra) one_le_star: "1 \<le> x\<^sup>\<star>"
  using local.add_lub local.star_unfoldl by blast

lemma (in kleene_algebra) star_unfoldlr: "x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  using add_lub star_unfoldl by simp

lemma (in kleene_algebra) star_unfoldrr: "x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  by (simp add: local.dka.star_unfoldlr)

lemma (in kleene_algebra) star_infl: "x \<le> x\<^sup>\<star>"
  by (metis add_assoc local.distl local.mult_1_right local.order_def one_le_star star_unfoldlr)

lemma (in kleene_algebra) star_power: "x ^ i \<le> x\<^sup>\<star>"
  apply (induct i)
  apply (simp add: one_le_star)
  by (metis local.mult_1_left local.power_inductr local.star_unfoldr)

lemma (in kleene_algebra) star_trans [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
  apply (rule order.antisym)
  apply (simp add: local.add_least local.star_inductl local.star_unfoldlr)
  using local.mult_isol local.one_le_star by fastforce

lemma (in kleene_algebra) star_idem [simp]: "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"
  by (metis order.antisym local.eq_refl local.mult_1_right local.order_def local.star_inductl one_le_star star_infl star_trans)

lemma (in kleene_algebra) star_unfoldl_eq [simp]: "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
  by (metis local.add_iso order.antisym local.mult_1_right local.mult_isol local.order_refl local.star_inductl local.star_unfoldl)

lemma (in kleene_algebra) star_unfoldr_eq: "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
  by simp

lemma (in kleene_algebra) star_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
  by (smt (verit, ccfv_SIG) add_assoc local.add_ubl local.distr local.mult_1_right local.order_def local.star_inductl local.star_unfoldl_eq)

lemma (in kleene_algebra) star_slide: "(x \<cdot> y)\<^sup>\<star> \<cdot> x = x \<cdot> (y \<cdot> x)\<^sup>\<star>"
  apply (rule order.antisym)
   apply (smt (verit, del_insts) local.add_lub local.mult_1_right local.mult_isol local.star_inductl mult_assoc one_le_star star_unfoldlr)
  by (smt (z3) local.distr local.eq_refl local.mult.semigroup_axioms local.mult_1_left local.star_inductr semigroup.assoc star_unfoldr_eq)

lemma (in kleene_algebra) star_denest: "(x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
 proof (rule order.antisym)
  have a: "1 \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (metis mult_1_right mult_isol order_trans one_le_star)
  have b: "x \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: mult_isor star_unfoldlr)
  have "y \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: star_unfoldlr)
  also have  "\<dots> = 1 \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by simp
  also have "\<dots> \<le>  x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    using mult_isor one_le_star by blast
  finally have "y \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>".
  hence "1 + (x + y) \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: a b add_lub distr)
  thus  "(x + y)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    using mult_assoc star_inductl by fastforce
  have a: "x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by (simp add: add_ubl star_iso)
  have "y \<le> (x + y)\<^sup>\<star>"
    using add_lub star_infl by blast
  hence "(y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> ((x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<star>)\<^sup>\<star>"
    using a mult_iso star_iso by blast
  also have "\<dots> = (x + y)\<^sup>\<star>"
    by simp
  finally have "(y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>".
  hence "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<star>"
    using a mult_iso by blast
  also have "\<dots> \<le> (x + y)\<^sup>\<star>"
    by simp
  finally show "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>".
qed

lemma (in kleene_algebra) star_subid: "x \<le> 1 \<Longrightarrow> x\<^sup>\<star> = 1"
  by (metis add_commute local.mult_1_left local.order.refl local.order_def local.star_inductr one_le_star)

lemma (in kleene_algebra) zero_star [simp]: "0\<^sup>\<star> = 1"
  by (simp add: zero_least star_subid)

lemma (in kleene_algebra) one_star [simp]: "1\<^sup>\<star> = 1"
  by (simp add: star_subid)

lemma (in kleene_algebra) star_sim1: "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y\<^sup>\<star> \<cdot> z"
  by (smt (verit) add_assoc add_commute local.dd.distl local.dd.distr local.dd.mult_assoc local.mult_1_left local.order_def local.star_inductr one_le_star star_unfoldr_eq)

lemma (in kleene_algebra) star_sim2: "x \<cdot> z \<le> z \<cdot> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z  \<le> z \<cdot> y\<^sup>\<star>"
  by (simp add: local.dka.star_sim1)

lemma (in kleene_algebra) star_inductl_var: "x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y"
  by (simp add: local.add_least local.star_inductl)

lemma (in kleene_algebra) star_inductr_var: "y \<cdot> x \<le> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"
  by (simp add: local.dka.star_inductl_var)

lemma (in kleene_algebra) church_rosser: "y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<Longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  apply (rule order.antisym)
  apply (smt (verit, ccfv_SIG) add_commute local.mult_isor mult_assoc star_denest star_idem star_sim1 star_trans)
  by (metis local.add_ubl local.add_ubr local.mult_iso star_iso star_trans)

lemma (in kleene_algebra) power_sup: "((\<Sum>i=0..n. x^i) \<le> y) = (\<forall>i. 0 \<le> i \<and> i \<le> n \<longrightarrow> x^i \<le> y)"
  apply (induct n)
   apply simp
  using le_Suc_eq local.add_lub by force

lemma (in kleene_algebra) power_dist: "(\<Sum>i=0..n. x ^ i) \<cdot> x = (\<Sum>i=0..n. x ^ Suc i)"
  apply (induct n)
   apply simp
  using local.distr local.power_Suc2 local.sum.atLeast0_atMost_Suc by presburger

lemma (in kleene_algebra) power_sum: "(\<Sum>i=0..n. x ^ Suc i) = (\<Sum>i=1..n. x ^ i) + x ^ Suc n"
  apply (induct n)
  by force+

lemma (in kleene_algebra) sum_star: "x\<^sup>\<star> = (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=0..n. x ^ i)"
proof (rule order.antisym)
  have "1 + (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=0..n. x ^ i) \<cdot> x = 1 + (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=0..n. x ^ Suc i)"
    using local.mult_assoc power_dist by presburger
  also have "\<dots> =  1 + (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=1..n. x ^ i) + (x ^ Suc n)\<^sup>\<star> \<cdot> x ^ Suc n"
    using local.add_assoc local.distl local.power_sum by presburger
  also have "\<dots> = (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=1..n. x ^ i) + (x ^ Suc n)\<^sup>\<star>"
    by (metis local.add.left_commute local.add_assoc star_unfoldr_eq)
  also have "\<dots> = (x ^ Suc n)\<^sup>\<star> \<cdot> (1 + (\<Sum>i=1..n. x ^ i))"
    using add_commute local.distl local.mult_1_right by presburger
  also have "\<dots> = (x ^ Suc n)\<^sup>\<star> \<cdot> (\<Sum>i=0..n. x ^ i)"
    by (simp add: local.sum.atLeast_Suc_atMost)
  finally show "x\<^sup>\<star> \<le> (x ^ Suc n)\<^sup>\<star> \<cdot> sum ((^) x) {0..n}"
    by (metis local.mult_1_left local.order_refl local.star_inductr)
next
  have a: "(x ^ Suc n)\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (metis star_idem star_iso star_power)
  have "(\<Sum>i=0..n. x ^ i) \<le> x\<^sup>\<star>"
    using power_sup star_power by presburger
  thus "(x ^ Suc n)\<^sup>\<star> \<cdot> sum ((^) x) {0..n} \<le> x\<^sup>\<star>"
    by (metis a local.mult_iso star_trans)
qed

lemma (in kleene_algebra) newman_aux: "x\<^sup>\<star> \<cdot> y \<cdot> z\<^sup>\<star> = x\<^sup>\<star> \<cdot> y + x\<^sup>\<star> \<cdot> x \<cdot> y \<cdot> z \<cdot> z\<^sup>\<star> + y \<cdot> z\<^sup>\<star>"
  by (smt (z3) add_commute local.add.left_commute local.distl local.distr local.mult.monoid_axioms local.mult.semigroup_axioms local.mult_1_right local.order_def monoid.left_neutral one_le_star semigroup.assoc star_unfoldl_eq star_unfoldr_eq)

end


theory prop_53
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun insort :: "Nat => Nat list => Nat list" where
  "insort x (Nil2) = Cons2 x (Nil2)"
  | "insort x (Cons2 z xs) =
       (if le x z then Cons2 x (Cons2 z xs) else Cons2 z (insort x xs))"
  fun sort :: "Nat list => Nat list" where
  "sort (Nil2) = Nil2"
  | "sort (Cons2 y xs) = insort y (sort xs)"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun count :: "Nat => Nat list => Nat" where
  "count x (Nil2) = Z"
  | "count x (Cons2 z ys) =
       (if equal2 x z then S (count x ys) else count x ys)"
  (*hipster le insort sort equal2 count *)

lemma lemma_a [thy_expl]: "equal2 x4 y4 = equal2 y4 x4"
by (hipster_induct_schemes equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes equal2.simps)

(*hipster le*)
lemma lemma_ac [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ad [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ae [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps)

lemma lemma_af [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes insort.simps)

lemma lemma_ag [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes insort.simps)

lemma lemma_ah [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes insort.simps)

lemma lemma_ai [thy_expl]: "insort Z (sort x2) = sort (insort Z x2)"
by (hipster_induct_schemes  sort.simps)
(*
hipster_cond le insort\<exclamdown>d

hipster_cond equal2 count sort

hipster insort sort count

  theorem x0 :
    "(count n xs) = (count n (sort xs))"
    by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})
end


theory ex4_06 imports Main "~~/src/HOL/IMP/AExp" begin

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
const_rel: "aval_rel (N n) _ n" |
var_rel: "v = s x \<Longrightarrow> aval_rel (V x) s v" |
pl_rel: "\<lbrakk> aval_rel a1 s v1; aval_rel a2 s v2; v = v1+v2 \<rbrakk> \<Longrightarrow> aval_rel (Plus a1 a2) s v"

theorem rel2val: "aval_rel a s v \<Longrightarrow> aval a s = v"
by (induction rule: "aval_rel.induct", auto)

theorem val2rel: "aval a s = v \<Longrightarrow> aval_rel a s v"
apply(induction arbitrary: s v rule: aexp.induct)
apply(simp add: const_rel)
apply(simp add: var_rel)
apply(rule pl_rel)
apply auto
done

theorem "aval_rel a s v \<longleftrightarrow> aval a s = v"
using rel2val val2rel by blast

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Preorders with explicit equivalence relation\<close>

theory Preorder
imports Main
begin

class preorder_equiv = preorder
begin

definition equiv :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "equiv x y \<longleftrightarrow> x \<le> y \<and> y \<le> x"

notation
  equiv ("'(\<approx>')") and
  equiv ("(_/ \<approx> _)"  [51, 51] 50)

lemma equivD1: "x \<le> y" if "x \<approx> y"
  using that by (simp add: equiv_def)

lemma equivD2: "y \<le> x" if "x \<approx> y"
  using that by (simp add: equiv_def)

lemma equiv_refl [iff]: "x \<approx> x"
  by (simp add: equiv_def)

lemma equiv_sym: "x \<approx> y \<longleftrightarrow> y \<approx> x"
  by (auto simp add: equiv_def)

lemma equiv_trans: "x \<approx> y \<Longrightarrow> y \<approx> z \<Longrightarrow> x \<approx> z"
  by (auto simp: equiv_def intro: order_trans)

lemma equiv_antisym: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x \<approx> y"
  by (simp only: equiv_def)

lemma less_le: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> x \<approx> y"
  by (auto simp add: equiv_def less_le_not_le)

lemma le_less: "x \<le> y \<longleftrightarrow> x < y \<or> x \<approx> y"
  by (auto simp add: equiv_def less_le)

lemma le_imp_less_or_equiv: "x \<le> y \<Longrightarrow> x < y \<or> x \<approx> y"
  by (simp add: less_le)

lemma less_imp_not_equiv: "x < y \<Longrightarrow> \<not> x \<approx> y"
  by (simp add: less_le)

lemma not_equiv_le_trans: "\<not> a \<approx> b \<Longrightarrow> a \<le> b \<Longrightarrow> a < b"
  by (simp add: less_le)

lemma le_not_equiv_trans: "a \<le> b \<Longrightarrow> \<not> a \<approx> b \<Longrightarrow> a < b"
  by (rule not_equiv_le_trans)

lemma antisym_conv: "y \<le> x \<Longrightarrow> x \<le> y \<longleftrightarrow> x \<approx> y"
  by (simp add: equiv_def)

end

ML_file \<open>~~/src/Provers/preorder.ML\<close>

ML \<open>
structure Quasi = Quasi_Tac(
struct

val le_trans = @{thm order_trans};
val le_refl = @{thm order_refl};
val eqD1 = @{thm equivD1};
val eqD2 = @{thm equivD2};
val less_reflE = @{thm less_irrefl};
val less_imp_le = @{thm less_imp_le};
val le_neq_trans = @{thm le_not_equiv_trans};
val neq_le_trans = @{thm not_equiv_le_trans};
val less_imp_neq = @{thm less_imp_not_equiv};

fun decomp_quasi thy (Const (@{const_name less_eq}, _) $ t1 $ t2) = SOME (t1, "<=", t2)
  | decomp_quasi thy (Const (@{const_name less}, _) $ t1 $ t2) = SOME (t1, "<", t2)
  | decomp_quasi thy (Const (@{const_name equiv}, _) $ t1 $ t2) = SOME (t1, "=", t2)
  | decomp_quasi thy (Const (@{const_name Not}, _) $ (Const (@{const_name equiv}, _) $ t1 $ t2)) = SOME (t1, "~=", t2)
  | decomp_quasi thy _ = NONE;

fun decomp_trans thy t = case decomp_quasi thy t of
    x as SOME (t1, "<=", t2) => x
  | _ => NONE;

end
);
\<close>

end


(* Title: Design_Isomorphisms
   Author: Chelsea Edmonds
*)

section \<open> Design Isomorphisms \<close>

theory Design_Isomorphisms imports Design_Basics Sub_Designs
begin

subsection \<open> Images of Set Systems \<close>

text \<open> We loosely define the concept of taking the "image" of a set system, as done in isomorphisms.
Note that this is not based off mathematical theory, but is for ease of notation \<close>
definition blocks_image :: "'a set multiset \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b set multiset" where
"blocks_image B f \<equiv> image_mset ((`) f) B"

lemma image_block_set_constant_size: "size (B) = size (blocks_image B f)"
  by (simp add: blocks_image_def)

lemma (in incidence_system) image_set_system_wellformed:
  "incidence_system (f ` \<V>) (blocks_image \<B> f)"
  by (unfold_locales, auto simp add: blocks_image_def) (meson image_eqI wf_invalid_point)

lemma (in finite_incidence_system) image_set_system_finite:
  "finite_incidence_system (f ` \<V>) (blocks_image \<B> f)"
  using image_set_system_wellformed finite_sets
  by (intro_locales) (simp_all add: blocks_image_def finite_incidence_system_axioms.intro)

subsection \<open>Incidence System Isomorphisms \<close>

text \<open>Isomorphism's are defined by the Handbook of Combinatorial Designs
\cite{colbournHandbookCombinatorialDesigns2007} \<close>

locale incidence_system_isomorphism = source: incidence_system \<V> \<B> + target: incidence_system \<V>' \<B>'
  for "\<V>" and "\<B>" and "\<V>'" and "\<B>'" + fixes bij_map ("\<pi>")
  assumes bij: "bij_betw \<pi> \<V> \<V>'"
  assumes block_img: "image_mset ((`) \<pi>) \<B> = \<B>'"
begin

lemma iso_eq_order: "card \<V> = card \<V>'"
  using bij bij_betw_same_card by auto

lemma iso_eq_block_num: "size \<B> = size \<B>'"
  using block_img by (metis size_image_mset)

lemma iso_block_img_alt_rep: "{# \<pi> ` bl . bl \<in># \<B>#} = \<B>'"
  using block_img by simp

lemma inv_iso_block_img: "image_mset ((`) (inv_into \<V> \<pi>)) \<B>' = \<B>"
proof -
  have "\<And> x. x \<in> \<V> \<Longrightarrow> ((inv_into \<V> \<pi>) \<circ> \<pi>) x = x"
    using bij bij_betw_inv_into_left comp_apply by fastforce
  then have "\<And> bl x . bl \<in># \<B> \<Longrightarrow> x \<in> bl  \<Longrightarrow> ((inv_into \<V> \<pi>) \<circ> \<pi>) x = x"
    using source.wellformed by blast
  then have img: "\<And> bl . bl \<in># \<B> \<Longrightarrow> image ((inv_into \<V> \<pi>) \<circ> \<pi>) bl = bl"
    by simp
  have "image_mset ((`) (inv_into \<V> \<pi>)) \<B>' = image_mset ((`) (inv_into \<V> \<pi>)) (image_mset ((`) \<pi>) \<B>)"
    using block_img by simp
  then have "image_mset ((`) (inv_into \<V> \<pi>)) \<B>' = image_mset ((`) ((inv_into \<V> \<pi>) \<circ> \<pi>)) \<B>"
    by (metis (no_types, hide_lams) comp_apply image_comp multiset.map_comp multiset.map_cong0)
  thus ?thesis using img by simp
qed

lemma inverse_incidence_sys_iso: "incidence_system_isomorphism \<V>' \<B>' \<V> \<B> (inv_into \<V> \<pi>)"
  using bij bij_betw_inv_into inv_iso_block_img by (unfold_locales) simp

lemma iso_points_map: "\<pi> ` \<V> = \<V>'"
  using bij by (simp add: bij_betw_imp_surj_on)

lemma iso_points_inv_map: "(inv_into \<V> \<pi>) `  \<V>' = \<V>"
  using incidence_system_isomorphism.iso_points_map inverse_incidence_sys_iso by blast

lemma iso_points_ss_card:
  assumes "ps \<subseteq> \<V>"
  shows "card ps = card (\<pi> ` ps)"
  using assms bij bij_betw_same_card bij_betw_subset by blast

lemma iso_block_in: "bl \<in># \<B> \<Longrightarrow> (\<pi> ` bl) \<in># \<B>'"
  using iso_block_img_alt_rep
  by (metis image_eqI in_image_mset)

lemma iso_inv_block_in: "x \<in># \<B>' \<Longrightarrow> x \<in> (`) \<pi> ` set_mset \<B>"
  by (metis block_img in_image_mset)

lemma iso_img_block_orig_exists: "x \<in># \<B>' \<Longrightarrow> \<exists> bl . bl \<in># \<B> \<and> x = \<pi> ` bl"
  using iso_inv_block_in by blast

lemma iso_blocks_map_inj: "x \<in># \<B> \<Longrightarrow> y \<in># \<B> \<Longrightarrow> \<pi> ` x = \<pi> ` y \<Longrightarrow> x = y"
  using image_inv_into_cancel incidence_system.wellformed iso_points_inv_map iso_points_map
  by (metis (no_types, lifting) source.incidence_system_axioms subset_image_iff)

lemma iso_bij_betwn_block_sets: "bij_betw ((`) \<pi>) (set_mset \<B>) (set_mset \<B>')"
  apply ( simp add: bij_betw_def inj_on_def)
  using iso_block_in iso_inv_block_in iso_blocks_map_inj by auto

lemma iso_bij_betwn_block_sets_inv: "bij_betw ((`) (inv_into \<V> \<pi>)) (set_mset \<B>') (set_mset \<B>)"
  using incidence_system_isomorphism.iso_bij_betwn_block_sets inverse_incidence_sys_iso by blast

lemma iso_bij_betw_individual_blocks: "bl \<in># \<B> \<Longrightarrow> bij_betw \<pi> bl (\<pi> ` bl)"
  using bij bij_betw_subset source.wellformed by blast

lemma iso_bij_betw_individual_blocks_inv: "bl \<in># \<B> \<Longrightarrow> bij_betw (inv_into \<V> \<pi>) (\<pi> ` bl) bl"
  using bij bij_betw_subset source.wellformed bij_betw_inv_into_subset by fastforce

lemma iso_bij_betw_individual_blocks_inv_alt:
    "bl \<in># \<B>' \<Longrightarrow> bij_betw (inv_into \<V> \<pi>) bl ((inv_into \<V> \<pi>) ` bl)"
  using incidence_system_isomorphism.iso_bij_betw_individual_blocks inverse_incidence_sys_iso
  by blast

lemma iso_inv_block_in_alt:  "(\<pi> ` bl) \<in># \<B>' \<Longrightarrow> bl \<subseteq> \<V> \<Longrightarrow> bl \<in># \<B>"
  using image_eqI image_inv_into_cancel inv_iso_block_img iso_points_inv_map
  by (metis (no_types, lifting) iso_points_map multiset.set_map subset_image_iff)

lemma iso_img_block_not_in:
  assumes "x \<notin># \<B>"
  assumes "x \<subseteq> \<V>"
  shows "(\<pi> ` x) \<notin># \<B>'"
proof (rule ccontr)
  assume a: "\<not> \<pi> ` x \<notin># \<B>'"
  then have a: "\<pi> ` x \<in># \<B>'" by simp
  then have "\<And> y . y \<in> (\<pi> ` x) \<Longrightarrow> (inv_into \<V> \<pi>) y \<in> \<V>"
    using target.wf_invalid_point iso_points_inv_map by auto
  then have "((`) (inv_into \<V> \<pi>)) (\<pi> ` x) \<in># \<B>"
    using iso_bij_betwn_block_sets_inv by (meson a bij_betw_apply)
  thus False
    using a assms(1) assms(2) iso_inv_block_in_alt by blast
qed

lemma iso_block_multiplicity:
  assumes  "bl \<subseteq> \<V>"
  shows "source.multiplicity bl = target.multiplicity (\<pi> ` bl)"
proof (cases "bl \<in># \<B>")
  case True
  have "inj_on ((`) \<pi>) (set_mset \<B>)"
    using bij_betw_imp_inj_on iso_bij_betwn_block_sets by auto
  then have "count \<B> bl = count \<B>' (\<pi> ` bl)"
    using count_image_mset_le_count_inj_on count_image_mset_ge_count True block_img inv_into_f_f
      less_le_not_le order.not_eq_order_implies_strict by metis
  thus ?thesis by simp
next
  case False
  have s_mult: "source.multiplicity bl = 0"
    by (simp add: False count_eq_zero_iff)
  then have "target.multiplicity (\<pi> ` bl) = 0"
    using False count_inI iso_inv_block_in_alt
    by (metis assms)
  thus ?thesis
    using s_mult by simp
qed

lemma iso_point_in_block_img_iff: "p \<in> \<V> \<Longrightarrow> bl \<in># \<B> \<Longrightarrow> p \<in> bl \<longleftrightarrow> (\<pi> p) \<in> (\<pi> ` bl)"
  by (metis bij bij_betw_imp_surj_on iso_bij_betw_individual_blocks_inv bij_betw_inv_into_left imageI)

lemma iso_point_subset_block_iff: "p \<subseteq> \<V> \<Longrightarrow> bl \<in># \<B> \<Longrightarrow> p \<subseteq> bl \<longleftrightarrow> (\<pi> ` p) \<subseteq> (\<pi> ` bl)"
  apply auto
  using image_subset_iff iso_point_in_block_img_iff subset_iff by metis

lemma iso_is_image_block: "\<B>' = blocks_image \<B> \<pi>"
  unfolding blocks_image_def by (simp add: block_img iso_points_map)

end

subsection \<open>Design Isomorphisms \<close>
text \<open> Apply the concept of isomorphisms to designs only \<close>

locale design_isomorphism = incidence_system_isomorphism \<V> \<B> \<V>' \<B>' \<pi> + source: design \<V> \<B> +
  target: design \<V>' \<B>' for \<V> and \<B> and \<V>' and \<B>' and bij_map ("\<pi>")

context design_isomorphism
begin

lemma inverse_design_isomorphism: "design_isomorphism \<V>' \<B>' \<V> \<B> (inv_into \<V> \<pi>)"
  using inverse_incidence_sys_iso source.wf_design target.wf_design
  by (simp add: design_isomorphism.intro)

end

subsubsection \<open>Isomorphism Operation \<close>
text \<open> Define the concept of isomorphic designs outside the scope of locale \<close>

definition isomorphic_designs (infixl "\<cong>\<^sub>D" 50) where
"\<D> \<cong>\<^sub>D \<D>' \<longleftrightarrow> (\<exists> \<pi> . design_isomorphism (fst \<D>) (snd \<D>) (fst \<D>') (snd \<D>') \<pi>)"

lemma isomorphic_designs_symmetric: "(\<V>, \<B>) \<cong>\<^sub>D (\<V>', \<B>') \<Longrightarrow> (\<V>', \<B>') \<cong>\<^sub>D (\<V>, \<B>)"
  using isomorphic_designs_def design_isomorphism.inverse_design_isomorphism
  by metis

lemma isomorphic_designs_implies_bij: "(\<V>, \<B>) \<cong>\<^sub>D (\<V>', \<B>') \<Longrightarrow> \<exists> \<pi> . bij_betw \<pi> \<V> \<V>'"
  using incidence_system_isomorphism.bij isomorphic_designs_def
  by (metis design_isomorphism.axioms(1) fst_conv)

lemma isomorphic_designs_implies_block_map: "(\<V>, \<B>) \<cong>\<^sub>D (\<V>', \<B>') \<Longrightarrow> \<exists> \<pi> . image_mset ((`) \<pi>) \<B> = \<B>'"
  using incidence_system_isomorphism.block_img isomorphic_designs_def
  using design_isomorphism.axioms(1) by fastforce

context design
begin

lemma isomorphic_designsI [intro]: "design \<V>' \<B>' \<Longrightarrow> bij_betw \<pi> \<V> \<V>' \<Longrightarrow> image_mset ((`) \<pi>) \<B> = \<B>'
    \<Longrightarrow> (\<V>, \<B>) \<cong>\<^sub>D (\<V>', \<B>')"
  using design_isomorphism.intro isomorphic_designs_def wf_design image_set_system_wellformed
  by (metis bij_betw_imp_surj_on blocks_image_def fst_conv incidence_system_axioms
      incidence_system_isomorphism.intro incidence_system_isomorphism_axioms_def snd_conv)

lemma eq_designs_isomorphic:
  assumes "\<V> = \<V>'"
  assumes "\<B> = \<B>'"
  shows "(\<V>, \<B>) \<cong>\<^sub>D (\<V>', \<B>')"
proof -
  interpret d1: design \<V> \<B> using assms
    using wf_design by auto
  interpret d2: design \<V>' \<B>' using assms
    using wf_design by blast
  have "design_isomorphism \<V> \<B> \<V>' \<B>' id" using assms by (unfold_locales) simp_all
  thus ?thesis unfolding isomorphic_designs_def by auto
qed

end

context design_isomorphism
begin

subsubsection \<open>Design Properties/Operations under Isomorphism \<close>

lemma design_iso_point_rep_num_eq:
  assumes "p \<in> \<V>"
  shows "\<B> rep p = \<B>' rep (\<pi> p)"
proof -
  have "{#b \<in># \<B> . p \<in> b#} = {#b \<in># \<B> . \<pi> p \<in> \<pi> ` b#}"
    using assms filter_mset_cong iso_point_in_block_img_iff assms by force
  then have "{#b \<in># \<B>' . \<pi> p \<in> b#} = image_mset ((`) \<pi>) {#b \<in># \<B> . p \<in> b#}"
    by (simp add: image_mset_filter_swap block_img)
  thus ?thesis
    by (simp add: point_replication_number_def)
qed

lemma design_iso_rep_numbers_eq: "source.replication_numbers = target.replication_numbers"
  apply (simp add: source.replication_numbers_def target.replication_numbers_def)
  using  design_iso_point_rep_num_eq design_isomorphism.design_iso_point_rep_num_eq iso_points_map
  by (metis (no_types, hide_lams) imageI inverse_design_isomorphism iso_points_inv_map)

lemma design_iso_block_size_eq: "bl \<in># \<B> \<Longrightarrow> card bl = card (\<pi> ` bl)"
  using card_image_le finite_subset_image image_inv_into_cancel
  by (metis iso_points_inv_map iso_points_map le_antisym source.finite_blocks source.wellformed)

lemma design_iso_block_sizes_eq: "source.sys_block_sizes = target.sys_block_sizes"
  apply (simp add: source.sys_block_sizes_def target.sys_block_sizes_def)
  by (metis (no_types, hide_lams) design_iso_block_size_eq iso_block_in iso_img_block_orig_exists)

lemma design_iso_points_index_eq:
  assumes "ps \<subseteq> \<V>"
  shows "\<B> index ps = \<B>' index (\<pi> ` ps)"
proof -
  have "\<And> b . b \<in># \<B> \<Longrightarrow> ((ps \<subseteq> b) = ((\<pi> ` ps) \<subseteq> \<pi> ` b))"
    using iso_point_subset_block_iff assms by blast
  then have "{#b \<in># \<B> . ps \<subseteq> b#} = {#b \<in># \<B> . (\<pi> ` ps) \<subseteq> (\<pi> ` b)#}"
    using assms filter_mset_cong by force
  then have "{#b \<in># \<B>' . \<pi> ` ps \<subseteq> b#} = image_mset ((`) \<pi>) {#b \<in># \<B> . ps \<subseteq> b#}"
    by (simp add: image_mset_filter_swap block_img)
  thus ?thesis
    by (simp add: points_index_def)
qed

lemma design_iso_points_indices_imp:
  assumes "x \<in> source.point_indices t"
  shows "x \<in> target.point_indices t"
proof -
  obtain ps where t: "card ps = t" and ss: "ps \<subseteq> \<V>" and x: "\<B> index ps = x" using assms
    by (auto simp add: source.point_indices_def)
  then have x_val: "x = \<B>' index (\<pi> ` ps)" using design_iso_points_index_eq by auto
  have x_img: " (\<pi> ` ps) \<subseteq> \<V>'"
    using ss bij iso_points_map by fastforce
  then have "card (\<pi> ` ps) = t" using t ss iso_points_ss_card by auto
  then show ?thesis using target.point_indices_elem_in x_img x_val by blast
qed

lemma design_iso_points_indices_eq: "source.point_indices t = target.point_indices t"
  using inverse_design_isomorphism design_isomorphism.design_iso_points_indices_imp
    design_iso_points_indices_imp by blast

lemma design_iso_block_intersect_num_eq:
  assumes "b1 \<in># \<B>"
  assumes "b2 \<in># \<B>"
  shows "b1 |\<inter>| b2 = (\<pi> ` b1) |\<inter>| (\<pi> ` b2)"
proof -
  have split: "\<pi> ` (b1 \<inter> b2) = (\<pi> ` b1) \<inter> (\<pi> ` b2)" using assms bij bij_betw_inter_subsets
    by (metis source.wellformed)
  thus ?thesis using source.wellformed
    by (simp add: intersection_number_def iso_points_ss_card split assms(2) inf.coboundedI2)
qed

lemma design_iso_inter_numbers_imp:
  assumes "x \<in> source.intersection_numbers"
  shows "x \<in> target.intersection_numbers"
proof -
  obtain b1 b2 where 1: "b1 \<in># \<B>" and 2: "b2 \<in># (remove1_mset b1 \<B>)" and xval: "x = b1 |\<inter>| b2"
    using assms by (auto simp add: source.intersection_numbers_def)
  then have pi1: "\<pi> ` b1 \<in># \<B>'" by (simp add: iso_block_in)
  have pi2: "\<pi> ` b2 \<in># (remove1_mset (\<pi> ` b1) \<B>')" using iso_block_in 2
    by (metis (no_types, lifting) "1" block_img image_mset_remove1_mset_if in_remove1_mset_neq
        iso_blocks_map_inj more_than_one_mset_mset_diff multiset.set_map)
  have "x = (\<pi> ` b1) |\<inter>| (\<pi> ` b2)" using 1 2 design_iso_block_intersect_num_eq
    by (metis in_diffD xval)
  then have "x \<in> {b1 |\<inter>| b2 | b1 b2 . b1 \<in># \<B>' \<and> b2 \<in># (\<B>' - {#b1#})}"
    using pi1 pi2 by blast
  then show ?thesis by (simp add: target.intersection_numbers_def)
qed

lemma design_iso_intersection_numbers: "source.intersection_numbers = target.intersection_numbers"
  using inverse_design_isomorphism design_isomorphism.design_iso_inter_numbers_imp
      design_iso_inter_numbers_imp by blast

lemma design_iso_n_intersect_num:
  assumes "b1 \<in># \<B>"
  assumes "b2 \<in># \<B>"
  shows "b1 |\<inter>|\<^sub>n b2 = ((\<pi> ` b1) |\<inter>|\<^sub>n (\<pi> ` b2))"
proof -
  let ?A = "{x . x \<subseteq> b1 \<and> x \<subseteq> b2 \<and> card x = n}"
  let ?B = "{y . y \<subseteq> (\<pi> ` b1) \<and> y \<subseteq> (\<pi> ` b2) \<and> card y = n}"
  have b1v: "b1 \<subseteq> \<V>"  by (simp add: assms(1) source.wellformed)
  have b2v: "b2 \<subseteq> \<V>"  by (simp add: assms(2) source.wellformed)
  then have "\<And>x y . x \<subseteq> b1 \<Longrightarrow> x \<subseteq> b2 \<Longrightarrow> y \<subseteq> b1 \<Longrightarrow> y \<subseteq> b2 \<Longrightarrow>  \<pi> ` x = \<pi> ` y \<Longrightarrow> x = y"
    using b1v bij by (metis bij_betw_imp_surj_on bij_betw_inv_into_subset dual_order.trans)
  then have inj: "inj_on ((`) \<pi>) ?A" by (simp add: inj_on_def)
  have eqcard: "\<And>xa. xa \<subseteq> b1 \<Longrightarrow> xa \<subseteq> b2 \<Longrightarrow> card (\<pi> ` xa) = card xa" using b1v b2v bij
    using iso_points_ss_card by auto
  have surj: "\<And>x. x \<subseteq> \<pi> ` b1 \<Longrightarrow> x \<subseteq> \<pi> ` b2  \<Longrightarrow>
                x \<in> {(\<pi> ` xa) | xa . xa \<subseteq> b1 \<and> xa \<subseteq> b2 \<and> card xa = card x}"
  proof -
    fix x
    assume x1: "x \<subseteq> \<pi> ` b1" and x2: "x \<subseteq> \<pi> ` b2"
    then obtain xa where eq_x: "\<pi> ` xa = x" and ss: "xa \<subseteq> \<V>"
      by (metis b1v dual_order.trans subset_imageE)
    then have f1: "xa \<subseteq> b1" by (simp add: x1 assms(1) iso_point_subset_block_iff)
    then have f2: "xa \<subseteq> b2" by (simp add: eq_x ss assms(2) iso_point_subset_block_iff x2)
    then have f3: "card xa = card x" using bij by (simp add: eq_x ss iso_points_ss_card)
    then show "x \<in> {(\<pi> ` xa) | xa . xa \<subseteq> b1 \<and> xa \<subseteq> b2 \<and> card xa = card x}"
      using f1 f2 f3 \<open>\<pi> ` xa = x\<close> by auto
  qed
  have "bij_betw ( (`) \<pi>) ?A ?B"
  proof (auto simp add: bij_betw_def)
    show "inj_on ((`) \<pi>) {x. x \<subseteq> b1 \<and> x \<subseteq> b2 \<and> card x = n}" using inj by simp
    show "\<And>xa. xa \<subseteq> b1 \<Longrightarrow> xa \<subseteq> b2 \<Longrightarrow> n = card xa \<Longrightarrow> card (\<pi> ` xa) = card xa"
      using eqcard by simp
    show "\<And>x. x \<subseteq> \<pi> ` b1 \<Longrightarrow> x \<subseteq> \<pi> ` b2 \<Longrightarrow> n = card x \<Longrightarrow>
            x \<in> (`) \<pi> ` {xa. xa \<subseteq> b1 \<and> xa \<subseteq> b2 \<and> card xa = card x}"
      using surj by (simp add: setcompr_eq_image)
  qed
  thus ?thesis
    using bij_betw_same_card by (auto simp add: n_intersect_number_def)
qed

lemma subdesign_iso_implies:
  assumes "sub_set_system V B \<V> \<B>"
  shows "sub_set_system (\<pi> ` V) (blocks_image B \<pi>) \<V>' \<B>'"
proof (unfold_locales)
  show "\<pi> ` V \<subseteq> \<V>'"
    by (metis assms image_mono iso_points_map sub_set_system.points_subset)
  show "blocks_image B \<pi> \<subseteq># \<B>'"
    by (metis assms block_img blocks_image_def image_mset_subseteq_mono sub_set_system.blocks_subset)
qed

lemma subdesign_image_is_design:
  assumes "sub_set_system V B \<V> \<B>"
  assumes "design V B"
  shows "design (\<pi> ` V) (blocks_image B \<pi>)"
proof -
  interpret fin: finite_incidence_system "(\<pi> ` V)" "(blocks_image B \<pi>)" using assms(2)
    by (simp add: design.axioms(1) finite_incidence_system.image_set_system_finite)
  interpret des: sub_design V B \<V> \<B> using assms design.wf_design_iff
    by (unfold_locales, auto simp add: sub_set_system.points_subset sub_set_system.blocks_subset)
  have bl_img: "blocks_image B \<pi> \<subseteq># \<B>'"
    by (simp add: blocks_image_def des.blocks_subset image_mset_subseteq_mono iso_is_image_block)
  then show ?thesis
  proof (unfold_locales, auto)
    show "{} \<in># blocks_image B \<pi> \<Longrightarrow> False"
      using assms subdesign_iso_implies target.blocks_nempty bl_img by auto
  qed
qed

lemma sub_design_isomorphism:
  assumes "sub_set_system V B \<V> \<B>"
  assumes "design V B"
  shows "design_isomorphism V B (\<pi> ` V) (blocks_image B \<pi>) \<pi>"
proof -
  interpret design "(\<pi> ` V)" "(blocks_image B \<pi>)"
    by (simp add: assms(1) assms(2) subdesign_image_is_design)
  interpret des: design V B by fact
  show ?thesis
  proof (unfold_locales)
    show "bij_betw \<pi> V (\<pi> ` V)" using bij
      by (metis assms(1) bij_betw_subset sub_set_system.points_subset)
    show "image_mset ((`) \<pi>) B = blocks_image B \<pi>" by (simp add: blocks_image_def)
  qed
qed

end
end


(*  Title:      HOL/Hahn_Banach/Function_Norm.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>The norm of a function\<close>

theory Function_Norm
imports Normed_Space Function_Order
begin

subsection \<open>Continuous linear forms\<close>

text \<open>
  A linear form @{text f} on a normed vector space @{text "(V, \<parallel>\<cdot>\<parallel>)"}
  is \emph{continuous}, iff it is bounded, i.e.
  \begin{center}
  @{text "\<exists>c \<in> R. \<forall>x \<in> V. \<bar>f x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
  \end{center}
  In our application no other functions than linear forms are
  considered, so we can define continuous linear forms as bounded
  linear forms:
\<close>

locale continuous = linearform +
  fixes norm :: "_ \<Rightarrow> real"    ("\<parallel>_\<parallel>")
  assumes bounded: "\<exists>c. \<forall>x \<in> V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>"

declare continuous.intro [intro?] continuous_axioms.intro [intro?]

lemma continuousI [intro]:
  fixes norm :: "_ \<Rightarrow> real"  ("\<parallel>_\<parallel>")
  assumes "linearform V f"
  assumes r: "\<And>x. x \<in> V \<Longrightarrow> \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>"
  shows "continuous V f norm"
proof
  show "linearform V f" by fact
  from r have "\<exists>c. \<forall>x\<in>V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" by blast
  then show "continuous_axioms V f norm" ..
qed

subsection \<open>The norm of a linear form\<close>

text \<open>
  The least real number @{text c} for which holds
  \begin{center}
  @{text "\<forall>x \<in> V. \<bar>f x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
  \end{center}
  is called the \emph{norm} of @{text f}.

  For non-trivial vector spaces @{text "V \<noteq> {0}"} the norm can be
  defined as
  \begin{center}
  @{text "\<parallel>f\<parallel> = \<sup>x \<noteq> 0. \<bar>f x\<bar> / \<parallel>x\<parallel>"}
  \end{center}

  For the case @{text "V = {0}"} the supremum would be taken from an
  empty set. Since @{text \<real>} is unbounded, there would be no supremum.
  To avoid this situation it must be guaranteed that there is an
  element in this set. This element must be @{text "{} \<ge> 0"} so that
  @{text fn_norm} has the norm properties. Furthermore it does not
  have to change the norm in all other cases, so it must be @{text 0},
  as all other elements are @{text "{} \<ge> 0"}.

  Thus we define the set @{text B} where the supremum is taken from as
  follows:
  \begin{center}
  @{text "{0} \<union> {\<bar>f x\<bar> / \<parallel>x\<parallel>. x \<noteq> 0 \<and> x \<in> F}"}
  \end{center}

  @{text fn_norm} is equal to the supremum of @{text B}, if the
  supremum exists (otherwise it is undefined).
\<close>

locale fn_norm =
  fixes norm :: "_ \<Rightarrow> real"    ("\<parallel>_\<parallel>")
  fixes B defines "B V f \<equiv> {0} \<union> {\<bar>f x\<bar> / \<parallel>x\<parallel> | x. x \<noteq> 0 \<and> x \<in> V}"
  fixes fn_norm ("\<parallel>_\<parallel>\<hyphen>_" [0, 1000] 999)
  defines "\<parallel>f\<parallel>\<hyphen>V \<equiv> \<Squnion>(B V f)"

locale normed_vectorspace_with_fn_norm = normed_vectorspace + fn_norm

lemma (in fn_norm) B_not_empty [intro]: "0 \<in> B V f"
  by (simp add: B_def)

text \<open>
  The following lemma states that every continuous linear form on a
  normed space @{text "(V, \<parallel>\<cdot>\<parallel>)"} has a function norm.
\<close>

lemma (in normed_vectorspace_with_fn_norm) fn_norm_works:
  assumes "continuous V f norm"
  shows "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
proof -
  interpret continuous V f norm by fact
  txt \<open>The existence of the supremum is shown using the
    completeness of the reals. Completeness means, that every
    non-empty bounded set of reals has a supremum.\<close>
  have "\<exists>a. lub (B V f) a"
  proof (rule real_complete)
    txt \<open>First we have to show that @{text B} is non-empty:\<close>
    have "0 \<in> B V f" ..
    then show "\<exists>x. x \<in> B V f" ..

    txt \<open>Then we have to show that @{text B} is bounded:\<close>
    show "\<exists>c. \<forall>y \<in> B V f. y \<le> c"
    proof -
      txt \<open>We know that @{text f} is bounded by some value @{text c}.\<close>
      from bounded obtain c where c: "\<forall>x \<in> V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" ..

      txt \<open>To prove the thesis, we have to show that there is some
        @{text b}, such that @{text "y \<le> b"} for all @{text "y \<in>
        B"}. Due to the definition of @{text B} there are two cases.\<close>

      def b \<equiv> "max c 0"
      have "\<forall>y \<in> B V f. y \<le> b"
      proof
        fix y assume y: "y \<in> B V f"
        show "y \<le> b"
        proof cases
          assume "y = 0"
          then show ?thesis unfolding b_def by arith
        next
          txt \<open>The second case is @{text "y = \<bar>f x\<bar> / \<parallel>x\<parallel>"} for some
            @{text "x \<in> V"} with @{text "x \<noteq> 0"}.\<close>
          assume "y \<noteq> 0"
          with y obtain x where y_rep: "y = \<bar>f x\<bar> * inverse \<parallel>x\<parallel>"
              and x: "x \<in> V" and neq: "x \<noteq> 0"
            by (auto simp add: B_def divide_inverse)
          from x neq have gt: "0 < \<parallel>x\<parallel>" ..

          txt \<open>The thesis follows by a short calculation using the
            fact that @{text f} is bounded.\<close>

          note y_rep
          also have "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<le> (c * \<parallel>x\<parallel>) * inverse \<parallel>x\<parallel>"
          proof (rule mult_right_mono)
            from c x show "\<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" ..
            from gt have "0 < inverse \<parallel>x\<parallel>"
              by (rule positive_imp_inverse_positive)
            then show "0 \<le> inverse \<parallel>x\<parallel>" by (rule order_less_imp_le)
          qed
          also have "\<dots> = c * (\<parallel>x\<parallel> * inverse \<parallel>x\<parallel>)"
            by (rule Groups.mult.assoc)
          also
          from gt have "\<parallel>x\<parallel> \<noteq> 0" by simp
          then have "\<parallel>x\<parallel> * inverse \<parallel>x\<parallel> = 1" by simp
          also have "c * 1 \<le> b" by (simp add: b_def)
          finally show "y \<le> b" .
        qed
      qed
      then show ?thesis ..
    qed
  qed
  then show ?thesis unfolding fn_norm_def by (rule the_lubI_ex)
qed

lemma (in normed_vectorspace_with_fn_norm) fn_norm_ub [iff?]:
  assumes "continuous V f norm"
  assumes b: "b \<in> B V f"
  shows "b \<le> \<parallel>f\<parallel>\<hyphen>V"
proof -
  interpret continuous V f norm by fact
  have "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
    using \<open>continuous V f norm\<close> by (rule fn_norm_works)
  from this and b show ?thesis ..
qed

lemma (in normed_vectorspace_with_fn_norm) fn_norm_leastB:
  assumes "continuous V f norm"
  assumes b: "\<And>b. b \<in> B V f \<Longrightarrow> b \<le> y"
  shows "\<parallel>f\<parallel>\<hyphen>V \<le> y"
proof -
  interpret continuous V f norm by fact
  have "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
    using \<open>continuous V f norm\<close> by (rule fn_norm_works)
  from this and b show ?thesis ..
qed

text \<open>The norm of a continuous function is always @{text "\<ge> 0"}.\<close>

lemma (in normed_vectorspace_with_fn_norm) fn_norm_ge_zero [iff]:
  assumes "continuous V f norm"
  shows "0 \<le> \<parallel>f\<parallel>\<hyphen>V"
proof -
  interpret continuous V f norm by fact
  txt \<open>The function norm is defined as the supremum of @{text B}.
    So it is @{text "\<ge> 0"} if all elements in @{text B} are @{text "\<ge>
    0"}, provided the supremum exists and @{text B} is not empty.\<close>
  have "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
    using \<open>continuous V f norm\<close> by (rule fn_norm_works)
  moreover have "0 \<in> B V f" ..
  ultimately show ?thesis ..
qed

text \<open>
  \medskip The fundamental property of function norms is:
  \begin{center}
  @{text "\<bar>f x\<bar> \<le> \<parallel>f\<parallel> \<cdot> \<parallel>x\<parallel>"}
  \end{center}
\<close>

lemma (in normed_vectorspace_with_fn_norm) fn_norm_le_cong:
  assumes "continuous V f norm" "linearform V f"
  assumes x: "x \<in> V"
  shows "\<bar>f x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>"
proof -
  interpret continuous V f norm by fact
  interpret linearform V f by fact
  show ?thesis
  proof cases
    assume "x = 0"
    then have "\<bar>f x\<bar> = \<bar>f 0\<bar>" by simp
    also have "f 0 = 0" by rule unfold_locales
    also have "\<bar>\<dots>\<bar> = 0" by simp
    also have a: "0 \<le> \<parallel>f\<parallel>\<hyphen>V"
      using \<open>continuous V f norm\<close> by (rule fn_norm_ge_zero)
    from x have "0 \<le> norm x" ..
    with a have "0 \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>" by (simp add: zero_le_mult_iff)
    finally show "\<bar>f x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>" .
  next
    assume "x \<noteq> 0"
    with x have neq: "\<parallel>x\<parallel> \<noteq> 0" by simp
    then have "\<bar>f x\<bar> = (\<bar>f x\<bar> * inverse \<parallel>x\<parallel>) * \<parallel>x\<parallel>" by simp
    also have "\<dots> \<le>  \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>"
    proof (rule mult_right_mono)
      from x show "0 \<le> \<parallel>x\<parallel>" ..
      from x and neq have "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<in> B V f"
        by (auto simp add: B_def divide_inverse)
      with \<open>continuous V f norm\<close> show "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<le> \<parallel>f\<parallel>\<hyphen>V"
        by (rule fn_norm_ub)
    qed
    finally show ?thesis .
  qed
qed

text \<open>
  \medskip The function norm is the least positive real number for
  which the following inequation holds:
  \begin{center}
    @{text "\<bar>f x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
  \end{center}
\<close>

lemma (in normed_vectorspace_with_fn_norm) fn_norm_least [intro?]:
  assumes "continuous V f norm"
  assumes ineq: "\<And>x. x \<in> V \<Longrightarrow> \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" and ge: "0 \<le> c"
  shows "\<parallel>f\<parallel>\<hyphen>V \<le> c"
proof -
  interpret continuous V f norm by fact
  show ?thesis
  proof (rule fn_norm_leastB [folded B_def fn_norm_def])
    fix b assume b: "b \<in> B V f"
    show "b \<le> c"
    proof cases
      assume "b = 0"
      with ge show ?thesis by simp
    next
      assume "b \<noteq> 0"
      with b obtain x where b_rep: "b = \<bar>f x\<bar> * inverse \<parallel>x\<parallel>"
        and x_neq: "x \<noteq> 0" and x: "x \<in> V"
        by (auto simp add: B_def divide_inverse)
      note b_rep
      also have "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<le> (c * \<parallel>x\<parallel>) * inverse \<parallel>x\<parallel>"
      proof (rule mult_right_mono)
        have "0 < \<parallel>x\<parallel>" using x x_neq ..
        then show "0 \<le> inverse \<parallel>x\<parallel>" by simp
        from x show "\<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" by (rule ineq)
      qed
      also have "\<dots> = c"
      proof -
        from x_neq and x have "\<parallel>x\<parallel> \<noteq> 0" by simp
        then show ?thesis by simp
      qed
      finally show ?thesis .
    qed
  qed (insert \<open>continuous V f norm\<close>, simp_all add: continuous_def)
qed

end


theory hw02
  imports Main
begin

fun collect:: "'a \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> 'b list" where
  "collect x [] = []"
| "collect x ((k,y)#xs) = (if x = k then y # collect x xs else collect x xs)"

definition ctest :: " (int * int) list" where "ctest = [
(2 ,3 ),(2 ,5 ),(2 ,7 ),(2 ,9 ),
(3 ,2 ),(3 ,4 ),(3 ,5 ),(3 ,7 ),(3 ,8 ),
(4 ,3 ),(4 ,5 ),(4 ,7 ),(4 ,9 ),
(5 ,2 ),(5 ,3 ),(5 ,4 ),(5 ,6 ),(5 ,7 ),(5 ,8 ),(5 ,9 ),
(6 ,5 ),(6 ,7 ),
(7 ,2 ),(7 ,3 ),(7 ,4 ),(7 ,5 ),(7 ,6 ),(7 ,8 ),(7 ,9 ),
(8 ,3 ),(8 ,5 ),(8 ,7 ),(8 ,9 ),
(9 ,2 ),(9 ,4 ),(9 ,5 ),(9 ,7 ),(9 ,8 )
]"
value "collect 3 ctest = [2 ,4 ,5 ,7, 8 ]"
value "collect 1 ctest = []"

lemma "collect x ys = map snd (filter (\<lambda>kv. fst kv = x) ys)"
  apply(induction ys)
   apply(auto)
  done

fun collect_tr:: "'b list \<Rightarrow> 'a \<Rightarrow> ('a * 'b) list \<Rightarrow> 'b list" where
  "collect_tr acc x [] = rev acc"
| "collect_tr acc x ((k,v)#ys) = (if (x = k) then collect_tr (v # acc) x ys else collect_tr acc x ys)"

lemma collect_gen:"collect_tr acc x ys = rev acc @ (collect x ys)"
  apply(induction ys arbitrary:acc)
   apply(auto)
  done

lemma "collect_tr [] x ys = collect x ys"
  apply(induction ys)
   apply(auto simp:collect_gen)
  done

datatype 'a ltree = Leaf 'a | Node "'a ltree" "'a ltree"

fun lheight:: "'a ltree \<Rightarrow> nat" where
  "lheight (Leaf x) = 0"
| "lheight (Node x y) = max (lheight x) (lheight y) + 1"

value "lheight (Node (Leaf (1::nat)) (Node (Leaf 2) (Leaf 4)))"

fun num_leafs:: "'a ltree \<Rightarrow> nat" where
  "num_leafs (Leaf x) = 1"
| "num_leafs (Node x y) = num_leafs x + num_leafs y"

value "num_leafs (Node (Leaf (1::nat)) (Node (Leaf 2) (Leaf 4)))"

fun balanced:: "'a ltree \<Rightarrow> bool" where
  "balanced (Leaf a) = True"
| "balanced (Node x y) = (op &)((op &)(lheight x = lheight y)(balanced x))(balanced y)"

value "balanced (Node (Node (Leaf a\<^sub>1) (Node (Leaf a\<^sub>1) (Leaf a\<^sub>1))) (Node (Leaf a\<^sub>1) (Node (Leaf a\<^sub>1) (Leaf a\<^sub>1))))"

lemma "balanced t \<Longrightarrow> num_leafs t = 2 ^ lheight t"
  apply(induction t)
  apply(auto)
  done

fun denc :: "int \<Rightarrow> int list \<Rightarrow> int list" where
  "denc a [] = []"
| "denc a (x#xs) = (x-a) # denc x xs"

value "denc 0 [1,2,4,8]"
value "denc 0 [3,4,5]"
value "denc 0 [5]"
value "denc 0 []"

fun ddec :: "int \<Rightarrow> int list \<Rightarrow> int list" where
  "ddec a [] = []"
| "ddec (a::int) (x#xs) = (x + a) # (ddec (x + a) xs)"

value "ddec 0 [1,1,2,4]"
value "ddec 0 [3,1,1]"
value "ddec 0 [5]"
value "ddec 0 []"

value "ddec 5 (denc 4 [1,2,3])"

lemma encdecgen: "ddec n (denc n l) = l"
  apply(induction l arbitrary:n)
  by auto

lemma "ddec 0 (denc 0 l) = l"
  apply(auto simp:encdecgen)
  done

end


(*
  File:    Pi_pmf.thy
  Authors: Manuel Eberl, Max W. Haslbeck
*)
section \<open>Indexed products of PMFs\<close>
theory Pi_pmf
  imports "HOL-Probability.Probability"
begin

text \<open>Conflicting notation from \<^theory>\<open>HOL-Analysis.Infinite_Sum\<close>\<close>
no_notation Infinite_Sum.abs_summable_on (infixr "abs'_summable'_on" 46)

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 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)

lemma Pi_pmf_cong [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>g. \<Prod>x\<in>A. pmf (f x) (g x)) = (\<lambda>g. \<Prod>x\<in>A. pmf (f' x) (g x))"
    by (intro ext prod.cong) (auto simp: assms)
  with assms show ?thesis by (simp add: Pi_pmf_def cong: if_cong)
qed

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)

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 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 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)"
proof -
  have "set_pmf (Pi_pmf A dflt (\<lambda>x. return_pmf (f x))) \<subseteq>
          PiE_dflt A dflt (set_pmf \<circ> (\<lambda>x. return_pmf (f x)))"
    by (intro set_Pi_pmf_subset' assms)
  also have "\<dots> \<subseteq> {\<lambda>x. if x \<in> A then f x else dflt}"
    by (auto simp: PiE_dflt_def)
  finally show ?thesis
    by (simp add: set_pmf_subset_singleton)
qed

lemma Pi_pmf_return_pmf' [simp]:
  assumes "finite A"
  shows   "Pi_pmf A dflt (\<lambda>_. return_pmf dflt) = return_pmf (\<lambda>_. dflt)"
  using assms by simp

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

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>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