(*  Title:      HOL/Cardinals/Cardinal_Arithmetic.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Copyright   2012

Cardinal arithmetic.
*)

section \<open>Cardinal Arithmetic\<close>

theory Cardinal_Arithmetic
  imports Cardinal_Order_Relation
begin

subsection \<open>Binary sum\<close>

lemma csum_Cnotzero2:
  "Cnotzero r2 \<Longrightarrow> Cnotzero (r1 +c r2)"
  unfolding csum_def
  by (metis Cnotzero_imp_not_empty Field_card_of Plus_eq_empty_conv card_of_card_order_on czeroE)

lemma single_cone:
  "|{x}| =o cone"
proof -
  let ?f = "\<lambda>x. ()"
  have "bij_betw ?f {x} {()}" unfolding bij_betw_def by auto
  thus ?thesis unfolding cone_def using card_of_ordIso by blast
qed

lemma cone_Cnotzero: "Cnotzero cone"
  by (simp add: cone_not_czero Card_order_cone)

lemma cone_ordLeq_ctwo: "cone \<le>o ctwo"
  unfolding cone_def ctwo_def card_of_ordLeq[symmetric] by auto

lemma csum_czero1: "Card_order r \<Longrightarrow> r +c czero =o r"
  unfolding czero_def csum_def Field_card_of
  by (rule ordIso_transitive[OF ordIso_symmetric[OF card_of_Plus_empty1] card_of_Field_ordIso])

lemma csum_czero2: "Card_order r \<Longrightarrow> czero +c r =o r"
  unfolding czero_def csum_def Field_card_of
  by (rule ordIso_transitive[OF ordIso_symmetric[OF card_of_Plus_empty2] card_of_Field_ordIso])

subsection \<open>Product\<close>

lemma Times_cprod: "|A \<times> B| =o |A| *c |B|"
  by (simp only: cprod_def Field_card_of card_of_refl)

lemma card_of_Times_singleton:
  fixes A :: "'a set"
  shows "|A \<times> {x}| =o |A|"
proof -
  define f :: "'a \<times> 'b \<Rightarrow> 'a" where "f = (\<lambda>(a, b). a)"
  have "A \<subseteq> f ` (A \<times> {x})" unfolding f_def by (auto simp: image_iff)
  hence "bij_betw f (A \<times> {x}) A"  unfolding bij_betw_def inj_on_def f_def by fastforce
  thus ?thesis using card_of_ordIso by blast
qed

lemma cprod_assoc: "(r *c s) *c t =o r *c s *c t"
  unfolding cprod_def Field_card_of by (rule card_of_Times_assoc)

lemma cprod_czero: "r *c czero =o czero"
  unfolding cprod_def czero_def Field_card_of by (simp add: card_of_empty_ordIso)

lemma cprod_cone: "Card_order r \<Longrightarrow> r *c cone =o r"
  unfolding cprod_def cone_def Field_card_of
  by (metis (no_types) card_of_Field_ordIso card_of_Times_singleton ordIso_transitive)

lemma ordLeq_cprod1: "\<lbrakk>Card_order p1; Cnotzero p2\<rbrakk> \<Longrightarrow> p1 \<le>o p1 *c p2"
  unfolding cprod_def by (metis Card_order_Times1 czeroI)

subsection \<open>Exponentiation\<close>

lemma cexp_czero: "r ^c czero =o cone"
  unfolding cexp_def czero_def Field_card_of Func_empty by (rule single_cone)

lemma Pow_cexp_ctwo:
  "|Pow A| =o ctwo ^c |A|"
  by (simp add: card_of_Pow_Func cexp_def ctwo_def)

lemma Cnotzero_cexp:
  assumes "Cnotzero q"
  shows "Cnotzero (q ^c r)"
proof -
  have "Field q \<noteq> {}"
    by (metis Card_order_iff_ordIso_card_of assms(1) czero_def)
  then show ?thesis
    by (simp add: card_of_ordIso_czero_iff_empty cexp_def)
qed

lemma Cinfinite_ctwo_cexp:
  "Cinfinite r \<Longrightarrow> Cinfinite (ctwo ^c r)"
  unfolding ctwo_def cexp_def cinfinite_def Field_card_of
  by (rule conjI, rule infinite_Func, auto)

lemma cone_ordLeq_iff_Field:
  assumes "cone \<le>o r"
  shows "Field r \<noteq> {}"
  by (metis assms card_of_empty3 card_of_mono2 cone_Cnotzero czeroI)

lemma cone_ordLeq_cexp: "cone \<le>o r1 \<Longrightarrow> cone \<le>o r1 ^c r2"
  by (simp add: cexp_def cone_def Func_non_emp cone_ordLeq_iff_Field)

lemma Card_order_czero: "Card_order czero"
  by (simp only: card_of_Card_order czero_def)

lemma cexp_mono2'':
  assumes 2: "p2 \<le>o r2"
    and n1: "Cnotzero q"
    and n2: "Card_order p2"
  shows "q ^c p2 \<le>o q ^c r2"
proof (cases "p2 =o (czero :: 'a rel)")
  case True
  hence "q ^c p2 =o q ^c (czero :: 'a rel)" using n1 n2 cexp_cong2 Card_order_czero by blast
  also have "q ^c (czero :: 'a rel) =o cone" using cexp_czero by blast
  also have "cone \<le>o q ^c r2" using cone_ordLeq_cexp cone_ordLeq_Cnotzero n1 by blast
  finally show ?thesis .
next
  case False thus ?thesis using assms cexp_mono2' czeroI by metis
qed

lemma csum_cexp: "\<lbrakk>Cinfinite r1; Cinfinite r2; Card_order q; ctwo \<le>o q\<rbrakk> \<Longrightarrow>
  q ^c r1 +c q ^c r2 \<le>o q ^c (r1 +c r2)"
  apply (rule csum_cinfinite_bound)
      apply (metis cexp_mono2' cinfinite_def finite.emptyI ordLeq_csum1)
     apply (metis cexp_mono2' cinfinite_def finite.emptyI ordLeq_csum2)
  by (simp_all add: Card_order_cexp Cinfinite_csum1 Cinfinite_cexp cinfinite_cexp)

lemma csum_cexp': "\<lbrakk>Cinfinite r; Card_order q; ctwo \<le>o q\<rbrakk> \<Longrightarrow> q +c r \<le>o q ^c r"
  apply (rule csum_cinfinite_bound)
      apply (metis Cinfinite_Cnotzero ordLeq_cexp1)
     apply (metis ordLeq_cexp2)
    apply blast+
  by (metis Cinfinite_cexp)

lemma card_of_Sigma_ordLeq_Cinfinite:
  "\<lbrakk>Cinfinite r; |I| \<le>o r; \<forall>i \<in> I. |A i| \<le>o r\<rbrakk> \<Longrightarrow> |SIGMA i : I. A i| \<le>o r"
  unfolding cinfinite_def by (blast intro: card_of_Sigma_ordLeq_infinite_Field)

lemma Cinfinite_ordLess_cexp:
  assumes r: "Cinfinite r"
  shows "r <o r ^c r"
proof -
  have "r <o ctwo ^c r" using r by (simp only: ordLess_ctwo_cexp)
  also have "ctwo ^c r \<le>o r ^c r"
    by (rule cexp_mono1[OF ctwo_ordLeq_Cinfinite]) (auto simp: r ctwo_not_czero Card_order_ctwo)
  finally show ?thesis .
qed

lemma infinite_ordLeq_cexp:
  assumes "Cinfinite r"
  shows "r \<le>o r ^c r"
  by (rule ordLess_imp_ordLeq[OF Cinfinite_ordLess_cexp[OF assms]])

lemma czero_cexp: "Cnotzero r \<Longrightarrow> czero ^c r =o czero"
  by (metis Cnotzero_imp_not_empty cexp_def czero_def card_of_empty_ordIso Field_card_of Func_is_emp)

lemma Func_singleton:
  fixes x :: 'b and A :: "'a set"
  shows "|Func A {x}| =o |{x}|"
proof (rule ordIso_symmetric)
  define f where [abs_def]: "f y a = (if y = x \<and> a \<in> A then x else undefined)" for y a
  have "Func A {x} \<subseteq> f ` {x}" unfolding f_def Func_def by (force simp: fun_eq_iff)
  hence "bij_betw f {x} (Func A {x})"
    unfolding bij_betw_def inj_on_def f_def Func_def by (auto split: if_split_asm)
  thus "|{x}| =o |Func A {x}|" using card_of_ordIso by blast
qed

lemma cone_cexp: "cone ^c r =o cone"
  unfolding cexp_def cone_def Field_card_of by (rule Func_singleton)

lemma card_of_Func_squared:
  fixes A :: "'a set"
  shows "|Func (UNIV :: bool set) A| =o |A \<times> A|"
proof (rule ordIso_symmetric)
  define f where "f = (\<lambda>(x::'a,y) b. if A = {} then undefined else if b then x else y)"
  have "Func (UNIV :: bool set) A \<subseteq> f ` (A \<times> A)" unfolding f_def Func_def
    by (auto simp: image_iff fun_eq_iff split: option.splits if_split_asm) blast
  hence "bij_betw f (A \<times> A) (Func (UNIV :: bool set) A)"
    unfolding bij_betw_def inj_on_def f_def Func_def by (auto simp: fun_eq_iff)
  thus "|A \<times> A| =o |Func (UNIV :: bool set) A|" using card_of_ordIso by blast
qed

lemma cexp_ctwo: "r ^c ctwo =o r *c r"
  unfolding cexp_def ctwo_def cprod_def Field_card_of by (rule card_of_Func_squared)

lemma card_of_Func_Plus:
  fixes A :: "'a set" and B :: "'b set" and C :: "'c set"
  shows "|Func (A <+> B) C| =o |Func A C \<times> Func B C|"
proof (rule ordIso_symmetric)
  define f where "f = (\<lambda>(g :: 'a => 'c, h::'b \<Rightarrow> 'c) ab. case ab of Inl a \<Rightarrow> g a | Inr b \<Rightarrow> h b)"
  define f' where "f' = (\<lambda>(f :: ('a + 'b) \<Rightarrow> 'c). (\<lambda>a. f (Inl a), \<lambda>b. f (Inr b)))"
  have "f ` (Func A C \<times> Func B C) \<subseteq> Func (A <+> B) C"
    unfolding Func_def f_def by (force split: sum.splits)
  moreover have "f' ` Func (A <+> B) C \<subseteq> Func A C \<times> Func B C" unfolding Func_def f'_def by force
  moreover have "\<forall>a \<in> Func A C \<times> Func B C. f' (f a) = a" unfolding f'_def f_def Func_def by auto
  moreover have "\<forall>a' \<in> Func (A <+> B) C. f (f' a') = a'" unfolding f'_def f_def Func_def
    by (auto split: sum.splits)
  ultimately have "bij_betw f (Func A C \<times> Func B C) (Func (A <+> B) C)"
    by (intro bij_betw_byWitness[of _ f' f])
  thus "|Func A C \<times> Func B C| =o |Func (A <+> B) C|" using card_of_ordIso by blast
qed

lemma cexp_csum: "r ^c (s +c t) =o r ^c s *c r ^c t"
  unfolding cexp_def cprod_def csum_def Field_card_of by (rule card_of_Func_Plus)

subsection \<open>Powerset\<close>

definition cpow where "cpow r = |Pow (Field r)|"

lemma card_order_cpow: "card_order r \<Longrightarrow> card_order (cpow r)"
  by (simp only: cpow_def Field_card_order Pow_UNIV card_of_card_order_on)

lemma cpow_greater_eq: "Card_order r \<Longrightarrow> r \<le>o cpow r"
  by (rule ordLess_imp_ordLeq) (simp only: cpow_def Card_order_Pow)

lemma Cinfinite_cpow: "Cinfinite r \<Longrightarrow> Cinfinite (cpow r)"
  unfolding cpow_def cinfinite_def by simp

lemma Card_order_cpow: "Card_order (cpow r)"
  unfolding cpow_def by (rule card_of_Card_order)

lemma cardSuc_ordLeq_cpow: "Card_order r \<Longrightarrow> cardSuc r \<le>o cpow r"
  unfolding cpow_def by (metis Card_order_Pow cardSuc_ordLess_ordLeq card_of_Card_order)

lemma cpow_cexp_ctwo: "cpow r =o ctwo ^c r"
  unfolding cpow_def ctwo_def cexp_def Field_card_of by (rule card_of_Pow_Func)

subsection \<open>Inverse image\<close>

lemma vimage_ordLeq:
  assumes "|A| \<le>o k" and "\<forall> a \<in> A. |vimage f {a}| \<le>o k" and "Cinfinite k"
  shows "|vimage f A| \<le>o k"
proof-
  have "vimage f A = (\<Union>a \<in> A. vimage f {a})" by auto
  also have "|\<Union>a \<in> A. vimage f {a}| \<le>o k"
    using UNION_Cinfinite_bound[OF assms] .
  finally show ?thesis .
qed

subsection \<open>Maximum\<close>

definition cmax where
  "cmax r s =
    (if cinfinite r \<or> cinfinite s then czero +c r +c s
     else natLeq_on (max (card (Field r)) (card (Field s))) +c czero)"

lemma cmax_com: "cmax r s =o cmax s r"
  unfolding cmax_def
  by (auto simp: max.commute intro: csum_cong2[OF csum_com] csum_cong2[OF czero_ordIso])

lemma cmax1:
  assumes "Card_order r" "Card_order s" "s \<le>o r"
  shows "cmax r s =o r"
  unfolding cmax_def
proof (split if_splits, intro conjI impI)
  assume "cinfinite r \<or> cinfinite s"
  hence Cinf: "Cinfinite r" using assms(1,3) by (metis cinfinite_mono)
  have "czero +c r +c s =o r +c s" by (rule csum_czero2[OF Card_order_csum])
  also have "r +c s =o r" by (rule csum_absorb1[OF Cinf assms(3)])
  finally show "czero +c r +c s =o r" .
next
  assume "\<not> (cinfinite r \<or> cinfinite s)"
  hence fin: "finite (Field r)" and "finite (Field s)" unfolding cinfinite_def by simp_all
  moreover
  { from assms(2) have "|Field s| =o s" by (rule card_of_Field_ordIso)
    also from assms(3) have "s \<le>o r" .
    also from assms(1) have "r =o |Field r|" by (rule ordIso_symmetric[OF card_of_Field_ordIso])
    finally have "|Field s| \<le>o |Field r|" .
  }
  ultimately have "card (Field s) \<le> card (Field r)" by (subst sym[OF finite_card_of_iff_card2])
  hence "max (card (Field r)) (card (Field s)) = card (Field r)" by (rule max_absorb1)
  hence "natLeq_on (max (card (Field r)) (card (Field s))) +c czero =
    natLeq_on (card (Field r)) +c czero" by simp
  also have "\<dots> =o natLeq_on (card (Field r))" by (rule csum_czero1[OF natLeq_on_Card_order])
  also have "natLeq_on (card (Field r)) =o |Field r|"
    by (rule ordIso_symmetric[OF finite_imp_card_of_natLeq_on[OF fin]])
  also from assms(1) have "|Field r| =o r" by (rule card_of_Field_ordIso)
  finally show "natLeq_on (max (card (Field r)) (card (Field s))) +c czero =o r" .
qed

lemma cmax2:
  assumes "Card_order r" "Card_order s" "r \<le>o s"
  shows "cmax r s =o s"
  by (metis assms cmax1 cmax_com ordIso_transitive)

context
  fixes r s
  assumes r: "Cinfinite r"
    and     s: "Cinfinite s"
begin

lemma cmax_csum: "cmax r s =o r +c s"
  by (simp add: Card_order_csum cmax_def csum_czero2 r)

lemma cmax_cprod: "cmax r s =o r *c s"
proof (cases "r \<le>o s")
  case True
  hence "cmax r s =o s" by (metis cmax2 r s)
  also have "s =o r *c s" by (metis Cinfinite_Cnotzero True cprod_infinite2' ordIso_symmetric r s)
  finally show ?thesis .
next
  case False
  hence "s \<le>o r" by (metis ordLeq_total r s card_order_on_def)
  hence "cmax r s =o r" by (metis cmax1 r s)
  also have "r =o r *c s" by (metis Cinfinite_Cnotzero \<open>s \<le>o r\<close> cprod_infinite1' ordIso_symmetric r s)
  finally show ?thesis .
qed

end

lemma Card_order_cmax:
  assumes r: "Card_order r" and s: "Card_order s"
  shows "Card_order (cmax r s)"
  unfolding cmax_def by (auto simp: Card_order_csum)

lemma ordLeq_cmax:
  assumes r: "Card_order r" and s: "Card_order s"
  shows "r \<le>o cmax r s \<and> s \<le>o cmax r s"
  by (meson card_order_on_def cmax1 cmax2 ordIso_iff_ordLeq ordLeq_total ordLeq_transitive r s)

lemmas ordLeq_cmax1 = ordLeq_cmax[THEN conjunct1] and
  ordLeq_cmax2 = ordLeq_cmax[THEN conjunct2]

lemma finite_cmax:
  assumes r: "Card_order r" and s: "Card_order s"
  shows "finite (Field (cmax r s)) \<longleftrightarrow> finite (Field r) \<and> finite (Field s)"
  by (meson card_order_on_def cmax1 cmax2 ordIso_finite_Field ordLeq_finite_Field ordLeq_total r s)

end


section \<open>Well-foundedness of Relations Defined as Predicate Functions\<close>

theory Well_founded
  imports Main
begin

locale well_founded =
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>" 70)
  assumes
    wf: "wfP (\<sqsubset>)"
begin

lemmas induct = wfP_induct_rule[OF wf]

end

subsection \<open>Unit\<close>

lemma wfP_unit: "wfP (\<lambda>() (). False)"
  by (simp add: Nitpick.case_unit_unfold wfP_eq_minimal)

interpretation well_founded "\<lambda>() (). False"
  apply unfold_locales
  by (auto intro: wfP_unit)

subsection \<open>Lexicographic product\<close>

context
  fixes
    r1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and
    r2 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
begin

definition lex_prodp :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
  "lex_prodp x y \<equiv> r1 (fst x) (fst y) \<or> fst x = fst y \<and> r2 (snd x) (snd y)"

lemma lex_prodp_lex_prod:
  shows "lex_prodp x y \<longleftrightarrow> (x, y) \<in> lex_prod { (x, y). r1 x y } { (x, y). r2 x y }"
  by (auto simp: lex_prod_def lex_prodp_def)

lemma lex_prodp_wfP:
  assumes
    "wfP r1" and
    "wfP r2"
  shows "wfP lex_prodp"
proof (rule wfPUNIVI)
  show "\<And>P. \<forall>x. (\<forall>y. lex_prodp y x \<longrightarrow> P y) \<longrightarrow> P x \<Longrightarrow> (\<And>x. P x)"
  proof -
    fix P
    assume "\<forall>x. (\<forall>y. lex_prodp y x \<longrightarrow> P y) \<longrightarrow> P x"
    hence hyps: "(\<And>y1 y2. lex_prodp (y1, y2) (x1, x2) \<Longrightarrow> P (y1, y2)) \<Longrightarrow> P (x1, x2)" for x1 x2
      by fast
    show "(\<And>x. P x)"
      apply (simp only: split_paired_all)
      apply (atomize (full))
      apply (rule allI)
      apply (rule wfP_induct_rule[OF assms(1), of "\<lambda>y. \<forall>b. P (y, b)"])
      apply (rule allI)
      apply (rule wfP_induct_rule[OF assms(2), of "\<lambda>b. P (x, b)" for x])
      using hyps[unfolded lex_prodp_def, simplified]
      by blast
  qed
qed

end

lemma lex_prodp_well_founded:
  assumes
    "well_founded r1" and
    "well_founded r2"
  shows "well_founded (lex_prodp r1 r2)"
  using well_founded.intro lex_prodp_wfP assms[THEN well_founded.wf] by auto

subsection \<open>Lexicographic list\<close>

context
  fixes order :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

inductive lexp :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  lexp_head: "order x y \<Longrightarrow> length xs = length ys \<Longrightarrow> lexp (x # xs) (y # ys)" |
  lexp_tail: "lexp xs ys \<Longrightarrow> lexp (x # xs) (x # ys)"

end

lemma lexp_prepend: "lexp order ys zs \<Longrightarrow> lexp order (xs @ ys) (xs @ zs)"
  by (induction xs) (simp_all add: lexp_tail)

lemma lexp_lex: "lexp order xs ys \<longleftrightarrow> (xs, ys) \<in> lex {(x, y). order x y}"
proof
  assume "lexp order xs ys"
  thus "(xs, ys) \<in> lex {(x, y). order x y}"
    by (induction xs ys rule: lexp.induct) simp_all
next
  assume "(xs, ys) \<in> lex {(x, y). order x y}"
  thus "lexp order xs ys"
    by (auto intro!: lexp_prepend intro: lexp_head simp: lex_conv)
qed

lemma lex_list_wfP: "wfP order \<Longrightarrow> wfP (lexp order)"
  by (simp add: lexp_lex wf_lex wfP_def)

lemma lex_list_well_founded:
  assumes "well_founded order"
  shows "well_founded (lexp order)"
  using well_founded.intro assms(1)[THEN well_founded.wf, THEN lex_list_wfP] by auto

end


theory Llength_lmap
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec lmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Llist \<Rightarrow> 'b Llist" where
 "lmap f xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons (f x) (lmap f xs))"

codatatype ENat = is_zero: EZ | ESuc (epred: ENat)

primcorec llength :: "'a Llist \<Rightarrow> ENat" where
"llength xs = (if lnull xs then EZ else ESuc (llength (ltl xs)))"

(*hipster llength lmap*)
lemma lemma_a [thy_expl]: "llength (LCons y z) = ESuc (llength z)"
  apply (coinduction  arbitrary: y z rule: Llength_lmap.ENat.coinduct_strong)
  by simp

lemma lemma_aa [thy_expl]: "lmap y (LCons z LNil) = LCons (y z) LNil"
apply (coinduction  arbitrary: y z rule: Llength_lmap.Llist.coinduct_strong)
by simp

lemma lemma_ab [thy_expl]: "LCons (y z) (lmap y x2) = lmap y (LCons z x2)"
apply (coinduction  arbitrary: x2 y z rule: Llength_lmap.Llist.coinduct_strong)
by simp

lemma lemma_ac [thy_expl]: "llength (lmap y z) = llength z"
apply (coinduction  arbitrary: y z rule: Llength_lmap.ENat.coinduct_strong)
apply simp
by (metis Llist.case_eq_if)

lemma lemma_ad [thy_expl]: "ltl (lmap y z) = lmap y (ltl z)"
apply (coinduction  arbitrary: y z rule: Llength_lmap.Llist.coinduct_strong)
apply simp
by (smt ENat.distinct(1) Llength_lmap.lemma_ab Llength_lmap.lemma_ac Llist.collapse(2) Llist.sel(1) Llist.sel(2) Llist.simps(5) llength.code lnull_def ltl_def)

theorem llength_lmap: "llength (lmap f xs) = llength xs"
  by (simp add: lemma_ac)
(*by hipster_coinduct_sledgehammer fails
Metis: Failed to replay Metis proof
resynchronize: Out of sync
Failed to apply initial proof method *)
 (* apply(coinduction arbitrary: f xs rule: Llist.coinduct_strong)
    sledgehammer times out *)

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.*)
  theory TIP_prop_37
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
"x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun elem :: "Nat => Nat list => bool" where
"elem y (nil2) = False"
| "elem y (cons2 z2 xs) = (if x y z2 then True else elem y xs)"

fun delete :: "Nat => Nat list => Nat list" where
"delete y (nil2) = nil2"
| "delete y (cons2 z2 xs) =
     (if x y z2 then delete y xs else cons2 z2 (delete y xs))"

theorem property0 :
  "(~ (elem y (delete y xs)))"
  oops

end


(*  Title:      HOL/Nitpick_Examples/Induct_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick applied to (co)inductive definitions.
*)

section \<open>Examples Featuring Nitpick Applied to (Co)inductive Definitions\<close>

theory Induct_Nits
imports Main
begin

nitpick_params [verbose, card = 1-8, unary_ints,
                sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]

inductive p1 :: "nat \<Rightarrow> bool" where
"p1 0" |
"p1 n \<Longrightarrow> p1 (n + 2)"

coinductive q1 :: "nat \<Rightarrow> bool" where
"q1 0" |
"q1 n \<Longrightarrow> q1 (n + 2)"

lemma "p1 = q1"
nitpick [expect = none]
nitpick [wf, expect = none]
nitpick [non_wf, expect = none]
nitpick [non_wf, dont_star_linear_preds, expect = none]
oops

lemma "p1 \<noteq> q1"
nitpick [expect = potential]
nitpick [wf, expect = potential]
nitpick [non_wf, expect = potential]
nitpick [non_wf, dont_star_linear_preds, expect = potential]
oops

lemma "p1 (n - 2) \<Longrightarrow> p1 n"
nitpick [expect = genuine]
nitpick [non_wf, expect = genuine]
nitpick [non_wf, dont_star_linear_preds, expect = genuine]
oops

lemma "q1 (n - 2) \<Longrightarrow> q1 n"
nitpick [expect = genuine]
nitpick [non_wf, expect = genuine]
nitpick [non_wf, dont_star_linear_preds, expect = genuine]
oops

inductive p2 :: "nat \<Rightarrow> bool" where
"p2 n \<Longrightarrow> p2 n"

coinductive q2 :: "nat \<Rightarrow> bool" where
"q2 n \<Longrightarrow> q2 n"

lemma "p2 = bot"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "q2 = bot"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [wf, expect = quasi_genuine]
oops

lemma "p2 = top"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
oops

lemma "q2 = top"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
nitpick [wf, expect = quasi_genuine]
sorry

lemma "p2 = q2"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
oops

lemma "p2 n"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "q2 n"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "\<not> p2 n"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "\<not> q2 n"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

inductive p3 and p4 where
"p3 0" |
"p3 n \<Longrightarrow> p4 (Suc n)" |
"p4 n \<Longrightarrow> p3 (Suc n)"

coinductive q3 and q4 where
"q3 0" |
"q3 n \<Longrightarrow> q4 (Suc n)" |
"q4 n \<Longrightarrow> q3 (Suc n)"

lemma "p3 = q3"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "p4 = q4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "p3 = top - p4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "q3 = top - q4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "inf p3 q4 \<noteq> bot"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "inf q3 p4 \<noteq> bot"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "sup p3 q4 \<noteq> top"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "sup q3 p4 \<noteq> top"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

end


(*  Title:   Bayesian_Linear_Regression.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection \<open> Bayesian Linear Regression \<close>

theory Bayesian_Linear_Regression
  imports "Measure_as_QuasiBorel_Measure"
begin

text \<open> We formalize the Bayesian linear regression presented in \cite{Heunen_2017} section VI.\<close>
subsubsection \<open> Prior \<close>
abbreviation "\<nu> \<equiv> density lborel (\<lambda>x. ennreal (normal_density 0 3 x))"

interpretation \<nu>: standard_borel_prob_space \<nu>
  by(simp add: standard_borel_prob_space_def prob_space_normal_density)

term "\<nu>.as_qbs_measure :: real qbs_prob_space"
definition prior :: "(real \<Rightarrow> real) qbs_prob_space" where
 "prior \<equiv> do { s \<leftarrow> \<nu>.as_qbs_measure ;
                b \<leftarrow> \<nu>.as_qbs_measure ;
                qbs_return (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) (\<lambda>r. s * r + b)}"

lemma \<nu>_as_qbs_measure_eq:
 "\<nu>.as_qbs_measure = qbs_prob_space (\<real>\<^sub>Q,id,\<nu>)"
  by(simp add: \<nu>.as_qbs_measure_retract[of id id] distr_id' measure_to_qbs_cong_sets[OF sets_density] measure_to_qbs_cong_sets[OF sets_lborel])

interpretation \<nu>_qp: pair_qbs_prob "\<real>\<^sub>Q" id \<nu> "\<real>\<^sub>Q" id \<nu>
  by(auto intro!: qbs_probI prob_space_normal_density simp: pair_qbs_prob_def)

lemma \<nu>_as_qbs_measure_in_Pr:
 "\<nu>.as_qbs_measure \<in> monadP_qbs_Px \<real>\<^sub>Q"
  by(simp add: \<nu>_as_qbs_measure_eq \<nu>_qp.qp1.qbs_prob_space_in_Px)

lemma sets_real_real_real[measurable_cong]:
  "sets (qbs_to_measure ((\<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q)) = sets ((borel \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M borel)"
  by (metis pair_standard_borel.l_r_r_sets pair_standard_borel_def r_preserves_product real.standard_borel_axioms real_real.standard_borel_axioms)

lemma lin_morphism:
 "(\<lambda>(s, b) r. s * r + b) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q"
  apply(simp add: split_beta')
  apply(rule curry_preserves_morphisms[of "\<lambda>(x,r). fst x * r + snd x",simplified curry_def split_beta',simplified])
  by auto

lemma lin_measurable[measurable]:
 "(\<lambda>(s, b) r. s * r + b) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M qbs_to_measure (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q)"
  using lin_morphism l_preserves_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q" "exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q"]
  by auto

lemma prior_computation:
 "qbs_prob (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) ((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
 "prior = qbs_prob_space (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q, (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g, distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
  using \<nu>_qp.qbs_bind_bind_return[OF lin_morphism]
  by(simp_all add: prior_def \<nu>_as_qbs_measure_eq map_prod_def)

text \<open> The following lemma corresponds to the equation (5). \<close>
lemma prior_measure:
  "qbs_prob_measure prior = distr (\<nu> \<Otimes>\<^sub>M \<nu>) (qbs_to_measure (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)) (\<lambda>(s,b) r. s * r + b)"
  by(simp add: prior_computation(2) qbs_prob.qbs_prob_measure_computation[OF prior_computation(1)])    (simp add: distr_distr comp_def)

lemma prior_in_space:
 "prior \<in> qbs_space (monadP_qbs (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q))"
  using qbs_prob.qbs_prob_space_in_Px[OF prior_computation(1)]
  by(simp add: prior_computation(2))

subsubsection \<open> Likelihood \<close>
abbreviation "d \<mu> x \<equiv> normal_density \<mu> (1/2) x"

lemma d_positive : "0 < d \<mu> x"
  by(simp add: normal_density_pos)

definition obs :: "(real \<Rightarrow> real) \<Rightarrow> ennreal" where
"obs f \<equiv> d (f 1) 2.5 * d (f 2) 3.8 * d (f 3) 4.5 * d (f 4) 6.2 * d (f 5) 8"

lemma obs_morphism:
 "obs \<in> \<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
proof(rule qbs_morphismI)
  fix \<alpha>
  assume "\<alpha> \<in> qbs_Mx (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q)"
  then have [measurable]:"(\<lambda>(x,y). \<alpha> x y) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M real_borel"
    by(auto simp: exp_qbs_Mx_def)
  show "obs \<circ> \<alpha> \<in> qbs_Mx \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    by(auto simp: comp_def obs_def normal_density_def)
qed

lemma obs_measurable[measurable]:
 "obs \<in> qbs_to_measure (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q) \<rightarrow>\<^sub>M ennreal_borel"
  using obs_morphism by auto

subsubsection \<open> Posterior \<close>
lemma id_obs_morphism:
 "(\<lambda>f. (f,obs f)) \<in> \<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  by(rule qbs_morphism_tuple[OF qbs_morphism_ident' obs_morphism])

lemma push_forward_measure_in_space:
 "monadP_qbs_Pf (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>f. (f,obs f)) prior \<in> qbs_space (monadP_qbs ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0))"
  by(rule qbs_morphismE(2)[OF monadP_qbs_Pf_morphism[OF id_obs_morphism] prior_in_space])

lemma push_forward_measure_computation:
 "qbs_prob ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>l. (((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) l, ((obs \<circ> (\<lambda>(s, b) r. s * r + b)) \<circ> real_real.g) l)) (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
 "monadP_qbs_Pf (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>f. (f, obs f)) prior = qbs_prob_space ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0, (\<lambda>l. (((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) l, ((obs \<circ> (\<lambda>(s, b) r. s * r + b)) \<circ> real_real.g) l)), distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
  using qbs_prob.monadP_qbs_Pf_computation[OF prior_computation id_obs_morphism] by(auto simp: comp_def)

subsubsection \<open> Normalizer \<close>
text \<open> We use the unit space for an error. \<close>
definition norm_qbs_measure :: "('a \<times> ennreal) qbs_prob_space \<Rightarrow> 'a qbs_prob_space + unit" where
"norm_qbs_measure p \<equiv> (let (XR,\<alpha>\<beta>,\<nu>) = rep_qbs_prob_space p in
                          if emeasure (density \<nu> (snd \<circ> \<alpha>\<beta>)) UNIV = 0 then Inr ()
                          else if emeasure (density \<nu> (snd \<circ> \<alpha>\<beta>)) UNIV = \<infinity> then Inr ()
                          else Inl (qbs_prob_space (map_qbs fst XR, fst \<circ> \<alpha>\<beta>, density \<nu> (\<lambda>r. snd (\<alpha>\<beta> r) / emeasure (density \<nu> (snd \<circ> \<alpha>\<beta>)) UNIV))))"

lemma norm_qbs_measure_qbs_prob:
  assumes "qbs_prob (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>r. (\<alpha> r, \<beta> r)) \<mu>"
          "emeasure (density \<mu> \<beta>) UNIV \<noteq> 0"
      and "emeasure (density \<mu> \<beta>) UNIV \<noteq> \<infinity>"
    shows "qbs_prob X \<alpha> (density \<mu> (\<lambda>r. (\<beta> r) / emeasure (density \<mu> \<beta>) UNIV))"
proof -
  interpret qp: qbs_prob "X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0" "\<lambda>r. (\<alpha> r, \<beta> r)" \<mu>
    by fact
  have ha[simp]: "\<alpha> \<in> qbs_Mx X"
   and hb[measurable] :"\<beta> \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
    using assms by(simp_all add: qbs_prob_def in_Mx_def pair_qbs_Mx_def comp_def)
  show ?thesis
  proof(rule qbs_probI)
    show "prob_space (density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV))"
    proof(rule prob_spaceI)
      show "emeasure (density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV)) (space (density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV))) = 1"
             (is "?lhs = ?rhs")
      proof -
        have "?lhs = emeasure (density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV)) UNIV"
          by simp
        also have "... = (\<integral>\<^sup>+r\<in>UNIV. (\<beta> r / emeasure (density \<mu> \<beta>) UNIV) \<partial>\<mu>)"
          by(intro emeasure_density) auto
        also have "... =  integral\<^sup>N \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV)"
          by simp
        also have "... = (integral\<^sup>N \<mu> \<beta>) / emeasure (density \<mu> \<beta>) UNIV"
          by(simp add: nn_integral_divide)
        also have "... = (\<integral>\<^sup>+r\<in>UNIV. \<beta> r \<partial>\<mu>) / emeasure (density \<mu> \<beta>) UNIV"
          by(simp add: emeasure_density)
        also have "... = 1"
          using assms(2,3) by(simp add: emeasure_density divide_eq_1_ennreal)
        finally show ?thesis .
      qed
    qed
  qed simp_all
qed

lemma norm_qbs_measure_computation:
  assumes "qbs_prob (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>r. (\<alpha> r, \<beta> r)) \<mu>"
  shows "norm_qbs_measure (qbs_prob_space (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0, (\<lambda>r. (\<alpha> r, \<beta> r)), \<mu>)) = (if emeasure (density \<mu> \<beta>) UNIV = 0 then Inr ()
                                                                                else if emeasure (density \<mu> \<beta>) UNIV = \<infinity> then Inr ()
                                                                                else Inl (qbs_prob_space (X, \<alpha>, density \<mu> (\<lambda>r. (\<beta> r) / emeasure (density \<mu> \<beta>) UNIV))))"
proof -
  interpret qp: qbs_prob "X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0" "\<lambda>r. (\<alpha> r, \<beta> r)" \<mu>
    by fact
  have ha: "\<alpha> \<in> qbs_Mx X"
   and hb[measurable] :"\<beta> \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
    using assms by(simp_all add: qbs_prob_def in_Mx_def pair_qbs_Mx_def comp_def)
  show ?thesis
    unfolding norm_qbs_measure_def
  proof(rule qp.in_Rep_induct)
    fix XR \<alpha>\<beta>' \<mu>'
    assume "(XR,\<alpha>\<beta>',\<mu>') \<in> Rep_qbs_prob_space (qbs_prob_space (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0, \<lambda>r. (\<alpha> r, \<beta> r), \<mu>))"
    from qp.if_in_Rep[OF this]
    have h:"XR = X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
           "qbs_prob XR \<alpha>\<beta>' \<mu>'"
           "qbs_prob_eq (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0, \<lambda>r. (\<alpha> r, \<beta> r), \<mu>) (XR, \<alpha>\<beta>', \<mu>')"
      by auto
    have hint: "\<And>f. f \<in> X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0 \<Longrightarrow> (\<integral>\<^sup>+ x. f (\<alpha> x, \<beta> x) \<partial>\<mu>) = (\<integral>\<^sup>+ x. f (\<alpha>\<beta>' x) \<partial>\<mu>')"
      using h(3)[simplified qbs_prob_eq_equiv14] by(simp add: qbs_prob_eq4_def)
    interpret qp': qbs_prob XR \<alpha>\<beta>' \<mu>'
      by fact
    have ha': "fst \<circ> \<alpha>\<beta>' \<in> qbs_Mx X" "(\<lambda>x. fst (\<alpha>\<beta>' x)) \<in> qbs_Mx X"
     and hb'[measurable]: "snd \<circ> \<alpha>\<beta>' \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel" "(\<lambda>x. snd (\<alpha>\<beta>' x)) \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel" "(\<lambda>x. fst (\<alpha>\<beta>' x)) \<in> real_borel \<rightarrow>\<^sub>M qbs_to_measure X"
      using h by(simp_all add: qbs_prob_def in_Mx_def pair_qbs_Mx_def comp_def)
    have fstX: "map_qbs fst XR = X"
      by(simp add: h(1) pair_qbs_fst)
    have he:"emeasure (density \<mu> \<beta>) UNIV = emeasure (density \<mu>' (snd \<circ> \<alpha>\<beta>')) UNIV"
      using hint[OF snd_qbs_morphism] by(simp add: emeasure_density)

    show "(let a = (XR,\<alpha>\<beta>',\<mu>') in case a of (XR, \<alpha>\<beta>, \<nu>') \<Rightarrow> if emeasure (density \<nu>' (snd \<circ> \<alpha>\<beta>)) UNIV = 0 then Inr ()
                                                else if emeasure (density \<nu>' (snd \<circ> \<alpha>\<beta>)) UNIV = \<infinity> then Inr ()
                                                else Inl (qbs_prob_space (map_qbs fst XR, fst \<circ> \<alpha>\<beta>, density \<nu>' (\<lambda>r. snd (\<alpha>\<beta> r) / emeasure (density \<nu>' (snd \<circ> \<alpha>\<beta>)) UNIV))))
         = (if emeasure (density \<mu> \<beta>) UNIV = 0 then Inr ()
            else if emeasure (density \<mu> \<beta>) UNIV = \<infinity> then Inr ()
            else Inl (qbs_prob_space (X, \<alpha>, density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV))))"
    proof(auto simp: he[symmetric] fstX)
      assume het0:"emeasure (density \<mu> \<beta>) UNIV \<noteq> \<top>"
                  "emeasure (density \<mu> \<beta>) UNIV \<noteq> 0"
      interpret pqp: pair_qbs_prob X "fst \<circ> \<alpha>\<beta>'" "density \<mu>' (\<lambda>r. snd (\<alpha>\<beta>' r) / emeasure (density \<mu> \<beta>) UNIV)" X \<alpha> "density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV)"
        apply(auto intro!: norm_qbs_measure_qbs_prob  simp: pair_qbs_prob_def assms het0)
        using het0
        by(auto intro!: norm_qbs_measure_qbs_prob[of X "fst \<circ> \<alpha>\<beta>'" "snd \<circ> \<alpha>\<beta>'",simplified,OF h(2)[simplified h(1)]] simp: he)

      show "qbs_prob_space (X, fst \<circ> \<alpha>\<beta>', density \<mu>' (\<lambda>r. snd (\<alpha>\<beta>' r) / emeasure (density \<mu> \<beta>) UNIV)) = qbs_prob_space (X, \<alpha>, density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV))"
      proof(rule pqp.qbs_prob_space_eq4)
        fix f
        assume hf[measurable]:"f \<in> qbs_to_measure X \<rightarrow>\<^sub>M ennreal_borel"
        show "(\<integral>\<^sup>+ x. f ((fst \<circ> \<alpha>\<beta>') x) \<partial>density \<mu>' (\<lambda>r. snd (\<alpha>\<beta>' r) / emeasure (density \<mu> \<beta>) UNIV)) = (\<integral>\<^sup>+ x. f (\<alpha> x) \<partial>density \<mu> (\<lambda>r. \<beta> r / emeasure (density \<mu> \<beta>) UNIV))"
             (is "?lhs = ?rhs")
        proof -
          have "?lhs =  (\<integral>\<^sup>+ x. (\<lambda>xr. (snd xr) / emeasure (density \<mu> \<beta>) UNIV * f (fst xr)) (\<alpha>\<beta>' x) \<partial>\<mu>')"
            by(auto simp: nn_integral_density)
          also have "... = (\<integral>\<^sup>+ x. (\<lambda>xr. (snd xr) / emeasure (density \<mu> \<beta>) UNIV * f (fst xr)) (\<alpha> x,\<beta> x) \<partial>\<mu>)"
            by(intro hint[symmetric]) (auto intro!: pair_qbs_morphismI)
          also have "... = ?rhs"
            by(simp add: nn_integral_density)
          finally show ?thesis .
        qed
      qed simp
    qed
  qed
qed

lemma norm_qbs_measure_morphism:
 "norm_qbs_measure \<in> monadP_qbs (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) \<rightarrow>\<^sub>Q monadP_qbs X <+>\<^sub>Q 1\<^sub>Q"
proof(rule qbs_morphismI)
  fix \<gamma>
  assume "\<gamma> \<in> qbs_Mx (monadP_qbs (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0))"
  then obtain \<alpha> g where hc:
   "\<alpha> \<in> qbs_Mx (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0)" "g \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
      "\<gamma> = (\<lambda>r. qbs_prob_space (X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0, \<alpha>, g r))"
    using rep_monadP_qbs_MPx[of "\<gamma>" "(X \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0)"] by auto
  note [measurable] = hc(2) measurable_prob_algebraD[OF hc(2)]
  have setsg[measurable_cong]:"\<And>r. sets (g r) = sets real_borel"
    using measurable_space[OF hc(2)] by(simp add: space_prob_algebra)
  then have ha: "fst \<circ> \<alpha> \<in> qbs_Mx X"
   and hb[measurable]: "snd \<circ> \<alpha> \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel" "(\<lambda>x. snd (\<alpha> x)) \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel" "\<And>r. snd \<circ> \<alpha> \<in> g r  \<rightarrow>\<^sub>M ennreal_borel" "\<And>r. (\<lambda>x. snd (\<alpha> x)) \<in> g r  \<rightarrow>\<^sub>M ennreal_borel"
    using hc(1) by(auto simp add: pair_qbs_Mx_def measurable_cong_sets[OF setsg refl] comp_def)
  have emeas_den_meas[measurable]: "\<And>U. U \<in> sets real_borel \<Longrightarrow> (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) U) \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
    by(simp add: emeasure_density)
  have S_setsc:"UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0,\<infinity>} \<in> sets real_borel"
    using measurable_sets_borel[OF emeas_den_meas] by simp
  have space_non_empty:"qbs_space (monadP_qbs X) \<noteq> {}"
    using ha qbs_empty_equiv monadP_qbs_empty_iff[of X] by auto
  have g_meas:"(\<lambda>r. if r \<in> (UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0,\<infinity>}) then density (g r) (\<lambda>l. ((snd \<circ> \<alpha>) l) / emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) else return real_borel 0) \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
  proof -
    have H:"\<And>\<Omega> M N c f. \<Omega> \<inter> space M \<in> sets M \<Longrightarrow> c \<in> space N \<Longrightarrow>
             f \<in> measurable (restrict_space M \<Omega>) N \<Longrightarrow> (\<lambda>x. if x \<in> \<Omega> then f x else c) \<in> measurable M N"
      by(simp add: measurable_restrict_space_iff)
    show ?thesis
    proof(rule H)
      show "(UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0, \<infinity>}) \<inter> space real_borel \<in> sets real_borel"
        using S_setsc by simp
    next
      show "(\<lambda>r. density (g r) (\<lambda>l. ((snd \<circ> \<alpha>) l) / emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV)) \<in> restrict_space real_borel (UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0,\<infinity>}) \<rightarrow>\<^sub>M prob_algebra real_borel"
      proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G="sets real_borel"])

        fix a
        assume "a \<in> space (restrict_space real_borel (UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0, \<infinity>}))"
        then have 1:"(\<integral>\<^sup>+ x. snd (\<alpha> x) \<partial>g a) \<noteq> 0" "(\<integral>\<^sup>+ x. snd (\<alpha> x) \<partial>g a) \<noteq> \<infinity>"
          by(simp_all add: space_restrict_space emeasure_density)
        show "prob_space (density (g a) (\<lambda>l. (snd \<circ> \<alpha>) l / emeasure (density (g a) (snd \<circ> \<alpha>)) UNIV))"
          using 1
          by(auto intro!: prob_spaceI simp: emeasure_density nn_integral_divide divide_eq_1_ennreal)
      next
        fix U
        assume 1:"U \<in> sets real_borel"
        then have 2:"\<And>a. U \<in> sets (g a)" by auto
        show "(\<lambda>a. emeasure (density (g a) (\<lambda>l. (snd \<circ> \<alpha>) l / emeasure (density (g a) (snd \<circ> \<alpha>)) UNIV)) U) \<in> (restrict_space real_borel (UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0, \<infinity>})) \<rightarrow>\<^sub>M ennreal_borel"
          using 1
          by(auto intro!: measurable_restrict_space1 nn_integral_measurable_subprob_algebra2[where N=real_borel] simp: emeasure_density emeasure_density[OF _ 2])
      qed (simp_all add: setsg sets.Int_stable sets.sigma_sets_eq[of real_borel,simplified])
    qed (simp add:space_prob_algebra prob_space_return)
  qed

  show "norm_qbs_measure \<circ> \<gamma> \<in> qbs_Mx (monadP_qbs X <+>\<^sub>Q unit_quasi_borel)"
    apply(auto intro!: bexI[OF _ S_setsc] bexI[where x="(\<lambda>r. ())"] bexI[where x="\<lambda>r. qbs_prob_space (X,fst \<circ> \<alpha>,if r \<in> (UNIV - (\<lambda>r. emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) -` {0,\<infinity>}) then density (g r) (\<lambda>l. ((snd \<circ> \<alpha>) l) / emeasure (density (g r) (snd \<circ> \<alpha>)) UNIV) else return real_borel 0)"]
                 simp: copair_qbs_Mx_equiv copair_qbs_Mx2_def space_non_empty[simplified])
     apply standard
     apply(simp add: hc(3) norm_qbs_measure_computation[of _ "fst \<circ> \<alpha>" "snd \<circ> \<alpha>",simplified,OF qbs_prob_MPx[OF hc(1,2)]])
    apply(simp add: monadP_qbs_MPx_def in_MPx_def)
    apply(auto intro!: bexI[OF _ ha] bexI[OF _ g_meas])
    done
qed

text \<open> The following is the semantics of the entire program. \<close>
definition program :: "(real \<Rightarrow> real) qbs_prob_space + unit" where
 "program \<equiv> norm_qbs_measure (monadP_qbs_Pf (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) ((\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) \<Otimes>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0) (\<lambda>f. (f,obs f)) prior)"

lemma program_in_space:
 "program \<in> qbs_space (monadP_qbs (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) <+>\<^sub>Q 1\<^sub>Q)"
  unfolding program_def
  by(rule qbs_morphismE(2)[OF norm_qbs_measure_morphism push_forward_measure_in_space])

text \<open> We calculate the normalizing constant. \<close>
lemma complete_the_square:
  fixes a b c x :: real
  assumes "a \<noteq> 0"
  shows "a*x\<^sup>2 + b * x + c = a * (x + (b / (2*a)))\<^sup>2 - ((b\<^sup>2 - 4* a * c)/(4*a))"
  using assms by(simp add: comm_semiring_1_class.power2_sum power2_eq_square[of "b / (2 * a)"] ring_class.ring_distribs(1) division_ring_class.diff_divide_distrib power2_eq_square[of b])

lemma complete_the_square2':
  fixes a b c x :: real
  assumes "a \<noteq> 0"
  shows "a*x\<^sup>2 - 2 * b * x + c = a * (x - (b / a))\<^sup>2 - ((b\<^sup>2 - a*c)/a)"
  using complete_the_square[OF assms,where b="-2 * b" and x=x and c=c]
  by(simp add: division_ring_class.diff_divide_distrib assms)

lemma normal_density_mu_x_swap:
   "normal_density \<mu> \<sigma> x = normal_density x \<sigma> \<mu>"
  by(simp add: normal_density_def power2_commute)

lemma normal_density_plus_shift:
 "normal_density \<mu> \<sigma> (x + y) = normal_density (\<mu> - x) \<sigma> y"
  by(simp add: normal_density_def add.commute diff_diff_eq2)

lemma normal_density_times:
  assumes "\<sigma> > 0" "\<sigma>' > 0"
  shows "normal_density \<mu> \<sigma> x * normal_density \<mu>' \<sigma>' x = (1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) * exp (- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) * normal_density ((\<mu>*\<sigma>'\<^sup>2 + \<mu>'*\<sigma>\<^sup>2)/(\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) x"
        (is "?lhs = ?rhs")
proof -
  have non0: "2*\<sigma>\<^sup>2 \<noteq> 0" "2*\<sigma>'\<^sup>2 \<noteq> 0" "\<sigma>\<^sup>2 + \<sigma>'\<^sup>2 \<noteq> 0"
    using assms by auto
  have "?lhs = exp (- ((x - \<mu>)\<^sup>2 / (2 * \<sigma>\<^sup>2))) * exp (- ((x - \<mu>')\<^sup>2 / (2 * \<sigma>'\<^sup>2))) / (sqrt (2 * pi * \<sigma>\<^sup>2) * sqrt (2 * pi * \<sigma>'\<^sup>2)) "
    by(simp add: normal_density_def)
  also have "... = exp (- ((x - \<mu>)\<^sup>2 / (2 * \<sigma>\<^sup>2)) - ((x - \<mu>')\<^sup>2 / (2 * \<sigma>'\<^sup>2))) / (sqrt (2 * pi * \<sigma>\<^sup>2) * sqrt (2 * pi * \<sigma>'\<^sup>2))"
    by(simp add: exp_add[of "- ((x - \<mu>)\<^sup>2 / (2 * \<sigma>\<^sup>2))" "- ((x - \<mu>')\<^sup>2 / (2 * \<sigma>'\<^sup>2))",simplified add_uminus_conv_diff])
  also have "... = exp (- (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) - (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)))  / (sqrt (2 * pi * \<sigma>\<^sup>2) * sqrt (2 * pi * \<sigma>'\<^sup>2))"
  proof -
    have "((x - \<mu>)\<^sup>2 / (2 * \<sigma>\<^sup>2)) + ((x - \<mu>')\<^sup>2 / (2 * \<sigma>'\<^sup>2)) = (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) + (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))"
         (is "?lhs' = ?rhs'")
    proof -
      have "?lhs' = (2 * ((x - \<mu>)\<^sup>2 * \<sigma>'\<^sup>2) + 2 * ((x - \<mu>')\<^sup>2 * \<sigma>\<^sup>2)) / (4 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
        by(simp add: field_class.add_frac_eq[OF non0(1,2)])
      also have "... = ((x - \<mu>)\<^sup>2 * \<sigma>'\<^sup>2 + (x - \<mu>')\<^sup>2 * \<sigma>\<^sup>2) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
        by(simp add: power2_eq_square division_ring_class.add_divide_distrib)
      also have "... = ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * x\<^sup>2 - 2 * (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) * x  + (\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2)) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
        by(simp add: comm_ring_1_class.power2_diff ring_class.left_diff_distrib semiring_class.distrib_right)
       also have "... = ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 - ((\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2)\<^sup>2 - (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2)) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
        by(simp only: complete_the_square2'[OF non0(3),of x "(\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2)" "(\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2)"])
      also have "... = ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2)) - (((\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2)\<^sup>2 - (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2)) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
        by(simp add: division_ring_class.diff_divide_distrib)
      also have "... = (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * ((\<sigma> * \<sigma>') / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) - (((\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2)\<^sup>2 - (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2)) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) / (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2))"
        by(simp add: monoid_mult_class.power2_eq_square[of "(\<sigma> * \<sigma>') / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)"] ab_semigroup_mult_class.mult.commute[of "\<sigma>\<^sup>2 + \<sigma>'\<^sup>2"] )
          (simp add: monoid_mult_class.power2_eq_square[of \<sigma>] monoid_mult_class.power2_eq_square[of \<sigma>'])
      also have "... =  (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) - ((\<mu> * \<sigma>'\<^sup>2)\<^sup>2 + (\<mu>' * \<sigma>\<^sup>2)\<^sup>2 + 2 * (\<mu> * \<sigma>'\<^sup>2) * (\<mu>' * \<sigma>\<^sup>2) - (\<sigma>\<^sup>2 * (\<mu>'\<^sup>2 * \<sigma>\<^sup>2) + \<sigma>\<^sup>2 * (\<mu>\<^sup>2 * \<sigma>'\<^sup>2) + (\<sigma>'\<^sup>2 * (\<mu>'\<^sup>2 * \<sigma>\<^sup>2) + \<sigma>'\<^sup>2 * (\<mu>\<^sup>2 * \<sigma>'\<^sup>2)))) / ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2)))"
        by(simp add: comm_semiring_1_class.power2_sum[of "\<mu> * \<sigma>'\<^sup>2" "\<mu>' * \<sigma>\<^sup>2"] semiring_class.distrib_right[of "\<sigma>\<^sup>2" "\<sigma>'\<^sup>2" "\<mu>'\<^sup>2 * \<sigma>\<^sup>2 + \<mu>\<^sup>2 * \<sigma>'\<^sup>2"] )
          (simp add: semiring_class.distrib_left[of _ "\<mu>'\<^sup>2 * \<sigma>\<^sup>2 " "\<mu>\<^sup>2 * \<sigma>'\<^sup>2"])
      also have "... = (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) + ((\<sigma>\<^sup>2 * \<sigma>'\<^sup>2)*\<mu>\<^sup>2 + (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2)*\<mu>'\<^sup>2 - (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2) * 2 * (\<mu>*\<mu>')) / ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * (2 * (\<sigma>\<^sup>2 * \<sigma>'\<^sup>2)))"
        by(simp add: monoid_mult_class.power2_eq_square division_ring_class.minus_divide_left)
      also have "... = (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) + (\<mu>\<^sup>2 + \<mu>'\<^sup>2 - 2 * (\<mu>*\<mu>')) / ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) * 2)"
        using assms by(simp add: division_ring_class.add_divide_distrib division_ring_class.diff_divide_distrib)
      also have "... = ?rhs'"
        by(simp add: comm_ring_1_class.power2_diff ab_semigroup_mult_class.mult.commute[of 2])
      finally show ?thesis .
    qed
    thus ?thesis
      by simp
  qed
  also have "... = (exp (- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) / (sqrt (2 * pi * \<sigma>\<^sup>2) * sqrt (2 * pi * \<sigma>'\<^sup>2))) * sqrt (2 * pi * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2)  * normal_density ((\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) x"
    by(simp add: exp_add[of "- (x - (\<mu> * \<sigma>'\<^sup>2 + \<mu>' * \<sigma>\<^sup>2) / (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2 / (2 * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2)" "- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))",simplified] normal_density_def)
  also have "... = ?rhs"
  proof -
    have "exp (- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) / (sqrt (2 * pi * \<sigma>\<^sup>2) * sqrt (2 * pi * \<sigma>'\<^sup>2)) * sqrt (2 * pi * (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))\<^sup>2) = 1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * exp (- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)))"
      using assms by(simp add: real_sqrt_mult)
    thus ?thesis
      by simp
  qed
  finally show ?thesis .
qed

lemma normal_density_times':
  assumes "\<sigma> > 0" "\<sigma>' > 0"
  shows "a * normal_density \<mu> \<sigma> x * normal_density \<mu>' \<sigma>' x = a * (1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) * exp (- (\<mu> - \<mu>')\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) * normal_density ((\<mu>*\<sigma>'\<^sup>2 + \<mu>'*\<sigma>\<^sup>2)/(\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) x"
  using normal_density_times[OF assms,of \<mu> x \<mu>']
  by (simp add: mult.assoc)

lemma normal_density_times_minusx:
  assumes "\<sigma> > 0" "\<sigma>' > 0" "a \<noteq> a'"
  shows "normal_density (\<mu> - a*x) \<sigma> y * normal_density (\<mu>' - a'*x) \<sigma>' y = (1 / \<bar>a' - a\<bar>) * normal_density ((\<mu>'- \<mu>)/(a'-a)) (sqrt ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)/(a' - a)\<^sup>2)) x * normal_density (((\<mu> - a*x)*\<sigma>'\<^sup>2 + (\<mu>' - a'*x)*\<sigma>\<^sup>2)/(\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) (\<sigma> * \<sigma>' / sqrt (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) y"
proof -
  have non0:"a' - a \<noteq> 0"
    using assms(3) by simp
  have "1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * exp (- (\<mu> - a * x - (\<mu>' - a' * x))\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2))) = 1 / \<bar>a' - a\<bar> * normal_density ((\<mu>' - \<mu>) / (a' - a)) (sqrt ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) / (a' - a)\<^sup>2)) x"
       (is "?lhs = ?rhs")
  proof -
    have "?lhs = 1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * exp (- ((a' - a) * x - (\<mu>' - \<mu>))\<^sup>2 / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)))"
      by(simp add: ring_class.left_diff_distrib group_add_class.diff_diff_eq2 add.commute add_diff_eq)
    also have "... = 1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * exp (- ((a' - a)\<^sup>2 * (x - (\<mu>' - \<mu>)/(a' - a))\<^sup>2) / (2 * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)))"
    proof -
      have "((a' - a) * x - (\<mu>' - \<mu>))\<^sup>2 = ((a' - a) * (x - (\<mu>' - \<mu>)/(a' - a)))\<^sup>2"
        using non0 by(simp add: ring_class.right_diff_distrib[of "a'-a" x])
      also have "... = (a' - a)\<^sup>2 * (x - (\<mu>' - \<mu>)/(a' - a))\<^sup>2"
        by(simp add: monoid_mult_class.power2_eq_square)
      finally show ?thesis
        by simp
    qed
    also have "... = 1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * sqrt (2 * pi * (sqrt ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)/(a' - a)\<^sup>2))\<^sup>2) * normal_density ((\<mu>' - \<mu>) / (a' - a)) (sqrt ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2) / (a' - a)\<^sup>2)) x"
      using non0 by (simp add: normal_density_def)
    also have "... = ?rhs"
    proof -
      have "1 / sqrt (2 * pi * (\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)) * sqrt (2 * pi * (sqrt ((\<sigma>\<^sup>2 + \<sigma>'\<^sup>2)/(a' - a)\<^sup>2))\<^sup>2) = 1 / \<bar>a' - a\<bar>"
        using assms by(simp add: real_sqrt_divide[symmetric]) (simp add: real_sqrt_divide)
      thus ?thesis
        by simp
    qed
    finally show ?thesis .
  qed
  thus ?thesis
    by(simp add:normal_density_times[OF assms(1,2),of "\<mu> - a*x" y "\<mu>' - a'*x"])
qed

text \<open> The following is the normalizing constant of the program. \<close>
abbreviation "C \<equiv> ennreal ((4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * (exp (- (1674761 / 1674025))))"

lemma program_normalizing_constant:
 "emeasure (density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g)) UNIV = C"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<integral>\<^sup>+ x. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) x \<partial> (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f))"
    by(simp add: emeasure_density)
  also have "... = (\<integral>\<^sup>+ z. (obs \<circ> (\<lambda>(s, b) r. s * r + b)) z \<partial>(\<nu> \<Otimes>\<^sub>M \<nu>))"
    using nn_integral_distr[of real_real.f "\<nu> \<Otimes>\<^sub>M \<nu>" real_borel "obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g",simplified]
    by(simp add: comp_def)
  also have "... = (\<integral>\<^sup>+ x. \<integral>\<^sup>+ y. (obs \<circ> (\<lambda>(s, b) r. s * r + b)) (x, y) \<partial>\<nu> \<partial>\<nu>)"
    by(simp only: \<nu>_qp.nn_integral_snd[where f="(obs \<circ> (\<lambda>(s, b) r. s * r + b))",simplified,symmetric])
      (simp add: \<nu>_qp.Fubini[where f="(obs \<circ> (\<lambda>(s, b) r. s * r + b))",simplified])
  also have "... = (\<integral>\<^sup>+ x. 2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x \<partial>\<nu>)"
  proof(rule nn_integral_cong[where M=\<nu>,simplified])
    fix x
    have [measurable]: "(\<lambda>y. obs (\<lambda>r. x * r + y)) \<in> real_borel \<rightarrow>\<^sub>M ennreal_borel"
      using measurable_Pair2[of "obs \<circ> (\<lambda>(s, b) r. s * r + b)"] by auto
    show "(\<integral>\<^sup>+ y. (obs \<circ> (\<lambda>(s, b) r. s * r + b)) (x, y) \<partial>\<nu>) = 2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x"
          (is "?lhs' = ?rhs'")
    proof -
      have "?lhs' = (\<integral>\<^sup>+ y. ennreal (d (5 / 2 - x) y * d (19 / 5 - x * 2) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y) \<partial>lborel)"
        by(simp add: nn_integral_density obs_def normal_density_mu_x_swap[where x="5/2"] normal_density_mu_x_swap[where x="19/5"] normal_density_mu_x_swap[where x="9/2"] normal_density_mu_x_swap[where x="31/5"] normal_density_mu_x_swap[where x="8"] normal_density_plus_shift ab_semigroup_mult_class.mult.commute[of "ennreal (normal_density 0 3 _)"] ennreal_mult'[symmetric])
      also have "... = (\<integral>\<^sup>+ y. ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y) \<partial>lborel)"
      proof(rule nn_integral_cong[where M=lborel,simplified])
        fix y
        have "d (5 / 2 - x) y * d (19 / 5 - x * 2) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y = 2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y"
             (is "?lhs'' = ?rhs''")
        proof -
          have "?lhs'' = normal_density (13 / 10) (1 / sqrt 2) x * normal_density (63 / 20 - (3 / 2) * x)  (sqrt 2 / 4) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y"
          proof -
            have "d (5 / 2 - x) y * d (19 / 5 - x * 2) y = normal_density (13 / 10) (1 / sqrt 2) x * normal_density (63 / 20 - (3 / 2) * x) (sqrt 2 / 4) y"
              by(simp add: normal_density_times_minusx[of "1/2" "1/2" 1 2 "5/2" x y "19/5",simplified ab_semigroup_mult_class.mult.commute[of 2 x],simplified])
                (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib)
            thus ?thesis
              by simp
          qed
          also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (18 / 5 - 2 * x) (1 / (2 * sqrt 3)) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y"
          proof -
            have 1:"sqrt 2 * sqrt 8 / (8 * sqrt 3) = 1 / (2 * sqrt 3)"
              by(simp add: real_sqrt_divide[symmetric] real_sqrt_mult[symmetric])
            have "normal_density (63 / 20 - 3 / 2 * x) (sqrt 2 / 4) y * d (9 / 2 - x * 3) y = (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (18 / 5 - 2 * x) (1 / (2 * sqrt 3)) y"
              by(simp add: normal_density_times_minusx[of "sqrt 2 / 4" "1 / 2" "3 / 2" 3 "63 / 20" x y "9 / 2",simplified ab_semigroup_mult_class.mult.commute[of 3 x],simplified])
                (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib 1)
            thus ?thesis
              by simp
          qed
          also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (17 / 4 - (5 / 2) * x) (1 / 4) y * d (8 - x * 5) y * normal_density 0 3 y"
          proof -
            have 1:"normal_density (18 / 5 - 2 * x) (1 / (2 * sqrt 3)) y * d (31 / 5 - x * 4) y = (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (17 / 4 - 5 / 2 * x) (1 / 4) y"
              by(simp add: normal_density_times_minusx[of "1 / (2 * sqrt 3)" "1 / 2" 2 4 "18 / 5" x y "31 / 5",simplified ab_semigroup_mult_class.mult.commute[of 4 x],simplified])
                (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib)
            show ?thesis
              by(simp add: 1 mult.assoc)
          qed
          also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * (2 / 5) * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 - 3 * x) (1 / (2 * sqrt 5)) y * normal_density 0 3 y"
          proof -
            have 1:"normal_density (17 / 4 - 5 / 2 * x) (1 / 4) y * d (8 - x * 5) y = (2 / 5) * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 - 3 * x) (1 / (2 * sqrt 5)) y"
              by(simp add: normal_density_times_minusx[of "1 / 4" "1 / 2" "5 / 2" 5 "17 / 4" x y 8,simplified ab_semigroup_mult_class.mult.commute[of 5 x],simplified])
                (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib)
            show ?thesis
              by(simp only: 1 mult.assoc)
          qed
          also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * (2 / 5) * normal_density (3 / 2) (1 / sqrt 20) x * (1 / 3) * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) ((3 / (2 * sqrt 5))/ sqrt (181 / 20)) y"
          proof -
            have "normal_density (5 - 3 * x) (1 / (2 * sqrt 5)) y * normal_density 0 3 y = (1 / 3) * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) ((3 / (2 * sqrt 5))/ sqrt (181 / 20)) y"
              by(simp add: normal_density_times_minusx[of "1 / (2 * sqrt 5)" 3 3 0 5 x y 0,simplified] monoid_mult_class.power2_eq_square)
            thus ?thesis
              by(simp only: mult.assoc)
          qed
          also have "... = ?rhs''"
            by simp
          finally show ?thesis .
        qed
        thus "ennreal( d (5 / 2 - x) y * d (19 / 5 - x * 2) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y) = ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y )"
          by simp
      qed
      also have "... = (\<integral>\<^sup>+ y. ennreal (normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y) * ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x) \<partial>lborel)"
        by(simp add: ab_semigroup_mult_class.mult.commute ennreal_mult'[symmetric])
      also have "... = (\<integral>\<^sup>+ y. ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x) \<partial> (density lborel (\<lambda>y. ennreal (normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y))))"
        by(simp add: nn_integral_density[of "\<lambda>y. ennreal (normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y)" lborel,simplified,symmetric])
      also have "... = ?rhs'"
        by(simp add: prob_space.emeasure_space_1[OF prob_space_normal_density[of "3 / (2 * sqrt 5 * sqrt (181 / 20))" "20 / 181 * 9 * (5 - 3 * x)"],simplified])
      finally show ?thesis .
    qed
  qed
  also have "... = (\<integral>\<^sup>+ x. ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x) \<partial>lborel)"
    by(simp add: nn_integral_density ab_semigroup_mult_class.mult.commute ennreal_mult'[symmetric])
  also have "... = (\<integral>\<^sup>+ x. (4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025)) * normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x \<partial>lborel)"
  proof(rule nn_integral_cong[where M=lborel,simplified])
    fix x
    show "ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x) = ennreal ((4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025)) * normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x)"
    proof -
      have "2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x = (4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025)) * normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x"
           (is "?lhs' = ?rhs'")
      proof -
        have "?lhs' = 2 / 45 * exp (- (3 / 25)) / sqrt (4 * pi / 3) * normal_density 1 (1 / sqrt 8) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x"
          by(simp add: normal_density_times' monoid_mult_class.power2_eq_square real_sqrt_mult[symmetric])
        also have "... = (2 / (15 * pi * sqrt 5)) * exp (- (42 / 125)) * normal_density (59 / 50) (1 / sqrt 20) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x"
        proof -
          have 1:"sqrt 8 * sqrt 12 * sqrt (5 / 24) = sqrt 20"
            by(simp add:real_sqrt_mult[symmetric])
          have 2:"sqrt (5 * pi / 12) * (45 * sqrt (4 * pi / 3)) = 15 * (pi * sqrt 5)"
            by(simp add: real_sqrt_mult[symmetric] real_sqrt_divide) (simp add: real_sqrt_mult real_sqrt_mult[of 4 5,simplified])
          have "2 / 45 * exp (- (3 / 25)) / sqrt (4 * pi / 3) * normal_density 1 (1 / sqrt 8) x * normal_density (13 / 10) (1 / sqrt 12) x = (6 / (45 * pi * sqrt 5)) * exp (- (42 / 125)) * normal_density (59 / 50) (1 / sqrt 20) x"
            by(simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (3 / 25)" "- (27 / 125)",simplified,symmetric] 1 2)
          thus ?thesis
            by simp
        qed
        also have "... = 2 / (15 * pi * sqrt pi) * exp (- (106 / 125)) * normal_density (67 / 50) (sqrt 10 / 20 ) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x"
        proof -
          have "2 / (15 * pi * sqrt 5) * exp (- (42 / 125)) * normal_density (59 / 50) (1 / sqrt 20) x * normal_density (3 / 2) (1 / sqrt 20) x = 2 / (15 * pi * sqrt pi) * exp (- (106 / 125)) * normal_density (67 / 50) (sqrt 10 /20) x"
            by(simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (42 / 125)" "- (64 / 125)",simplified,symmetric] real_sqrt_divide)
              (simp add: mult.commute)
          thus ?thesis
            by simp
        qed
        also have "... = ((4 * sqrt 5) / (5 * pi\<^sup>2 * sqrt 371)) * exp (- (5961 / 6625)) * normal_density (1786 / 1325) (sqrt 905 / (10 * sqrt 371)) x * normal_density 0 3 x"
        proof -
          have 1:"sqrt (371 * pi / 180) * (15 * pi * sqrt pi) = 5 * pi * pi * sqrt 371 / (2 * sqrt 5)"
            by(simp add: real_sqrt_mult real_sqrt_divide real_sqrt_mult[of 36 5,simplified])
          have 22:"10 = sqrt 5 * 2 * sqrt 5" by simp
          have 2:"sqrt 10 * sqrt (181 / 180) / (20 * sqrt (371 / 360)) = sqrt 905 / (10 * sqrt 371)"
            by(simp add: real_sqrt_mult real_sqrt_divide real_sqrt_mult[of 36 5,simplified] real_sqrt_mult[of 36 10,simplified]  real_sqrt_mult[of 181 5,simplified])
              (simp add: mult.assoc[symmetric] 22)
          have "2 / (15 * pi * sqrt pi) * exp (- (106 / 125)) * normal_density (67 / 50) (sqrt 10 / 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x  = 4 * sqrt 5 / (5 * pi\<^sup>2 * sqrt 371) * exp (- (5961 / 6625)) * normal_density (1786 / 1325) (sqrt 905 / (10 * sqrt 371)) x"
            by(simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (106 / 125)" "- (343 / 6625)",simplified,symmetric] 1 2)
              (simp add: mult.assoc)
          thus ?thesis
            by simp
        qed
        also have "... = ?rhs'"
        proof -
          have 1: "4 * sqrt 5 / (sqrt (66961 * pi / 3710) * (5 * (pi * pi) * sqrt 371)) = 4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))"
            by(simp add: real_sqrt_mult[of 10 371,simplified] real_sqrt_mult[of 5 2,simplified] real_sqrt_divide monoid_mult_class.power2_eq_square mult.assoc)
              (simp add: mult.assoc[symmetric])
          have 2: "sqrt 905 * 3 / (10 * sqrt 371 * sqrt (66961 / 7420)) = 3 * sqrt 181 / sqrt 66961"
            by(simp add: real_sqrt_mult[of 371 20,simplified] real_sqrt_divide real_sqrt_mult[of 4 5,simplified] real_sqrt_mult[of 181 5,simplified]  mult.commute[of _ 3])
              (simp add: mult.assoc)
          show ?thesis
            by(simp only: 1[symmetric]) (simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (5961 / 6625)" "- (44657144 / 443616625)",simplified,symmetric] 2)
        qed
        finally show ?thesis .
      qed
      thus ?thesis
        by simp
    qed
  qed
  also have "... = (\<integral>\<^sup>+ x. ennreal (normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x) *  (ennreal (4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025))) \<partial>lborel)"
    by(simp add: ab_semigroup_mult_class.mult.commute ennreal_mult'[symmetric])
  also have "... = (\<integral>\<^sup>+ x. (ennreal (4 * sqrt 2 / (pi\<^sup>2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025))) \<partial>(density lborel (\<lambda>x. ennreal (normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x))))"
    by(simp add: nn_integral_density[symmetric])
  also have "... = ?rhs"
    by(simp add: prob_space.emeasure_space_1[OF prob_space_normal_density,simplified] ennreal_mult'[symmetric])
  finally show ?thesis .
qed

text \<open> The program returns a probability measure, rather than error. \<close>
lemma program_result:
 "qbs_prob (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q) ((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) (density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r / C))"
 "program = Inl (qbs_prob_space (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q, (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g, density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r / C)))"
  using norm_qbs_measure_computation[OF push_forward_measure_computation(1),simplified program_normalizing_constant]
        norm_qbs_measure_qbs_prob[OF push_forward_measure_computation(1),simplified program_normalizing_constant]
  by(simp_all add: push_forward_measure_computation program_def comp_def)

lemma program_inl:
 "program \<in> Inl ` (qbs_space (monadP_qbs (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q)))"
  using program_in_space[simplified program_result(2)]
  by(auto simp: image_def program_result(2))

lemma program_result_measure:
 "qbs_prob_measure (qbs_prob_space (\<real>\<^sub>Q \<Rightarrow>\<^sub>Q \<real>\<^sub>Q, (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g, density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r / C)))
   = density (qbs_prob_measure prior) (\<lambda>k. obs k / C)"
 (is "?lhs = ?rhs")
proof -
  interpret qp: qbs_prob "exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q" "(\<lambda>(s, b) r. s * r + b) \<circ> real_real.g" "density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r / C)"
    by(rule  program_result(1))
  have "?lhs = distr (density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. obs (((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r) / C)) (qbs_to_measure (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)) ((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g)"
    using qp.qbs_prob_measure_computation by simp
  also have "... = density (distr (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (qbs_to_measure (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)) ((\<lambda>(s, b) r. s * r + b) \<circ> real_real.g)) (\<lambda>k. obs k / C)"
    by(simp add: density_distr)
  also have "... = ?rhs"
    by(simp add: distr_distr comp_def prior_measure)
  finally show ?thesis .
qed

lemma program_result_measure':
 "qbs_prob_measure (qbs_prob_space (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q, (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g, density (distr (\<nu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (\<lambda>r. (obs \<circ> (\<lambda>(s, b) r. s * r + b) \<circ> real_real.g) r / C)))
   = distr (density (\<nu> \<Otimes>\<^sub>M \<nu>) (\<lambda>(s,b). obs (\<lambda>r. s * r + b) / C)) (qbs_to_measure (exp_qbs \<real>\<^sub>Q \<real>\<^sub>Q)) (\<lambda>(s, b) r. s * r + b)"
  by(simp only: program_result_measure distr_distr) (simp add: density_distr split_beta' prior_measure)

end


section \<open>Formal Derivatives\label{sec:pderiv}\<close>

theory Formal_Polynomial_Derivatives
  imports "HOL-Algebra.Polynomial_Divisibility" "Ring_Characteristic"
begin

definition pderiv ("pderiv\<index>") where
  "pderiv\<^bsub>R\<^esub> x = ring.normalize R (
    map (\<lambda>i. int_embed R i \<otimes>\<^bsub>R\<^esub> ring.coeff R x i) (rev [1..<length x]))"

context domain
begin

lemma coeff_range:
  assumes "subring K R"
  assumes "f \<in> carrier (K[X])"
  shows "coeff f i \<in> K"
proof -
  have "coeff f i \<in> set f \<union> {\<zero>}"
    using coeff_img(3) by auto
  also have "... \<subseteq> K \<union> {\<zero>}"
    using assms(2) univ_poly_carrier polynomial_incl by blast
  also have "... \<subseteq> K"
    using subringE[OF assms(1)] by simp
  finally show ?thesis by simp
qed

lemma pderiv_carr:
  assumes "subring K R"
  assumes "f \<in> carrier (K[X])"
  shows "pderiv f \<in> carrier (K[X])"
proof -
  have "int_embed R i \<otimes> coeff f i \<in> K" for i
    using coeff_range[OF assms] int_embed_range[OF assms(1)]
    using subringE[OF assms(1)] by simp
  hence "polynomial K (pderiv f)"
    unfolding pderiv_def by (intro normalize_gives_polynomial, auto)
  thus ?thesis
    using univ_poly_carrier by auto
qed

lemma pderiv_coeff:
  assumes "subring K R"
  assumes "f \<in> carrier (K[X])"
  shows "coeff (pderiv f) k = int_embed R (Suc k) \<otimes> coeff f (Suc k)"
    (is "?lhs = ?rhs")
proof (cases "k + 1  < length f")
  case True
  define j where "j = length f - k - 2"
  define d where
    "d = map (\<lambda>i. int_embed R i \<otimes> coeff f i) (rev [1..<length f])"

  have a: "j+1 < length f"
    using True unfolding j_def by simp
  hence b: "j < length [1..<length f]"
    by simp
  have c: "k < length d"
    unfolding d_def using True by simp
  have d: "degree d - k = j"
    unfolding d_def j_def by simp
  have e: "rev [Suc 0..<length f] ! j = length f - 1 - j"
    using b  by (subst rev_nth, auto)
  have f: "length f - j - 1 = k+1"
    unfolding j_def using True by simp

  have "coeff (pderiv f ) k = coeff (normalize d) k"
    unfolding pderiv_def d_def by simp
  also have "... = coeff d k"
    using normalize_coeff by simp
  also have "... = d ! j"
    using c d by (subst coeff_nth, auto)
  also have
    "... = int_embed R (length f - j - 1) \<otimes> coeff f (length f - j - 1)"
    using b e unfolding d_def by simp
  also have "... = ?rhs"
    using f by simp
  finally show ?thesis by simp
next
  case False
  hence "Suc k \<ge> length f"
    by simp
  hence a:"coeff f (Suc k) = \<zero>"
    using coeff_img by blast
  have b:"coeff (pderiv f) k = \<zero>"
    unfolding pderiv_def normalize_coeff[symmetric] using False
    by (intro coeff_length, simp)
  show ?thesis
    using int_embed_range[OF carrier_is_subring] by (simp add:a b)
qed

lemma pderiv_const:
  assumes "degree x = 0"
  shows "pderiv x = \<zero>\<^bsub>K[X]\<^esub>"
proof (cases "length x = 0")
  case True
  then show ?thesis by (simp add:univ_poly_zero pderiv_def)
next
  case False
  hence "length x = 1" using assms by linarith
  then obtain y where "x = [y]" by (cases x, auto)
  then show ?thesis by (simp add:univ_poly_zero pderiv_def)
qed

lemma pderiv_var:
  shows "pderiv X = \<one>\<^bsub>K[X]\<^esub>"
  unfolding var_def pderiv_def
  by (simp add:univ_poly_one int_embed_def)

lemma pderiv_zero:
  shows "pderiv \<zero>\<^bsub>K[X]\<^esub> = \<zero>\<^bsub>K[X]\<^esub>"
  unfolding pderiv_def univ_poly_zero by simp

lemma pderiv_add:
  assumes "subring K R"
  assumes [simp]: "f \<in> carrier (K[X])" "g \<in> carrier (K[X])"
  shows "pderiv (f \<oplus>\<^bsub>K[X]\<^esub> g) = pderiv f \<oplus>\<^bsub>K[X]\<^esub> pderiv g"
    (is "?lhs = ?rhs")
proof -
  interpret p: ring "(K[X])"
    using univ_poly_is_ring[OF assms(1)] by simp

  let ?n = "(\<lambda>i. int_embed R i)"

  have a[simp]:"?n k \<in> carrier R" for k
    using int_embed_range[OF carrier_is_subring] by auto
  have b[simp]:"coeff f k \<in> carrier R" if "f \<in> carrier (K[X])" for k f
    using coeff_range[OF assms(1)] that
    using subringE(1)[OF assms(1)] by auto

  have "coeff ?lhs i = coeff ?rhs i" for i
  proof -
    have "coeff ?lhs i = ?n (i+1) \<otimes> coeff (f \<oplus>\<^bsub>K [X]\<^esub> g) (i+1)"
      by (simp add: pderiv_coeff[OF assms(1)])
    also have "... = ?n (i+1) \<otimes> (coeff f (i+1) \<oplus> coeff g (i+1))"
      by (subst coeff_add[OF assms], simp)
    also have "... = ?n (i+1) \<otimes> coeff f (i+1)
      \<oplus> int_embed R (i+1) \<otimes> coeff g (i+1)"
      by (subst r_distr, simp_all)
    also have "... = coeff (pderiv f) i \<oplus> coeff (pderiv g) i"
      by (simp add: pderiv_coeff[OF assms(1)])
    also have "... = coeff (pderiv f \<oplus>\<^bsub>K [X]\<^esub> pderiv g) i"
      using pderiv_carr[OF assms(1)]
      by (subst coeff_add[OF assms(1)], auto)
    finally show ?thesis by simp
  qed
  hence "coeff ?lhs = coeff ?rhs" by auto
  thus "?lhs = ?rhs"
    using pderiv_carr[OF assms(1)]
    by (subst coeff_iff_polynomial_cond[where K="K"])
      (simp_all add:univ_poly_carrier)+
qed

lemma pderiv_inv:
  assumes "subring K R"
  assumes [simp]: "f \<in> carrier (K[X])"
  shows "pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) = \<ominus>\<^bsub>K[X]\<^esub> pderiv f" (is "?lhs = ?rhs")
proof -
  interpret p: cring "(K[X])"
    using univ_poly_is_cring[OF assms(1)] by simp

  have "pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) \<oplus>\<^bsub>K[X]\<^esub> \<zero>\<^bsub>K[X]\<^esub>"
    using pderiv_carr[OF assms(1)]
    by (subst p.r_zero, simp_all)
  also have "... = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) \<oplus>\<^bsub>K[X]\<^esub> (pderiv f \<ominus>\<^bsub>K[X]\<^esub> pderiv f)"
    using pderiv_carr[OF assms(1)] by simp
  also have "... = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) \<oplus>\<^bsub>K[X]\<^esub> pderiv f \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
    using pderiv_carr[OF assms(1)]
    unfolding a_minus_def by (simp add:p.a_assoc)
  also have "... = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f \<oplus>\<^bsub>K[X]\<^esub> f) \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
    by (subst pderiv_add[OF assms(1)], simp_all)
  also have "... = pderiv \<zero>\<^bsub>K[X]\<^esub> \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
    by (subst p.l_neg, simp_all)
  also have "... = \<zero>\<^bsub>K[X]\<^esub> \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
    by (subst pderiv_zero, simp)
  also have "... = \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
    unfolding a_minus_def using pderiv_carr[OF assms(1)]
    by (subst p.l_zero, simp_all)
  finally show "pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) = \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
    by simp
qed

lemma coeff_mult:
  assumes "subring K R"
  assumes "f \<in> carrier (K[X])" "g \<in> carrier (K[X])"
  shows "coeff (f \<otimes>\<^bsub>K[X]\<^esub> g) i =
    (\<Oplus> k \<in> {..i}. (coeff f) k \<otimes> (coeff g) (i - k))"
proof -
  have a:"set f \<subseteq> carrier R"
    using assms(1,2) univ_poly_carrier
    using subringE(1)[OF assms(1)] polynomial_incl by blast
  have b:"set g \<subseteq> carrier R"
    using assms(1,3) univ_poly_carrier
    using subringE(1)[OF assms(1)] polynomial_incl by blast
  show ?thesis
    unfolding univ_poly_mult poly_mult_coeff[OF a b] by simp
qed

lemma pderiv_mult:
  assumes "subring K R"
  assumes [simp]: "f \<in> carrier (K[X])" "g \<in> carrier (K[X])"
  shows "pderiv (f \<otimes>\<^bsub>K[X]\<^esub> g) =
    pderiv f \<otimes>\<^bsub>K[X]\<^esub> g \<oplus>\<^bsub>K[X]\<^esub> f \<otimes>\<^bsub>K[X]\<^esub> pderiv g"
    (is "?lhs = ?rhs")
proof -
  interpret p: cring "(K[X])"
    using univ_poly_is_cring[OF assms(1)] by simp

  let ?n = "(\<lambda>i. int_embed R i)"

  have a[simp]:"?n k \<in> carrier R" for k
    using int_embed_range[OF carrier_is_subring] by auto
  have b[simp]:"coeff f k \<in> carrier R" if "f \<in> carrier (K[X])" for k f
    using coeff_range[OF assms(1)]
    using subringE(1)[OF assms(1)] that by auto

  have "coeff ?lhs i = coeff ?rhs i" for i
  proof -
    have "coeff ?lhs i = ?n (i+1) \<otimes> coeff (f \<otimes>\<^bsub>K [X]\<^esub> g) (i+1)"
      using assms(2,3) by (simp add: pderiv_coeff[OF assms(1)])
    also have "... = ?n (i+1) \<otimes>
      (\<Oplus>k \<in> {..i+1}. coeff f k \<otimes> (coeff g (i + 1 - k)))"
      by (subst coeff_mult[OF assms], simp)
    also have "... =
      (\<Oplus>k \<in> {..i+1}. ?n (i+1) \<otimes> (coeff f k \<otimes> coeff g (i + 1 - k)))"
      by (intro finsum_rdistr, simp_all add:Pi_def)
    also have "... =
      (\<Oplus>k \<in> {..i+1}. ?n k \<otimes> (coeff f k \<otimes> coeff g (i + 1 - k)) \<oplus>
      ?n (i+1-k) \<otimes> (coeff f k \<otimes> coeff g (i + 1 - k)))"
      using int_embed_add[symmetric] of_nat_diff
      by (intro finsum_cong')
        (simp_all add:l_distr[symmetric] of_nat_diff)
    also have "... =
      (\<Oplus>k \<in> {..i+1}. ?n k \<otimes> coeff f k \<otimes> coeff g (i + 1 - k) \<oplus>
      coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i + 1 - k)))"
      using Pi_def a b m_assoc m_comm
      by (intro finsum_cong' arg_cong2[where f="(\<oplus>)"], simp_all)
    also have "... =
      (\<Oplus>k \<in> {..i+1}. ?n k \<otimes> coeff f k \<otimes> coeff g (i+1-k)) \<oplus>
      (\<Oplus>k \<in> {..i+1}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))"
      by (subst finsum_addf[symmetric], simp_all add:Pi_def)
    also have "... =
      (\<Oplus>k\<in>insert 0 {1..i+1}. ?n k \<otimes> coeff f k \<otimes> coeff g (i+1-k)) \<oplus>
      (\<Oplus>k\<in>insert (i+1) {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))"
      using subringE(1)[OF assms(1)]
      by (intro arg_cong2[where f="(\<oplus>)"] finsum_cong')
        (auto simp:set_eq_iff)
    also have "... =
      (\<Oplus>k \<in> {1..i+1}. ?n k \<otimes> coeff f k \<otimes> coeff g (i+1-k)) \<oplus>
      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))"
      by (subst (1 2) finsum_insert, auto simp add:int_embed_zero)
    also have "... =
      (\<Oplus>k \<in> Suc ` {..i}. ?n k \<otimes> coeff f (k) \<otimes> coeff g (i+1-k)) \<oplus>
      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))"
      by (intro arg_cong2[where f="(\<oplus>)"] finsum_cong')
        (simp_all add:Pi_def atMost_atLeast0)
    also have "... =
      (\<Oplus>k \<in> {..i}. ?n (k+1) \<otimes> coeff f (k+1) \<otimes> coeff g (i-k)) \<oplus>
      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))"
      by (subst finsum_reindex, auto)
    also have "... =
      (\<Oplus>k \<in> {..i}. coeff (pderiv f) k \<otimes> coeff g (i-k)) \<oplus>
      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> coeff (pderiv g) (i-k))"
      using Suc_diff_le
      by (subst (1 2) pderiv_coeff[OF assms(1)])
        (auto intro!: finsum_cong')
    also have "... =
      coeff (pderiv f \<otimes>\<^bsub>K[X]\<^esub> g) i \<oplus> coeff (f \<otimes>\<^bsub>K[X]\<^esub> pderiv g) i"
      using pderiv_carr[OF assms(1)]
      by (subst (1 2) coeff_mult[OF assms(1)], auto)
    also have "... = coeff ?rhs i"
      using pderiv_carr[OF assms(1)]
      by (subst coeff_add[OF assms(1)], auto)
    finally show ?thesis by simp
  qed

  hence "coeff ?lhs = coeff ?rhs" by auto
  thus "?lhs = ?rhs"
    using pderiv_carr[OF assms(1)]
    by (subst coeff_iff_polynomial_cond[where K="K"])
     (simp_all add:univ_poly_carrier)
qed

lemma pderiv_pow:
  assumes "n > (0 :: nat)"
  assumes "subring K R"
  assumes [simp]: "f \<in> carrier (K[X])"
  shows "pderiv (f [^]\<^bsub>K[X]\<^esub> n) =
    int_embed (K[X]) n \<otimes>\<^bsub>K[X]\<^esub> f [^]\<^bsub>K[X]\<^esub> (n-1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f"
    (is "?lhs = ?rhs")
proof -
  interpret p: cring "(K[X])"
    using univ_poly_is_cring[OF assms(2)] by simp

  let ?n = "\<lambda>n. int_embed (K[X]) n"

  have [simp]: "?n i \<in> carrier (K[X])" for i
    using p.int_embed_range[OF p.carrier_is_subring] by simp

  obtain m where n_def: "n = Suc m" using assms(1) lessE by blast
  have "pderiv (f [^]\<^bsub>K[X]\<^esub> (m+1)) =
    ?n (m+1) \<otimes>\<^bsub>K[X]\<^esub> f [^]\<^bsub>K[X]\<^esub> m \<otimes>\<^bsub>K[X]\<^esub> pderiv f"
  proof (induction m)
    case 0
    then show ?case
      using pderiv_carr[OF assms(2)] assms(3)
      using p.int_embed_one by simp
  next
    case (Suc m)
    have "pderiv (f [^]\<^bsub>K [X]\<^esub> (Suc m + 1)) =
      pderiv (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> f) "
      by simp
    also have "... =
      pderiv (f [^]\<^bsub>K [X]\<^esub> (m+1)) \<otimes>\<^bsub>K[X]\<^esub> f \<oplus>\<^bsub>K[X]\<^esub>
      f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f"
      using assms(3) by (subst pderiv_mult[OF assms(2)], auto)
    also have "... =
      (?n (m+1) \<otimes>\<^bsub>K [X]\<^esub> f [^]\<^bsub>K [X]\<^esub> m \<otimes>\<^bsub>K [X]\<^esub> pderiv f) \<otimes>\<^bsub>K[X]\<^esub> f
      \<oplus>\<^bsub>K[X]\<^esub> f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f"
      by (subst Suc(1), simp)
    also have
      "... = ?n (m+1) \<otimes>\<^bsub>K[X]\<^esub> (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f)
      \<oplus>\<^bsub>K[X]\<^esub> \<one>\<^bsub>K [X]\<^esub> \<otimes>\<^bsub>K[X]\<^esub> (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f)"
      using assms(3) pderiv_carr[OF assms(2)]
      apply (intro arg_cong2[where f="(\<oplus>\<^bsub>K[X]\<^esub>)"])
      apply (simp add:p.m_assoc)
       apply (simp add:p.m_comm)
      by simp
    also have
      "... = (?n (m+1) \<oplus>\<^bsub>K[X]\<^esub> \<one>\<^bsub>K [X]\<^esub>) \<otimes>\<^bsub>K [X]\<^esub>
      (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K [X]\<^esub> pderiv f)"
      using assms(3) pderiv_carr[OF assms(2)]
      by (subst p.l_distr[symmetric], simp_all)
    also have "... =
      (\<one>\<^bsub>K [X]\<^esub> \<oplus>\<^bsub>K[X]\<^esub> ?n (m+1)) \<otimes>\<^bsub>K [X]\<^esub>
      (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K [X]\<^esub> pderiv f)"
      using assms(3) pderiv_carr[OF assms(2)]
      by (subst p.a_comm, simp_all)
    also have "... = ?n (1+ Suc m)
      \<otimes>\<^bsub>K [X]\<^esub> f [^]\<^bsub>K [X]\<^esub> (Suc m) \<otimes>\<^bsub>K [X]\<^esub> pderiv f"
      using assms(3) pderiv_carr[OF assms(2)] of_nat_add
      apply (subst (2) of_nat_add, subst p.int_embed_add)
      by (simp add:p.m_assoc p.int_embed_one)
    finally show ?case by simp
  qed
  thus "?thesis" using n_def by auto
qed

lemma pderiv_var_pow:
  assumes "n > (0::nat)"
  assumes "subring K R"
  shows "pderiv (X [^]\<^bsub>K[X]\<^esub> n) =
    int_embed (K[X]) n \<otimes>\<^bsub>K[X]\<^esub> X [^]\<^bsub>K[X]\<^esub> (n-1)"
proof -
  interpret p: cring "(K[X])"
    using univ_poly_is_cring[OF assms(2)] by simp

  have [simp]: "int_embed (K[X]) i \<in> carrier (K[X])" for i
    using p.int_embed_range[OF p.carrier_is_subring] by simp

  show ?thesis
    using var_closed[OF assms(2)]
    using pderiv_var[where K="K"] pderiv_carr[OF assms(2)]
    by (subst pderiv_pow[OF assms(1,2)], simp_all)
qed

lemma int_embed_consistent_with_poly_of_const:
  assumes "subring K R"
  shows "int_embed (K[X]) m = poly_of_const (int_embed R m)"
proof -
  define K' where "K' = R \<lparr> carrier := K \<rparr>"
  interpret p: cring "(K[X])"
    using univ_poly_is_cring[OF assms] by simp
  interpret d: domain "K'"
    unfolding K'_def
    using assms(1) subdomainI' subdomain_is_domain by simp
  interpret h: ring_hom_ring  "K'" "K[X]" "poly_of_const"
    unfolding K'_def
    using canonical_embedding_ring_hom[OF assms(1)] by simp

  define n where "n=nat (abs m)"

  have a1: "int_embed (K[X]) (int n) = poly_of_const (int_embed K' n)"
  proof (induction n)
    case 0
    then show ?case by (simp add:d.int_embed_zero p.int_embed_zero)
  next
    case (Suc n)
    then show ?case
      using d.int_embed_closed d.int_embed_add d.int_embed_one
      by (simp add:p.int_embed_add p.int_embed_one)
  qed
  also have "... = poly_of_const (int_embed R n)"
    unfolding K'_def using int_embed_consistent[OF assms] by simp
  finally have a:
    "int_embed (K[X]) (int n) = poly_of_const (int_embed R (int n))"
    by simp

  have "int_embed (K[X]) (-(int n)) =
    poly_of_const (int_embed K' (- (int n)))"
    using d.int_embed_closed a1 by (simp add: p.int_embed_inv d.int_embed_inv)
  also have "... = poly_of_const (int_embed R (- (int n)))"
    unfolding K'_def using int_embed_consistent[OF assms] by simp
  finally have b:
    "int_embed (K[X]) (-int n) = poly_of_const (int_embed R (-int n))"
    by simp

  show ?thesis
    using a b n_def by (cases "m \<ge> 0", simp, simp)
qed

end

end