(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Cong_Subst
  imports Weak_Late_Cong Weak_Late_Bisim_Subst Strong_Late_Bisim_Subst
begin

definition congruenceSubst :: "pi \<Rightarrow> pi\<Rightarrow> bool" (infixr "\<simeq>\<^sup>s" 65) where
  "P \<simeq>\<^sup>s Q \<equiv> (P, Q) \<in> (substClosed congruence)"

lemmas congruenceSubstDef = congruenceSubst_def congruence_def substClosed_def

lemma unfoldE:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<simeq>\<^sup>s Q"

  shows "P[<s>] \<leadsto><weakBisim> Q[<s>]"
  and   "Q[<s>] \<leadsto><weakBisim> P[<s>]"
proof -
  from assms show "P[<s>] \<leadsto><weakBisim> Q[<s>]" by(force simp add: congruenceSubstDef)
next
  from assms show "Q[<s>] \<leadsto><weakBisim> P[<s>]" by(force simp add: congruenceSubstDef)
qed

lemma unfoldI:
  fixes P :: pi
  and   Q :: pi

  assumes "\<forall>s. P[<s>] \<leadsto><weakBisim> Q[<s>] \<and> Q[<s>] \<leadsto><weakBisim> P[<s>]"

  shows "P \<simeq>\<^sup>s Q"
proof -
  from assms show ?thesis by(force simp add: congruenceSubstDef)
qed

lemma weakEqSubset:
  shows "substClosed congruence \<subseteq> weakBisim"
proof(auto simp add: substClosed_def)
  fix P Q
  assume "\<forall>s. P[<s>] \<simeq> Q[<s>]"
  hence "P[<[]>] \<simeq> Q[<[]>]" by blast
  thus "P \<approx> Q"
    by(force dest: congruenceWeakBisim intro: Weak_Late_Bisim.unfoldI)
qed

  assumes "P \<simeq>\<^sup>s Q"

  shows "P \<simeq> Q"
using assms
apply(auto simp add: substClosed_def congruenceSubst_def)
apply(erule_tac x="[]" in allE)
by auto

lemma eqvt:
  shows "eqvt (substClosed congruence)"
by(rule eqvtSubstClosed[OF Weak_Late_Cong.eqvt])

lemma eqvtI:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<simeq>\<^sup>s Q"

  shows "(perm \<bullet> P) \<simeq>\<^sup>s (perm \<bullet> Q)"
using assms
by(simp add: congruenceSubst_def) (rule eqvtRelI[OF eqvt])

lemma strongEqWeakCong:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "P \<simeq>\<^sup>s Q"
using assms
by(force intro: strongBisimWeakEq simp add: substClosed_def congruenceSubst_def)

lemma congSubstBisimSubst:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "P \<approx>\<^sup>s Q"
using assms
by(force simp add: congruenceSubst_def substClosed_def intro: congruenceWeakBisim)

lemma reflexive:
  fixes P :: pi

  shows "P \<simeq>\<^sup>s P"
proof -
  from Weak_Late_Bisim.reflexive have "\<And>P. P \<leadsto><weakBisim> P"
    by(blast intro: Weak_Late_Step_Sim.reflexive)
  thus ?thesis
    by(force simp add: congruenceSubstDef)
qed

lemma symetric:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq>\<^sup>s Q"

  shows "Q \<simeq>\<^sup>s P"
using assms
by(force simp add: congruenceSubstDef)

lemma partUnfold:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<simeq>\<^sup>s Q"

  shows "P[<s>] \<simeq>\<^sup>s Q[<s>]"
using assms
proof(auto simp add: congruenceSubst_def substClosed_def)
  fix s'
  assume "\<forall>s. (P[<s>], Q[<s>]) \<in> congruence"
  hence "(P[<(s@s')>], Q[<(s@s')>]) \<in> congruence" by blast
  moreover have "P[<(s@s')>] = (P[<s>])[<s'>]"
    by(induct s', auto)
  moreover have "Q[<(s@s')>] = (Q[<s>])[<s'>]"
    by(induct s', auto)

  ultimately show "((P[<s>])[<s'>], (Q[<s>])[<s'>]) \<in> congruence"
    by simp
qed

end


(*  Title:       Deriving class instances for datatypes
    Author:      Christian Sternagel and René Thiemann  <christian.sternagel|rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)
subsection \<open>Defining Comparators and Compare-Instances for Common Types\<close>

theory Compare_Instances
imports
  Compare_Generator
  "~~/src/HOL/Library/Char_ord"
begin

text \<open>For all of the following types, we define comparators and register them in the class
  @{class compare}:
  @{type int}, @{type integer}, @{type nibble}, @{type nat}, @{type char}, @{type bool}, @{type unit}, @{type sum}, @{type option}, @{type list},
  and @{type prod}. We do not register those classes in @{class compare_order} where
  so far no linear order is defined, in particular if there are conflicting orders, like pair-wise or
  lexicographic comparison on pairs.\<close>

text \<open>For @{type int}, @{type nat}, @{type integer}, @{type nibble}, and @{type char} we just use their linear orders as comparators.\<close>
derive (linorder) compare_order int integer nibble nat char

text \<open>For @{type sum}, @{type list}, @{type prod}, and @{type option} we generate comparators
  which are however are not used to instantiate @{class linorder}.\<close>
derive compare sum list prod option

text \<open>We do not use the linear order to define the comparator for @{typ bool} and @{typ unit},
  but implement more efficient ones.\<close>

fun comparator_unit :: "unit comparator" where
  "comparator_unit x y = Eq"

fun comparator_bool :: "bool comparator" where
  "comparator_bool False False = Eq"
| "comparator_bool False True = Lt"
| "comparator_bool True True = Eq"
| "comparator_bool True False = Gt"

lemma comparator_unit: "comparator comparator_unit"
  by (unfold_locales, auto)

lemma comparator_bool: "comparator comparator_bool"
proof
  fix x y z :: bool
  show "invert_order (comparator_bool x y) = comparator_bool y x" by (cases x, (cases y, auto)+)
  show "comparator_bool x y = Eq \<Longrightarrow> x = y" by (cases x, (cases y, auto)+)
  show "comparator_bool x y = Lt \<Longrightarrow> comparator_bool y z = Lt \<Longrightarrow> comparator_bool x z = Lt"
    by (cases x, (cases y, auto), cases y, (cases z, auto)+)
qed

local_setup {*
  Comparator_Generator.register_foreign_comparator @{typ unit}
    @{term comparator_unit}
    @{thm comparator_unit}
*}

local_setup {*
  Comparator_Generator.register_foreign_comparator @{typ bool}
    @{term comparator_bool}
    @{thm comparator_bool}
*}

derive compare bool unit

text \<open>It is not directly possible to @{text "derive (linorder) bool unit"}, since
  @{term "compare :: bool comparator"}
  was not defined as @{term "comparator_of :: bool comparator"}, but as
  @{const comparator_bool}.
  However, we can manually prove this equivalence
  and then use this knowledge to prove the instance of @{class compare_order}.\<close>

lemma comparator_bool_comparator_of [compare_simps]:
  "comparator_bool = comparator_of"
proof (intro ext)
  fix a b
  show "comparator_bool a b = comparator_of a b"
    unfolding comparator_of_def
    by (cases a, (cases b, auto))
qed

derive (linorder) compare_order bool unit
end


(*  Title:      HOL/ATP.thy
    Author:     Fabian Immler, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Author:     Martin Desharnais, UniBw Muenchen
*)

section \<open>Automatic Theorem Provers (ATPs)\<close>

theory ATP
  imports Meson
begin

subsection \<open>ATP problems and proofs\<close>

ML_file \<open>Tools/ATP/atp_util.ML\<close>
ML_file \<open>Tools/ATP/atp_problem.ML\<close>
ML_file \<open>Tools/ATP/atp_proof.ML\<close>
ML_file \<open>Tools/ATP/atp_proof_redirect.ML\<close>

subsection \<open>Higher-order reasoning helpers\<close>

definition fFalse :: bool where
"fFalse \<longleftrightarrow> False"

definition fTrue :: bool where
"fTrue \<longleftrightarrow> True"

definition fNot :: "bool \<Rightarrow> bool" where
"fNot P \<longleftrightarrow> \<not> P"

definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
"fComp P = (\<lambda>x. \<not> P x)"

definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fconj P Q \<longleftrightarrow> P \<and> Q"

definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fdisj P Q \<longleftrightarrow> P \<or> Q"

definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"fimplies P Q \<longleftrightarrow> (P \<longrightarrow> Q)"

definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
"fAll P \<longleftrightarrow> All P"

definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
"fEx P \<longleftrightarrow> Ex P"

definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
"fequal x y \<longleftrightarrow> (x = y)"

lemma fTrue_ne_fFalse: "fFalse \<noteq> fTrue"
unfolding fFalse_def fTrue_def by simp

lemma fNot_table:
"fNot fFalse = fTrue"
"fNot fTrue = fFalse"
unfolding fFalse_def fTrue_def fNot_def by auto

lemma fconj_table:
"fconj fFalse P = fFalse"
"fconj P fFalse = fFalse"
"fconj fTrue fTrue = fTrue"
unfolding fFalse_def fTrue_def fconj_def by auto

lemma fdisj_table:
"fdisj fTrue P = fTrue"
"fdisj P fTrue = fTrue"
"fdisj fFalse fFalse = fFalse"
unfolding fFalse_def fTrue_def fdisj_def by auto

lemma fimplies_table:
"fimplies P fTrue = fTrue"
"fimplies fFalse P = fTrue"
"fimplies fTrue fFalse = fFalse"
unfolding fFalse_def fTrue_def fimplies_def by auto

lemma fAll_table:
"Ex (fComp P) \<or> fAll P = fTrue"
"All P \<or> fAll P = fFalse"
unfolding fFalse_def fTrue_def fComp_def fAll_def by auto

lemma fEx_table:
"All (fComp P) \<or> fEx P = fTrue"
"Ex P \<or> fEx P = fFalse"
unfolding fFalse_def fTrue_def fComp_def fEx_def by auto

lemma fequal_table:
"fequal x x = fTrue"
"x = y \<or> fequal x y = fFalse"
unfolding fFalse_def fTrue_def fequal_def by auto

lemma fNot_law:
"fNot P \<noteq> P"
unfolding fNot_def by auto

lemma fComp_law:
"fComp P x \<longleftrightarrow> \<not> P x"
unfolding fComp_def ..

lemma fconj_laws:
"fconj P P \<longleftrightarrow> P"
"fconj P Q \<longleftrightarrow> fconj Q P"
"fNot (fconj P Q) \<longleftrightarrow> fdisj (fNot P) (fNot Q)"
unfolding fNot_def fconj_def fdisj_def by auto

lemma fdisj_laws:
"fdisj P P \<longleftrightarrow> P"
"fdisj P Q \<longleftrightarrow> fdisj Q P"
"fNot (fdisj P Q) \<longleftrightarrow> fconj (fNot P) (fNot Q)"
unfolding fNot_def fconj_def fdisj_def by auto

lemma fimplies_laws:
"fimplies P Q \<longleftrightarrow> fdisj (\<not> P) Q"
"fNot (fimplies P Q) \<longleftrightarrow> fconj P (fNot Q)"
unfolding fNot_def fconj_def fdisj_def fimplies_def by auto

lemma fAll_law:
"fNot (fAll R) \<longleftrightarrow> fEx (fComp R)"
unfolding fNot_def fComp_def fAll_def fEx_def by auto

lemma fEx_law:
"fNot (fEx R) \<longleftrightarrow> fAll (fComp R)"
unfolding fNot_def fComp_def fAll_def fEx_def by auto

lemma fequal_laws:
"fequal x y = fequal y x"
"fequal x y = fFalse \<or> fequal y z = fFalse \<or> fequal x z = fTrue"
"fequal x y = fFalse \<or> fequal (f x) (f y) = fTrue"
unfolding fFalse_def fTrue_def fequal_def by auto

subsection \<open>Basic connection between ATPs and HOL\<close>

ML_file \<open>Tools/lambda_lifting.ML\<close>
ML_file \<open>Tools/monomorph.ML\<close>
ML_file \<open>Tools/ATP/atp_problem_generate.ML\<close>
ML_file \<open>Tools/ATP/atp_proof_reconstruct.ML\<close>

end


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

ML "Header.initialize
    [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
     \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
     \"notNot1\", \"notNot2\", \"EqualTDef\", \"EqualSymDef\",
     \"EqualReflex\", \"EqualTransT\", \"DiffDef\", \"EqualPrefixDef\",
     \"DiffPrefixDef\", \"IBE3\", \"DiffSymDef\", \"DiffTDef\",
     \"DiffFDef\", \"TE1\", \"TE2\", \"TE3\", \"TE4\", \"IBE1\",
     \"IBE2\", \"IBE4\", \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\",
     \"IUE1\", \"IUE2\"]"

typedecl Unit

datatype Bool = X_False ("False''") | X_True ("True''")

consts
Not__X :: "Bool => Bool" ("(Not''/ _)" [56] 56)
XLtXEqXEqXGt :: "'a => 'a => Bool"
XLtXSlashXEqXGt :: "'a => 'a => Bool"
X__XAmpXAmp__X :: "Bool => Bool => Bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a => 'a => Bool" ("(_/ ==''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a => 'a => Bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "Bool => Bool => Bool" ("(_/ ||/ _)" [54,54] 52)
otherwiseH :: "Bool"

axioms
NotFalse [rule_format] : "Not' False' = True'"

NotTrue [rule_format] : "Not' True' = False'"

AndFalse [rule_format] : "ALL x. False' && x = False'"

AndTrue [rule_format] : "ALL x. True' && x = x"

AndSym [rule_format] : "ALL x. ALL y. x && y = y && x"

OrDef [rule_format] :
"ALL x. ALL y. x || y = Not' (Not' x && Not' y)"

OtherwiseDef [rule_format] : "otherwiseH = True'"

NotFalse1 [rule_format] : "ALL x. Not' x = True' = (x = False')"

NotTrue1 [rule_format] : "ALL x. Not' x = False' = (x = True')"

notNot1 [rule_format] : "ALL x. (~ x = True') = (Not' x = True')"

notNot2 [rule_format] : "ALL x. (~ x = False') = (Not' x = False')"

EqualTDef [rule_format] : "ALL x. ALL y. x = y --> x ==' y = True'"

EqualSymDef [rule_format] : "ALL x. ALL y. x ==' y = y ==' x"

EqualReflex [rule_format] : "ALL x. x ==' x = True'"

EqualTransT [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & y ==' z = True' --> x ==' z = True'"

DiffDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

EqualPrefixDef [rule_format] :
"ALL x. ALL y. XLtXEqXEqXGt x y = x ==' y"

DiffPrefixDef [rule_format] :
"ALL x. ALL y. XLtXSlashXEqXGt x y = x /= y"

IBE3 [rule_format] : "False' ==' True' = False'"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare EqualReflex [simp]
declare IBE3 [simp]

theorem DiffSymDef : "ALL x. ALL y. x /= y = y /= x"
apply(auto)
apply(simp add: DiffDef)
apply(simp add: EqualSymDef)
done

ML "Header.record \"DiffSymDef\""

theorem DiffTDef :
"ALL x. ALL y. x /= y = True' = (Not' (x ==' y) = True')"
apply(auto)
apply(simp add: DiffDef)
apply(case_tac "x ==' y")
apply(auto)
apply(simp add: DiffDef)
done

ML "Header.record \"DiffTDef\""

theorem DiffFDef :
"ALL x. ALL y. x /= y = False' = (x ==' y = True')"
apply(auto)
apply(simp add: DiffDef)
apply(case_tac "x ==' y")
apply(auto)
apply(simp add: DiffDef)
done

ML "Header.record \"DiffFDef\""

theorem TE1 : "ALL x. ALL y. x ==' y = False' --> ~ x = y"
by (auto)

ML "Header.record \"TE1\""

theorem TE2 :
"ALL x. ALL y. Not' (x ==' y) = True' = (x ==' y = False')"
apply auto
apply(case_tac "x ==' y")
apply auto
done

ML "Header.record \"TE2\""

theorem TE3 :
"ALL x. ALL y. Not' (x ==' y) = False' = (x ==' y = True')"
apply(auto)
apply(case_tac "x ==' y")
apply auto
done

ML "Header.record \"TE3\""

theorem TE4 :
"ALL x. ALL y. (~ x ==' y = True') = (x ==' y = False')"
apply auto
apply(case_tac "x ==' y")
apply auto
done

ML "Header.record \"TE4\""

theorem IBE1 : "True' ==' True' = True'"
by (auto)

ML "Header.record \"IBE1\""

theorem IBE2 : "False' ==' False' = True'"
by (auto)

ML "Header.record \"IBE2\""

theorem IBE4 : "True' ==' False' = False'"
apply(simp add: EqualSymDef)
done

ML "Header.record \"IBE4\""

theorem IBE5 : "True' /= False' = True'"
apply(simp add: DiffDef)
apply(simp add: IBE4)
done

ML "Header.record \"IBE5\""

theorem IBE6 : "False' /= True' = True'"
apply(simp add: DiffDef)
done

ML "Header.record \"IBE6\""

theorem IBE7 : "Not' (True' ==' False') = True'"
apply(simp add: IBE4)
done

ML "Header.record \"IBE7\""

theorem IBE8 : "Not' Not' (True' ==' False') = False'"
apply(simp add: IBE4)
done

ML "Header.record \"IBE8\""

theorem IUE1 : "() ==' () = True'"
by (auto)

ML "Header.record \"IUE1\""

theorem IUE2 : "() /= () = False'"
apply(simp add: DiffDef)
done

ML "Header.record \"IUE2\""

end


theory Order_Relations_From_Priorities
  imports
    Order_Relations
    Treaps.Random_List_Permutation
begin

subsection \<open>Unweighted Case\<close>
lemma preorder_on_linorder_from_keys[intro]: "preorder_on A (linorder_from_keys A f)"
  unfolding linorder_from_keys_def preorder_on_def
  by (auto simp: refl_on_def trans_def total_on_def)

lemma linorder_from_keys_in_preorders_on[intro]: "linorder_from_keys A f \<in> preorders_on A"
  by auto

lemma linorder_from_keys_lessI:
  assumes "f i < f j"
  assumes "i \<in> A" "j \<in> A"
  shows "(i,j) \<in> linorder_from_keys A f \<and> (j,i) \<notin> linorder_from_keys A f"
  using assms
  unfolding linorder_from_keys_def
  by auto

lemma linorder_from_keys_Restr:
  shows "Restr (linorder_from_keys A f) (A - B) = linorder_from_keys (A - B) f"
  unfolding linorder_from_keys_def
  by blast

lemma linorder_from_keys_update_eq:
  shows "linorder_from_keys (A - {a}) (f(a:=x)) = linorder_from_keys (A - {a}) f"
  unfolding linorder_from_keys_def
  by auto

text \<open>Generalize @{thm measurable_linorder_from_keys_restrict} by Eberl from
 \<^term>\<open>count_space (Pow (A \<times> A))\<close> to \<^term>\<open>count_space (preorders_on A)\<close>. The original
  statement then also follows with @{thm measurable_count_space_extend}.\<close>
lemma measurable_linorder_from_keys_restrict_preorders[measurable]:
  assumes fin: "finite A"
  shows "linorder_from_keys A \<in> Pi\<^sub>M A (\<lambda>_. borel :: real measure) \<rightarrow>\<^sub>M count_space (preorders_on A)"
  (is "_ : ?M \<rightarrow>\<^sub>M _")
  apply (subst measurable_count_space_eq2)
   apply (auto simp: fin)
proof -
  note fin[simp]
  fix r assume "r \<in> preorders_on A"
  then have "linorder_from_keys A -` {r} \<inter> space ?M =
    {f \<in> space ?M. \<forall>x\<in>A. \<forall>y\<in>A. (x,y) \<in> r \<longleftrightarrow> f x \<le> f y}"
    by (auto simp: linorder_from_keys_def preorder_on_def set_eq_iff dest!: preorders_onD refl_on_domain)

  also have "\<dots> \<in> sets ?M"
    by measurable

  finally show "linorder_from_keys A -` {r} \<inter> space ?M \<in> sets ?M" .
qed

lemma linorder_on_linorder_from_keys_insert:
  assumes linorder: "linorder_on A (linorder_from_keys A f)"
  assumes "y \<notin> f ` A"
  assumes "a \<notin> A"
  shows "linorder_on (insert a A) (linorder_from_keys (insert a A) (f(a:=y)))"
proof -
  from \<open>a \<notin> A\<close> have linorder_from_insert: "linorder_from_keys (insert a A) (f(a:=y)) = linorder_from_keys A f \<union> {(a,a)} \<union> {(a,b) | b. b \<in> A \<and> y \<le> f b} \<union> {(b,a) | b. b \<in> A \<and> f b \<le> y}"
    unfolding linorder_from_keys_def
    by (auto split: if_splits)

  show "linorder_on (insert a A) (linorder_from_keys (insert a A) (f(a:=y)))"
    unfolding linorder_on_def
  proof (intro conjI, goal_cases)
    case 1
    with linorder show ?case
      by (subst linorder_from_insert)
         (auto simp: linorder_on_def refl_on_def)
  next
    case 2
    with linorder \<open>a \<notin> A\<close> \<open>y \<notin> f ` A\<close> show ?case
      by (subst linorder_from_insert)
         (auto simp: linorder_on_def antisym_def dest: refl_on_domain)
  next
    case 3
    with linorder \<open>a \<notin> A\<close> \<open>y \<notin> f ` A\<close> show ?case
      by (subst linorder_from_insert, unfold trans_def)
         (auto simp: linorder_from_keys_def linorder_on_def)
  next
    case 4
    with linorder show ?case
      by (subst linorder_from_insert, unfold linorder_on_def total_on_def)
         auto
  qed
qed

text \<open>Adapted from @{thm almost_everywhere_linorder}\<close>
lemma almost_everywhere_linorder_preorders:
  fixes a b :: real
  assumes fin: "finite A" and ab: "a < b"
  defines "M \<equiv> distr (\<Pi>\<^sub>M i \<in> A. uniform_measure lborel {a..b}) (count_space (preorders_on A)) (linorder_from_keys A)"
  shows "AE R in M. linorder_on A R"
proof -
  define N where "N = PiM A (\<lambda>_. uniform_measure lborel {a..b})"
  have [simp]: "sets (Pi\<^sub>M A (\<lambda>_. uniform_measure lborel {a..b})) = sets (PiM A (\<lambda>_. lborel))"
    by (intro sets_PiM_cong) simp_all
  let ?M_A = "(Pi\<^sub>M A (\<lambda>_. lborel :: real measure))"
  have meas: "{h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h j} \<in> sets ?M_A"
    if [simp]: "i \<in> A" "j \<in> A" for i j
  proof -
    have "{h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h j} = {h \<in> space ?M_A. h i = h j}"
      by (auto simp: space_PiM)
    also have "... \<in> sets ?M_A"
      by measurable
    finally show ?thesis .
  qed
  define X :: "('a \<Rightarrow> real) set" where "X = (\<Union>x\<in>A. \<Union>y\<in>A-{x}. {h\<in>A \<rightarrow>\<^sub>E UNIV. h x = h y})"
  have "AE f in N. inj_on f A"
  proof (rule AE_I)
    show "{f \<in> space N. \<not> inj_on f A} \<subseteq> X"
      by (auto simp: inj_on_def X_def space_PiM N_def)
  next
    show "X \<in> sets N" unfolding X_def N_def
      using meas by (auto intro!: countable_finite fin sets.countable_UN')
  next
    have "emeasure N X \<le> (\<Sum>i\<in>A. emeasure N (\<Union>y\<in>A - {i}. {h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h y}))"
      unfolding X_def N_def using fin meas
      by (intro emeasure_subadditive_finite)
         (auto simp: disjoint_family_on_def intro!: sets.countable_UN' countable_finite)
    also have "\<dots> \<le> (\<Sum>i\<in>A. \<Sum>j\<in>A-{i}. emeasure N {h \<in> A \<rightarrow>\<^sub>E UNIV. h i = h j})"
      unfolding N_def using fin meas
      by (intro emeasure_subadditive_finite sum_mono)
         (auto simp: disjoint_family_on_def intro!: sets.countable_UN' countable_finite)
    also have "\<dots> = (\<Sum>i\<in>A. \<Sum>j\<in>A-{i}. 0)" unfolding N_def using fin ab
      by (intro sum.cong refl emeasure_PiM_diagonal) auto
    also have "\<dots> = 0" by simp
    finally show "emeasure N X = 0" by simp
  qed
  hence "AE f in N. linorder_on A (linorder_from_keys A f)"
    by eventually_elim auto
  with fin show ?thesis unfolding M_def N_def
    by (subst AE_distr_iff) auto
qed

text \<open>Adapted from @{thm random_linorder_by_prios}\<close>
lemma random_linorder_by_prios_preorders:
  fixes a b :: real
  assumes fin: "finite A" and ab: "a < b"
  defines "M \<equiv> distr (\<Pi>\<^sub>M i \<in> A. uniform_measure lborel {a..b}) (count_space (preorders_on A)) (linorder_from_keys A)"
  shows
  "M = uniform_measure (count_space (preorders_on A)) (linorders_on A)"
proof -
  from linorders_finite_nonempty[OF fin] obtain R where R: "linorder_on A R"
    by (auto simp: linorders_on_def)

  have *: "emeasure M {R} \<le> emeasure M {R'}" if "linorder_on A R" "linorder_on A R'" for R R'
  proof -
    define N where "N = PiM A (\<lambda>_. uniform_measure lborel {a..b})"
    from linorder_permutation_exists[OF fin that]
    obtain \<pi> where \<pi>: "\<pi> permutes A" "R' = map_relation A \<pi> R"
      by blast
    have "(\<lambda>f. f \<circ> \<pi>) \<in> Pi\<^sub>M A (\<lambda>_. lborel :: real measure) \<rightarrow>\<^sub>M Pi\<^sub>M A (\<lambda>_. lborel :: real measure)"
      by (auto intro!: measurable_PiM_single' measurable_PiM_component_rev
          simp: comp_def permutes_in_image[OF \<pi>(1)] space_PiM PiE_def extensional_def)
    also have "\<dots> = N \<rightarrow>\<^sub>M Pi\<^sub>M A (\<lambda>_. lborel)"
      unfolding N_def by (intro measurable_cong_sets refl sets_PiM_cong) simp_all
    finally have [measurable]: "(\<lambda>f. f \<circ> \<pi>) \<in> \<dots>" .

    have [simp]: "measurable N X = measurable (PiM A (\<lambda>_. lborel)) X" for X :: "('a \<times> 'a) set measure"
      unfolding N_def by (intro measurable_cong_sets refl sets_PiM_cong) simp_all
    have [simp]: "measurable M X = measurable (count_space (preorders_on A)) X" for X :: "('a \<times> 'a) set measure"
      unfolding M_def by simp

    have M_eq: "M = distr N (count_space (preorders_on A)) (linorder_from_keys A)"
      by (simp only: M_def N_def)
    also have "N = distr N (PiM A (\<lambda>_. lborel)) (\<lambda>f. f \<circ> \<pi>)"
      unfolding N_def by (rule PiM_uniform_measure_permute [symmetric]) fact+
    also have "distr \<dots> (count_space (preorders_on A)) (linorder_from_keys A) =
                 distr N (count_space (preorders_on A)) (linorder_from_keys A \<circ> (\<lambda>f. f \<circ> \<pi>))"
      using fin
      by (intro distr_distr) measurable
    also have "\<dots> = distr N (count_space (preorders_on A)) (map_relation A \<pi> \<circ> linorder_from_keys A)"
      by (intro distr_cong refl) (auto simp: linorder_from_keys_permute[OF \<pi>(1)])
    also have "\<dots> = distr M (count_space (preorders_on A)) (map_relation A \<pi>)"
      unfolding M_eq
      using fin \<pi>
      by (intro distr_distr [symmetric])
         (auto simp: map_relation_def intro!: preorder_on_permutes preorders_onI dest!: preorders_onD)
    finally have M_eq': "distr M (count_space (preorders_on A)) (map_relation A \<pi>) = M" ..

    from that have preorder: "R \<in> preorders_on A" "R' \<in> preorders_on A"
      by (auto dest: linorder_on_imp_preorder_on)
    hence "emeasure M {R} \<le> emeasure M (map_relation A \<pi> -` {R'} \<inter> space M)"
      using preorder by (intro emeasure_mono) (auto simp: M_def \<pi> )
    also have "\<dots> = emeasure (distr M (count_space (preorders_on A)) (map_relation A \<pi>)) {R'} "
      by (rule emeasure_distr [symmetric])
         (use preorder \<pi> in \<open>auto simp: map_relation_def intro!: preorders_onI preorder_on_permutes dest: preorders_onD\<close>)
    also note M_eq'
    finally show ?thesis .
  qed
  have same_prob: "emeasure M {R'} = emeasure M {R}" if "linorder_on A R'" for R'
    using *[of R R'] and *[of R' R] and R and that by simp

  from ab fin have "prob_space M"
    unfolding M_def
    by (intro prob_space.prob_space_distr prob_space_PiM prob_space_uniform_measure) simp_all
  hence "1 = emeasure M (preorders_on A)"
    using prob_space.emeasure_space_1[OF \<open>prob_space M\<close>] by (simp add: M_def)
  also have "preorders_on A  = linorders_on A \<union> ((preorders_on A)-linorders_on A)"
    by (auto simp: linorders_on_def linorder_on_def refl_on_def preorders_on_def preorder_on_def)
  also have "emeasure M \<dots> = emeasure M (linorders_on A) + emeasure M ((preorders_on A)-linorders_on A)"
    by (subst plus_emeasure) (auto simp: M_def linorders_on_def linorder_on_def refl_on_def preorders_on_def preorder_on_def)
  also have "emeasure M ((preorders_on A)-linorders_on A) = 0" using almost_everywhere_linorder_preorders[OF fin ab]
    by (subst (asm) AE_iff_measurable) (auto simp: linorders_on_def M_def)
  also from fin have "emeasure M (linorders_on A) = (\<Sum>R'\<in>linorders_on A. emeasure M {R'})"
    by (intro emeasure_eq_sum_singleton)
       (auto simp: M_def  linorders_on_def linorder_on_def refl_on_def preorders_on_def preorder_on_def)
  also have "\<dots> = (\<Sum>R'\<in>linorders_on A. emeasure M {R})"
    by (rule sum.cong) (simp_all add: linorders_on_def same_prob)
  also from fin have "\<dots> = fact (card A) * emeasure M {R}"
    by (simp add: linorders_on_def card_finite_linorders)
  finally have [simp]: "emeasure M {R} = inverse (fact (card A))"
    by (simp add: inverse_ennreal_unique)

  show ?thesis
  proof (rule measure_eqI_countable_AE')
    show "sets M = Pow (preorders_on A)"
      by (simp add: M_def)
  next
    from \<open>finite A\<close> show "countable (linorders_on A)"
      by (blast intro: countable_finite)
  next
    show "AE R in uniform_measure (count_space (preorders_on A))
            (linorders_on A). R \<in> linorders_on A"
      by (rule AE_uniform_measureI)
         (auto simp: linorders_on_def preorders_on_def dest: linorder_on_imp_preorder_on)
  next
    fix R' assume R': "R' \<in> linorders_on A"
    have subset: "linorders_on A \<subseteq> preorders_on A"
      by (auto simp: linorders_on_def preorders_on_def dest: linorder_on_imp_preorder_on)
    have "emeasure (uniform_measure (count_space (preorders_on A))
           (linorders_on A)) {R'} = emeasure (count_space (preorders_on A)) (linorders_on A \<inter> {R'}) /
                                      emeasure (count_space (preorders_on A)) (linorders_on A)"
      using R' by (subst emeasure_uniform_measure) (auto simp: linorders_on_def preorders_on_def dest: linorder_on_imp_preorder_on)
    also have "\<dots> = 1 / emeasure (count_space (preorders_on A)) (linorders_on A)"
      using R' by (subst emeasure_count_space) (auto simp: linorders_on_def preorders_on_def dest: linorder_on_imp_preorder_on)
    also have "\<dots> = 1 / fact (card A)"
      using fin finite_linorders_on[of A]
      by (subst emeasure_count_space [OF subset])
         (auto simp: divide_ennreal [symmetric] linorders_on_def card_finite_linorders)
    also have "\<dots> = emeasure M {R}"
      by (simp add: field_simps divide_ennreal_def)
    also have "\<dots> = emeasure M {R'}"
      using R' by (intro same_prob [symmetric]) (auto simp: linorders_on_def)
    finally show "emeasure M {R'} = emeasure (uniform_measure (count_space (preorders_on A))
                    (linorders_on A)) {R'}" ..
  next
    show "linorders_on A \<subseteq> preorders_on A"
      by (auto simp: linorders_on_def preorders_on_def dest: linorder_on_imp_preorder_on)
  next
    show "AE r in M. r \<in> linorders_on A"
      unfolding M_def
      using almost_everywhere_linorder_preorders[OF fin ab]
      by (auto simp: linorders_on_def)
  qed simp
qed

subsection \<open>Weighted Case\<close>
definition weighted_linorder_from_keys :: "'a set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> (real \<Rightarrow> real) \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> ('a \<times> 'a) set" where
  "weighted_linorder_from_keys A v g Y \<equiv> {(x, y) \<in> A \<times> A. v x * (1 - g (Y x)) \<ge> v y * (1 - g (Y y))}"

lemma preorder_on_weighted_linorder_from_keys[intro]: "preorder_on A (weighted_linorder_from_keys A v g f)"
  unfolding weighted_linorder_from_keys_def preorder_on_def
  by (auto simp: refl_on_def trans_def total_on_def)

lemma weighted_linorder_from_keys_in_preorders_on[intro]: "weighted_linorder_from_keys A v g f \<in> preorders_on A"
  by auto

lemma measurable_weighted_linorder_from_keys[measurable]:
  assumes fin: "finite A"
  assumes "g \<in> borel_measurable borel"
  shows "weighted_linorder_from_keys A v g \<in> PiM A (\<lambda>_. borel :: real measure) \<rightarrow>\<^sub>M count_space (preorders_on A)"
  (is "_ \<in> ?M \<rightarrow>\<^sub>M _")
  apply (subst measurable_count_space_eq2)
   apply (auto simp: fin)
proof -
  note fin[simp]
  fix r assume "r \<in> preorders_on A"
  then have "weighted_linorder_from_keys A v g -` {r} \<inter> space ?M =
    {f \<in> space ?M. \<forall>x\<in>A. \<forall>y\<in>A. (x,y) \<in> r \<longleftrightarrow> v x * (1 - g(f x)) \<ge> v y * (1 - g(f y))}"
    by (auto simp: weighted_linorder_from_keys_def preorder_on_def set_eq_iff dest!: preorders_onD refl_on_domain)

  also from assms have "\<dots> \<in> sets ?M"
    by measurable

  finally show "weighted_linorder_from_keys A v g -` {r} \<inter> space ?M \<in> sets ?M" .
qed

lemma weighted_linorder_from_keys_fun_upd_eq:
  assumes "a \<notin> A"
  shows "weighted_linorder_from_keys A v g (f(a:=x)) = weighted_linorder_from_keys A v g f"
  using assms
  unfolding weighted_linorder_from_keys_def
  by auto

lemma weighted_linorder_from_keys_Restr:
  shows "Restr (weighted_linorder_from_keys A v g f) (A - B) = weighted_linorder_from_keys (A - B) v g f"
  unfolding weighted_linorder_from_keys_def
  by blast

lemma weighted_linorder_from_keys_update_eq:
  shows "weighted_linorder_from_keys (A - {a}) v g (f(a:=x)) = weighted_linorder_from_keys (A - {a}) v g f"
  unfolding weighted_linorder_from_keys_def
  by auto

lemma weighted_linorder_from_keys_lessI:
  assumes "v i * (1 - g (f i)) > v j * (1 - g (f j))"
  assumes "i \<in> A" "j \<in> A"
  shows "(i,j) \<in> weighted_linorder_from_keys A v g f \<and> (j,i) \<notin> weighted_linorder_from_keys A v g f"
  using assms
  unfolding weighted_linorder_from_keys_def
  by auto

lemma linorder_on_weighted_linorder_from_keys[intro]:
  assumes "inj_on (\<lambda>a. v a * (1 - g (f a))) A"
  shows "linorder_on A (weighted_linorder_from_keys A v g f)"
  using assms
  by (auto simp: linorder_on_def refl_on_def antisym_def weighted_linorder_from_keys_def trans_def total_on_def
           dest: inj_onD)

lemma linorder_on_weighted_linorder_from_keys_insert:
  assumes linorder: "linorder_on A (weighted_linorder_from_keys A v g f)"
  assumes no_collision: "y \<notin> {y | y i. i \<in> A \<and> v a * (1 - g y) = v i * (1 - g (f i))}"
  assumes "a \<notin> A"
  shows "linorder_on (insert a A) (weighted_linorder_from_keys (insert a A) v g (f(a:=y)))"
proof -
  from \<open>a \<notin> A\<close> have linorder_from_insert: "weighted_linorder_from_keys (insert a A) v g (f(a:=y)) =
    weighted_linorder_from_keys A v g f \<union> {(a,a)} \<union> {(a,b) | b. b \<in> A \<and> v a * (1 - g y) \<ge> v b * (1 - g (f b))} \<union> {(b,a) | b. b \<in> A \<and> v b * (1 - g (f b)) \<ge> v a * (1 - g y)}"
    unfolding weighted_linorder_from_keys_def
    by (auto split: if_splits)

  show "linorder_on (insert a A) (weighted_linorder_from_keys (insert a A) v g (f(a:=y)))"
    unfolding linorder_on_def
  proof (intro conjI, goal_cases)
    case 1
    with linorder show ?case
      by (subst linorder_from_insert)
         (auto simp: linorder_on_def refl_on_def)
  next
    case 2
    with linorder no_collision \<open>a \<notin> A\<close> show ?case
      by (subst linorder_from_insert)
         (auto simp: linorder_on_def antisym_def dest: refl_on_domain)
  next
    case 3
    with linorder no_collision \<open>a \<notin> A\<close> show ?case
      by (subst linorder_from_insert, unfold trans_def)
         (auto simp: weighted_linorder_from_keys_def linorder_on_def)
  next
    case 4
    with linorder show ?case
      by (subst linorder_from_insert, unfold linorder_on_def total_on_def)
         auto
  qed
qed

end


header "Global Specifications"
theory Global_Specification
imports RMD

begin

text {* SPARK has only one integer-type, therefore type-conversions
  are needed in order to specify the proof-functions in Isabelle. *}

subsection {* Specification of Bit-Operations *}

text {* The proof-functions for SPARK's bit-opertations are specified
with HOL-Word *}

abbreviation bit__and' :: "int => int => int" where
  "bit__and' m n == uint ((word_of_int m::word32) AND word_of_int n)"

abbreviation bit__or' :: "int => int => int" where
  "bit__or' m n == uint ((word_of_int m::word32) OR word_of_int n)"

abbreviation bit__xor' :: "int => int => int" where
  "bit__xor' m n == uint ((word_of_int m::word32) XOR word_of_int n)"

abbreviation rotate_left' :: "int => int => int" where
  "rotate_left' i w == uint (word_rotl (nat i) (word_of_int w::word32))"

text{* This is how SPARK treats the bitwise not *}

lemma bit_not_spark_def[simp]:
  "(word_of_int (4294967295 - x)::word32) = NOT (word_of_int x)"
proof -
  have "word_of_int x + (word_of_int (4294967295 - x)::word32) =
          word_of_int x + NOT (word_of_int x)"
    by (simp only: bwsimps bin_add_not Min_def) simp
  thus ?thesis by (simp only: add_left_imp_eq)
qed

subsection{* Conversions for proof functions *}

text{* Here, the proof-functions declared in the SPARK-Annotations are
  mapped to the corresponding parts of the Isabelle-Specification. *}

abbreviation k_l' :: "int => int" where
  "k_l' j == uint (K (nat j))"
abbreviation k_r' :: "int => int" where
  "k_r' j == uint (K' (nat j))"
abbreviation r_l' :: "int => int" where
  "r_l' j == int (r (nat j))"
abbreviation r_r' :: "int => int" where
  "r_r' j == int (r' (nat j))"
abbreviation s_l' :: "int => int" where
  "s_l' j == int (s (nat j))"
abbreviation s_r' :: "int => int" where
  "s_r' j == int (s' (nat j))"
abbreviation f' :: "int => int => int => int => int" where
  "f' j x y z ==
    uint (f (nat j) (word_of_int x::word32) (word_of_int y) (word_of_int z))"

end


section \<open>Real-Valued random variables \label{sec:realrandvar}\<close>

theory RealRandVar
imports Measure "HOL-Library.Countable"
begin

text \<open>While most of the above material was modeled after Hurd's work
  (but still proved independently),
  the original content basically starts here\footnote{There are two
  main reasons why the above has not been imported using Sebastian
Skalberg's import tool \<^cite>\<open>"Skalberg"\<close>. Firstly, there are
  inconveniences caused by different conventions in HOL, meaning
  predicates instead of sets foremost, that make the consistent use of
  such basic definitions impractical. What is more, the import tool
  simply was not available at the time these theories were
  written.}. From now
  on, we will specialize in functions that map into
  the real numbers and are measurable with respect to the canonical sigma
  algebra on the reals, the Borel sigma algebra. These functions will
  be called real-valued random variables. The terminology is slightly
  imprecise, as random variables hint at a probability space, which
  usually requires \<open>measure M UNIV = 1\<close>. Notwithstanding, as we regard
  only finite measures (cf. \ref{sec:measure-spaces}), this condition can
  easily be achieved by normalization. After all, the other standard
  name, ``measurable functions'', is even less precise.

  A lot of the theory in this and the preceding section has also been
  formalized within the Mizar project \<^cite>\<open>"mesfunc1" and "mesfunc2"\<close>. The
  abstract of the second source hints that it was also planned as a
  stepping stone for Lebesgue integration, though further results in
  this line could not be found. The main difference lies in the use of
  extended real numbers --- the reals together with \<open>\<plusminus>\<infinity>\<close> --- in
  those documents. It is established practice in measure theory
  to allow infinite values, but ``($\ldots$) we felt that the complications
  that this generated ($\ldots$) more than canceled out the gain in
  uniformity ($\ldots$), and that a simpler theory resulted from sticking to
  the standard real numbers.'' \<^cite>\<open>\<open>p.~32f\<close> in "hurd2002"\<close>. Hurd also advocates
  going directly to the hyper-reals, should the need for infinite
  measures arise. I agree, nevertheless sticking to his example for the reasons
  mentioned in the prologue.\<close>

(*First of all, for the definition of a real valued random variable,
we need the Borel-\<sigma>-Algebra on the Reals*)
(*The smallest \<sigma>-Algebra containing {..u} for all rational u is
  sufficient, but we use all real u for simplicity!*)

definition
  Borelsets:: "real set set" ("\<bool>") where
  "\<bool> = sigma {S. \<exists>u. S={..u}}"

definition
(*We use Joe Hurd's formalism of a measure space (which assumes that
  the universe is always the whole type universe)*)
  rv:: "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> ('a \<Rightarrow> real) set" where
  "rv M = {f. measure_space M \<and> f \<in> measurable (measurable_sets M) \<bool>}"

text \<open>As explained in the first paragraph, the preceding
  definitions\footnote{The notation $\<open>{..u}\<close>$ signifies the
  interval from negative infinity to $u$ included.}
  determine the rest of this section. There are many ways to define
  the Borel sets. For example, taking into account only rationals for
  $u$ would also have worked out above, but we can take the reals to
  simplify things. The smallest sigma algebra containing all the open
  (or closed) sets is another alternative; the multitude of
  possibilities testifies to the relevance of the concept.

  The latter path leads the way to the fact that any continuous function is
  measurable. Generalization for $\<open>\<real>\<close>^n$ brings another unified way to
  prove all the measurability theorems in this theory plus, for instance,
  measurability of the trigonometric and exponential functions. This approach is detailed in another influential textbook
  by Billingsley \<^cite>\<open>"Billingsley86"\<close>. It requires some concepts of
  topologic spaces, which made the following elementary
  course, based on Bauer's excellent book \<^cite>\<open>"Bauer"\<close>, seem more feasible.

  Two more definitions go next. The image measure, law, or
  distribution --- the last term being specific to probability --- of a
  measure with respect to a measurable function is calculated as the measure of the
  inverse image of a set. Characteristic functions will
  be frequently needed in the rest of the development.
\<close>
(*Perhaps one day we will need distributions, this might be the right
time to define them*)

definition
  distribution::
  "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> (real set \<Rightarrow> real)" ("law") where
  "f \<in> rv M \<Longrightarrow> law M f \<equiv> (measure M) \<circ> (vimage f)"

definition
  characteristic_function:: "'a set \<Rightarrow> ('a \<Rightarrow> real)" ("\<chi> _"(*<*)[1000](*>*)) where
  "\<chi> A x \<equiv> if x \<in> A then 1 else 0"

lemma char_empty: "\<chi> {} = (\<lambda>t. 0)"
proof (rule ext)
  fix t
  show "\<chi> {} t = 0" by (simp add: characteristic_function_def)
qed

text \<open>Now that random variables are defined, we aim to show that a
  broad class of functions belongs to them. For a constant function
  this is easy, as there are only two possible preimages.\<close>
  (*measurability lemmata*)

lemma assumes sigma: "sigma_algebra S"
  shows const_measurable: "(\<lambda>x. (c::real)) \<in> measurable S X"
proof (unfold measurable_def, rule, rule)
  fix g
  show "(\<lambda>x. c) -` g \<in> S"
  proof (cases "c \<in> g")
    case True
    hence "(\<lambda>x::'a. c) -` g = UNIV"
      by blast
    moreover from sigma have "UNIV \<in> S"
      by (rule sigma_algebra_UNIV)
    ultimately show ?thesis by simp
  next
    case False
    hence "(\<lambda>x::'a. c) -` g = {}"
      by blast
    moreover from sigma have "{} \<in> S"
      by (simp only: sigma_algebra_def)
    ultimately show ?thesis by simp
    txt\<open>\nopagebreak\<close>
  qed
qed

theorem assumes ms: "measure_space M"
  shows const_rv: "(\<lambda>x. c) \<in> rv M" using ms
  by (auto simp only: measure_space_def const_measurable rv_def)

text\<open>Characteristic functions produce four cases already, so the
  details are glossed over.\<close>

lemma assumes a: "a \<in> S" and sigma: "sigma_algebra S" shows
char_measurable : "\<chi> a \<in> measurable S x"
(*<*)proof -
  {fix g
    have "\<chi> a -` g \<in> S"
    proof (cases "1 \<in> g")
      case True
      show ?thesis
      proof (cases "0 \<in> g")
        case True
        with \<open>1 \<in> g\<close> have "\<chi> a -` g = UNIV" by (auto simp add: vimage_def characteristic_function_def)
        with sigma show ?thesis by (auto simp add: sigma_algebra_UNIV)
      next
        case False
        with \<open>1 \<in> g\<close> have "\<chi> a -` g = a"
          by (auto simp add: vimage_def characteristic_function_def)
        with a show ?thesis by simp
      qed

    next
      case False
      show ?thesis
      proof (cases "0 \<in> g")
        case True
        with \<open>1 \<notin> g\<close> have "\<chi> a -` g = -a"
          by (auto simp add: vimage_def characteristic_function_def)
        with a sigma show ?thesis by (simp add: sigma_algebra_def)
      next
        case False
        with \<open>1 \<notin> g\<close> have "\<chi> a -` g = {}" by (auto simp add: vimage_def characteristic_function_def)
        moreover from sigma have "{} \<in> S" by  (simp only: sigma_algebra_def)
        ultimately show ?thesis by simp
      qed
    qed}
  thus ?thesis by (unfold measurable_def) blast
qed(*>*)

theorem assumes ms: "measure_space M" and A: "A \<in> measurable_sets M"
  shows char_rv: "\<chi> A \<in> rv M" using ms A
  by (auto simp only: measure_space_def char_measurable rv_def)

text \<open>For more intricate functions, the following application of the
  measurability lifting theorem from \ref{sec:measure-spaces} gives a
  useful characterization.\<close>

theorem assumes ms: "measure_space M" shows
  rv_le_iff: "(f \<in> rv M) = (\<forall>a. {w. f w \<le> a} \<in> measurable_sets M)"
proof -

  have "f \<in> rv M \<Longrightarrow> \<forall>a. {w. f w \<le> a} \<in> measurable_sets M"
  proof
    { fix a
      assume "f \<in> measurable (measurable_sets M) \<bool>"
      hence "\<forall>b\<in>\<bool>. f -` b \<in> measurable_sets M"
        by (unfold measurable_def) blast
      also have "{..a} \<in> \<bool>"
        by (simp only: Borelsets_def) (rule sigma.basic, blast)
      ultimately have "{w. f w \<le> a} \<in> measurable_sets M"
        by (auto simp add: vimage_def)
    }
    thus "\<And>a. f \<in> rv M \<Longrightarrow> {w. f w \<le> a} \<in> measurable_sets M"
      by (simp add: rv_def)
  qed

  also have "\<forall>a. {w. f w \<le> a} \<in> measurable_sets M \<Longrightarrow> f \<in> rv M"
  proof -
    assume "\<forall>a. {w. f w \<le> a} \<in> measurable_sets M"
    hence "f \<in> measurable (measurable_sets M){S. \<exists>u. S={..u}}"
      by (auto simp add: measurable_def vimage_def)
    with ms have "f \<in> measurable (measurable_sets M) \<bool>"
      by (simp only: Borelsets_def measure_space_def measurable_lift)
    with ms show ?thesis
      by (auto simp add: rv_def)
   txt\<open>\nopagebreak\<close>
  qed
  ultimately show ?thesis by rule
qed

text \<open>The next four lemmata allow for a ring deduction that helps establish
  this fact for all of the signs \<open><\<close>, \<open>>\<close> and \<open>\<ge>\<close> as well.\<close>

lemma assumes sigma: "sigma_algebra A" and le: "\<forall>a. {w. f w \<le> a} \<in> A"
  shows le_less: "\<forall>a. {w. f w < (a::real)} \<in> A"
proof
  fix a::real
  from le sigma have "(\<Union>n::nat. {w. f w \<le> a - inverse (real (Suc n))}) \<in> A"
    by (simp add: sigma_algebra_def)
  also
  have "(\<Union>n::nat. {w. f w \<le> a - inverse (real (Suc n))}) = {w. f w < a}"
  proof -
    {
      fix w n
      have "0 < inverse (real (Suc (n::nat)))"
        by simp
      hence "f w \<le> a - inverse (real (Suc n)) \<Longrightarrow> f w < a"
        by arith
    }
    also
    { fix w
      have "(\<lambda>n. inverse (real (Suc n))) \<longlonglongrightarrow> 0"
        by (rule LIMSEQ_inverse_real_of_nat)

      also assume "f w < a"
      hence "0 < a - f w" by simp

      ultimately have
        "\<exists>n0. \<forall>n. n0 \<le> n \<longrightarrow> abs (inverse (real (Suc n))) < a - f w"
        by (auto simp add: lim_sequentially dist_real_def)
      then obtain n where  "abs (inverse (real (Suc n))) < a - f w"
        by blast
      hence "f w \<le> a - inverse (real (Suc n))"
        by arith
      hence "\<exists>n. f w \<le> a - inverse (real (Suc n))" ..
    }
    ultimately show ?thesis by auto
  qed
  finally show "{w. f w < a} \<in> A" .
qed

lemma assumes sigma: "sigma_algebra A" and less: "\<forall>a. {w. f w < a} \<in> A"
  shows less_ge: "\<forall>a. {w. (a::real) \<le> f w} \<in> A"
proof
  fix a::real
  from less sigma have "-{w. f w < a} \<in> A"
    by (simp add: sigma_algebra_def)
  also
  have "-{w. f w < a} = {w. a \<le> f w}"
    by auto

  finally show "{w. a \<le> f w} \<in> A" .
qed

lemma assumes sigma: "sigma_algebra A" and ge: "\<forall>a. {w. a \<le> f w} \<in> A"
  shows ge_gr: "\<forall>a. {w. (a::real) < f w} \<in> A"
(*<*)proof
  fix a::real
  from ge sigma have "(\<Union>n::nat. {w. a + inverse (real (Suc n)) \<le> f w}) \<in> A"
    by (simp add: sigma_algebra_def)
  also
  have "(\<Union>n::nat. {w. a + inverse (real (Suc n)) \<le> f w}) = {w. a < f w}"
  proof -
    {
      fix w n
      have "0 < inverse (real (Suc (n::nat)))" by simp
      hence "a + inverse (real (Suc n)) \<le> f w \<Longrightarrow> a < f w" by arith
    }
    also
    { fix w
      have "(\<lambda>n. inverse (real (Suc n))) \<longlonglongrightarrow> 0" by (rule LIMSEQ_inverse_real_of_nat)

      also assume "a < f w"
      hence "0 < f w - a" by simp

      ultimately have "\<exists>n0. \<forall>n. n0 \<le> n \<longrightarrow> abs (inverse (real (Suc n))) < f w - a"
        by (auto simp add: lim_sequentially dist_real_def)
      then obtain n where  "abs (inverse (real (Suc n))) < f w - a" by blast
      hence "a + inverse (real (Suc n)) \<le> f w" by arith
      hence "\<exists>n. a + inverse (real (Suc n)) \<le> f w" ..
    }
    ultimately show ?thesis by auto
  qed

  finally show "{w. a < f w} \<in> A" .
qed(*>*)

lemma assumes sigma: "sigma_algebra A" and gr: "\<forall>a. {w. a < f w} \<in> A"
  shows gr_le: "\<forall>a. {w. f w \<le> (a::real)} \<in> A"
(*<*)proof
  fix a::real
  from gr sigma have "-{w. a < f w} \<in> A" by (simp add: sigma_algebra_def)
  also
  have "-{w. a < f w} = {w. f w \<le> a}" by auto

  finally show "{w. f w \<le> a} \<in> A" .
qed(*>*)

theorem assumes ms: "measure_space M" shows
  rv_ge_iff: "(f \<in> rv M) = (\<forall>a. {w. a \<le> f w} \<in> measurable_sets M)"
proof -
  from ms have "(f \<in> rv M) = (\<forall>a. {w. f w \<le> a} \<in> measurable_sets M)"
    by (rule rv_le_iff)
  also have "\<dots> = (\<forall>a. {w. a \<le> f w} \<in> measurable_sets M)" (is "?lhs = ?rhs")
  proof -
    from ms have sigma: "sigma_algebra (measurable_sets M)"
      by (simp only: measure_space_def)
    also note less_ge le_less
    ultimately have "?lhs \<Longrightarrow> ?rhs" by blast
    also
    from sigma gr_le ge_gr have "?rhs \<Longrightarrow> ?lhs" by blast
    ultimately
    show ?thesis ..
  qed
  finally show ?thesis .
qed

theorem assumes ms: "measure_space M" shows
  rv_gr_iff: "(f \<in> rv M) = (\<forall>a. {w. a < f w} \<in> measurable_sets M)"
(*<*)proof -
  from ms have "(f \<in> rv M) = (\<forall>a. {w.  a \<le> f w} \<in> measurable_sets M)" by (rule rv_ge_iff)
  also have "\<dots> = (\<forall>a. {w.  a < f w} \<in> measurable_sets M)" (is "?lhs = ?rhs")
  proof -
    from ms have sigma: "sigma_algebra (measurable_sets M)" by (simp only: measure_space_def)
    also note ge_gr ultimately have "?lhs \<Longrightarrow> ?rhs" by blast
    also from sigma less_ge le_less gr_le have "?rhs \<Longrightarrow> ?lhs" by blast
    ultimately show ?thesis ..
  qed
  finally show ?thesis .
qed(*>*)

theorem assumes ms: "measure_space M" shows
  rv_less_iff: "(f \<in> rv M) = (\<forall>a. {w. f w < a} \<in> measurable_sets M)"
(*<*)proof -
  from ms have "(f \<in> rv M) = (\<forall>a. {w. a \<le> f w} \<in> measurable_sets M)" by (rule rv_ge_iff)
  also have "\<dots> = (\<forall>a. {w. f w < a} \<in> measurable_sets M)" (is "?lhs = ?rhs")
  proof -
    from ms have sigma: "sigma_algebra (measurable_sets M)" by (simp only: measure_space_def)
    also note le_less gr_le ge_gr ultimately have "?lhs \<Longrightarrow> ?rhs" by blast
    also from sigma less_ge have "?rhs \<Longrightarrow> ?lhs" by blast
    ultimately show ?thesis ..
  qed
  finally show ?thesis .
qed(*>*)

text \<open>As a first application we show that addition and multiplication
  with constants preserve measurability. This is a precursor to the
  more general addition and multiplication theorems later on. You can see that
  quite a few properties of the real numbers are employed.\<close>

lemma assumes g: "g \<in> rv M"
  shows affine_rv: "(\<lambda>x. (a::real) + (g x) * b) \<in> rv M"
proof (cases "b=0")
  from g have ms: "measure_space M"
    by (simp add: rv_def)
  case True
  hence "(\<lambda>x. a + (g x) * b) = (\<lambda>x. a)"
    by simp
  also
  from g have "(\<lambda>x. a) \<in> rv M"
    by (simp add: const_measurable rv_def measure_space_def)
  ultimately show ?thesis by simp

next
  from g have ms: "measure_space M"
    by (simp add: rv_def)
  case False
  have calc: "\<And>x c. (a + g x * b \<le> c) = (g x * b  \<le> c - a)"
    by arith
  have "\<forall>c. {w.  a + g w * b \<le> c} \<in> measurable_sets M"
  proof (cases "b<0")
    case False
    with \<open>b \<noteq> 0\<close> have "0<b" by arith
    hence "\<And>x c.  (g x * b  \<le> c - a) = (g x \<le> (c - a) / b)"
      by (rule pos_le_divide_eq [THEN sym])
    with calc have "\<And>c. {w.  a + g w * b \<le> c} = {w. g w \<le> (c - a) / b}"
      by simp

    also from ms g  have "\<forall>a. {w. g w \<le> a} \<in> measurable_sets M"
      by (simp add: rv_le_iff)

    ultimately show ?thesis by simp

  next
    case True
    hence "\<And>x c. (g x * b \<le> c-a) = ((c-a)/b \<le> g x)"
      by (rule neg_divide_le_eq [THEN sym])
    with calc have "\<And>c. {w.  a + g w * b \<le> c} = {w. (c-a)/b \<le> g w}"
      by simp

    also from ms g have "\<forall>a. {w. a \<le> g w } \<in> measurable_sets M"
      by (simp add: rv_ge_iff)

    ultimately show ?thesis by simp
  qed

  with ms show ?thesis
    by (simp only: rv_le_iff [THEN sym])
qed

text \<open>For the general case of addition, we need one more set to be
  measurable, namely \<open>{w. f w \<le> g w}\<close>. This follows from a
  like statement for $<$. A dense and countable
  subset of the reals is needed to establish it.

  Of course, the rationals come to
  mind. They were not available in Isabelle/HOL\footnote{At least not
  as a subset of the reals, to the definition of which a type of
  positive rational numbers contributed \<^cite>\<open>"Fleuriot:2000:MNR"\<close>.}, so
  I built a theory with the necessary properties on my own. [Meanwhile
  Isabelle has proper rationals and SR's development of the rationals has been
  moved to and merged with Isabelle's rationals.\<close>

(*For this theorem, we need some properties of the rational numbers
(or any other dense and countable set in the reals - so why not use
the rationals?).*)

lemma assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows rv_less_rv_measurable: "{w. f w < g w} \<in> measurable_sets M"
proof -
  let "?I i" = "let s::real = of_rat(nat_to_rat_surj i) in {w. f w < s} \<inter> {w. s < g w}"
  from g have ms: "measure_space M" by (simp add: rv_def)
  have "{w. f w < g w} = (\<Union>i. ?I i)"
  proof
    { fix w assume "w \<in> {w. f w < g w}"
      hence "f w < g w" ..
      hence "\<exists>s\<in>\<rat>. f w < s \<and> s < g w" by (rule Rats_dense_in_real)
      hence "\<exists>s\<in>\<rat>. w \<in> {w. f w < s} \<inter> {w. s < g w}" by simp
      hence "\<exists>i. w \<in> ?I i"
        by(simp add:Let_def)(metis surj_of_rat_nat_to_rat_surj)
      hence "w \<in> (\<Union>i. ?I i)" by simp
    }
    thus "{w. f w < g w} \<subseteq> (\<Union>i. ?I i)" ..

    show "(\<Union>i. ?I i) \<subseteq> {w. f w < g w}" by (force simp add: Let_def)
  qed
  moreover have "(\<Union>i. ?I i) \<in> measurable_sets M"
  proof -
    from ms have sig: "sigma_algebra (measurable_sets M)"
      by (simp only: measure_space_def)
    { fix s
      note sig
      also from ms f have "{w. f w < s} \<in> measurable_sets M" (is "?a\<in>?M")
        by (simp add: rv_less_iff)
      moreover from ms g have "{w. s < g w} \<in> ?M" (is "?b \<in> ?M")
        by (simp add: rv_gr_iff)
      ultimately have "?a \<inter> ?b \<in> ?M" by (rule sigma_algebra_inter)
    }
    hence "\<forall>i. ?I i \<in> measurable_sets M" by (simp add: Let_def)
    with sig show ?thesis by (auto simp only: sigma_algebra_def Let_def)
  qed
  ultimately show ?thesis by simp
qed

(*The preceding theorem took me about 1 month to establish through its deep dependencies*)
lemma assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows rv_le_rv_measurable: "{w. f w \<le> g w} \<in> measurable_sets M" (is "?a \<in> ?M")
proof -
  from g have ms: "measure_space M"
    by (simp add: rv_def)
  from g f have "{w. g w < f w} \<in> ?M"
    by (rule rv_less_rv_measurable)
  also from ms have "sigma_algebra ?M"
    by (simp only: measure_space_def)

  ultimately have "-{w. g w < f w} \<in> ?M"
    by (simp only: sigma_algebra_def)
  also have "-{w. g w < f w} = ?a"
    by auto
txt\<open>\nopagebreak\<close>
  finally show ?thesis .
qed

lemma assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows f_eq_g_measurable: "{w. f w = g w} \<in> measurable_sets M" (*<*)(is "?a \<in> ?M")
proof -
  from g have ms: "measure_space M" by (simp add: rv_def)
  hence "sigma_algebra ?M" by (simp only: measure_space_def)
  also from f g ms have "{w. f w \<le> g w} \<in> ?M" and "{w. g w \<le> f w} \<in> ?M"
    by (auto simp only: rv_le_rv_measurable)

  ultimately have "{w. f w \<le> g w} \<inter> {w. g w \<le> f w} \<in> ?M" (is "?b \<in> ?M")
    by (rule sigma_algebra_inter)
  also have "?b = ?a" by auto

  finally show ?thesis .
qed(*>*)

lemma assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows f_noteq_g_measurable: "{w. f w \<noteq> g w} \<in> measurable_sets M" (*<*)(is "?a \<in> ?M")
proof -
  from g have ms: "measure_space M" by (simp add: rv_def)
  hence "sigma_algebra ?M" by (simp only: measure_space_def)
  also from f g have "{w. f w = g w} \<in> ?M" by (rule f_eq_g_measurable)

  ultimately have "-{w. f w = g w} \<in> ?M" by (simp only: sigma_algebra_def)
  also have "-{w. f w = g w} = ?a" by auto

  finally show ?thesis .
qed(*>*)

text \<open>With these tools, a short proof for the addition theorem is
  possible.\<close>

theorem assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows rv_plus_rv: "(\<lambda>w. f w + g w) \<in> rv M"
proof -
  from g have ms: "measure_space M" by (simp add: rv_def)
  { fix a
    have "{w. a \<le> f w + g w} = {w. a + (g w)*(-1) \<le> f w}"
      by auto
    moreover from g have "(\<lambda>w. a + (g w)*(-1)) \<in> rv M"
      by (rule affine_rv)
    with f have "{w. a + (g w)*(-1) \<le> f w} \<in> measurable_sets M"
      by (simp add: rv_le_rv_measurable)
    ultimately have "{w. a \<le> f w + g w} \<in> measurable_sets M" by simp
  }
  with ms show ?thesis
    by (simp add: rv_ge_iff)
  thm rv_ge_iff
qed

text \<open>To show preservation of measurability by multiplication, it is
  expressed by addition and squaring. This requires a few technical
  lemmata including the one stating measurability for squares, the proof of which is skipped.\<close>

(*This lemma should probably be in the RealPow Theory or a special Sqroot-Theory*)
lemma pow2_le_abs: "(a\<^sup>2 \<le> b\<^sup>2) = (\<bar>a\<bar> \<le> \<bar>b::real\<bar>)"
(*<*)proof -
  have "(a\<^sup>2 \<le> b\<^sup>2) = (\<bar>a\<bar>\<^sup>2 \<le> \<bar>b\<bar>\<^sup>2)" by (simp add: numeral_2_eq_2)
  also have "\<dots> = (\<bar>a\<bar> \<le> \<bar>b\<bar>)"
  proof
    assume "\<bar>a\<bar> \<le> \<bar>b\<bar>"
    thus "\<bar>a\<bar>\<^sup>2 \<le> \<bar>b\<bar>\<^sup>2"
      by (rule power_mono) simp
  next
    assume "\<bar>a\<bar>\<^sup>2 \<le> \<bar>b\<bar>\<^sup>2" hence "\<bar>a\<bar>^(Suc 1) \<le> \<bar>b\<bar>^(Suc 1)" by (simp add: numeral_2_eq_2)
    moreover have "0 \<le> \<bar>b\<bar>" by auto
    ultimately show "\<bar>a\<bar> \<le> \<bar>b\<bar>" by (rule power_le_imp_le_base)
  qed
  finally show ?thesis .
qed(*>*)

lemma assumes f: "f \<in> rv M"
  shows rv_square: "(\<lambda>w. (f w)\<^sup>2) \<in> rv M"
(*<*)proof -
  from f have ms: "measure_space M" by (simp add: rv_def)
  hence "?thesis = (\<forall>a. {w. (f w)\<^sup>2 \<le> a} \<in> measurable_sets M)" (is "_ = (\<forall>a. ?F a \<in> ?M)") by (rule rv_le_iff)
  also {
    fix a
    from ms have sig: "sigma_algebra ?M" by (simp only: measure_space_def)
    have "?F a \<in> ?M"
    proof (cases "a < 0")

      case True
      { fix w
        note True
        also have "0 \<le> (f w)\<^sup>2" by simp
        finally have "((f w)\<^sup>2 \<le> a) = False" by simp
      } hence "?F a = {}" by simp
      thus ?thesis using sig by (simp only: sigma_algebra_def)

    next
      case False
      show ?thesis
      proof (cases "a = 0")

        case True also
        { fix w
          have "0 \<le> (f w)\<^sup>2" by simp
          hence "((f w)\<^sup>2 \<le> 0) \<Longrightarrow> ((f w)\<^sup>2 = 0)" by (simp only: order_antisym)
          hence "((f w)\<^sup>2 \<le> 0) = ((f w)\<^sup>2 = 0)" by (force simp add: numeral_2_eq_2)
          also have "\<dots> = (f w = 0)" by simp
          finally have "((f w)\<^sup>2 \<le> 0) = \<dots>" .
        }

        ultimately have "?F a = {w. f w = 0}" by simp
        moreover have "\<dots> = {w. f w \<le> 0} \<inter> {w. 0 \<le> f w}" by auto
        moreover have "\<dots> \<in> ?M"
        proof -
          from ms f have "{w. f w \<le> 0} \<in> ?M" by (simp only: rv_le_iff)
          also from ms f have "{w. 0 \<le> f w} \<in> ?M" by (simp only: rv_ge_iff)
          ultimately show ?thesis using sig by (simp only: sigma_algebra_inter)
        qed

        ultimately show ?thesis by simp

      next
        case False
        with \<open>\<not> a < 0\<close> have "0<a" by (simp add: order_less_le)
        then have "\<exists> sqra. 0<sqra \<and> sqra\<^sup>2 = a" by (simp only: realpow_pos_nth2 numeral_2_eq_2)
        then have "\<And>w. \<exists> sqra. ?F a = {w. -sqra \<le> f w} \<inter> {w. f w \<le> sqra}"
          by (force simp only: pow2_le_abs abs_le_iff)
        then obtain sqra where "?F a = {w. -sqra \<le> f w} \<inter> {w. f w \<le> sqra}" by fast
        moreover have "\<dots> \<in> ?M"
        proof -
          from ms f have "{w. f w \<le> sqra} \<in> ?M" by (simp only: rv_le_iff)
          also from ms f have "{w. -sqra \<le> f w} \<in> ?M" by (simp only: rv_ge_iff)
          ultimately show ?thesis using sig by (simp only: sigma_algebra_inter)
        qed

        ultimately show ?thesis by simp

      qed
    qed
  }

  ultimately show ?thesis by simp

qed(*>*)

lemma realpow_two_binomial_iff: "(f+g::real)\<^sup>2 = f\<^sup>2 + 2*(f*g) + g\<^sup>2"
  (*<*)
  by (simp add: power2_eq_square distrib_right distrib_left)(*>*)

lemma times_iff_sum_squares: "f*g = (f+g)\<^sup>2/4 - (f-g)\<^sup>2/(4::real)"
  by (simp add: power2_eq_square field_simps)

theorem assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows rv_times_rv: "(\<lambda>w. f w * g w) \<in> rv M"
proof -
  have "(\<lambda>w. f w * g w) = (\<lambda>w. (f w + g w)\<^sup>2/4 - (f w - g w)\<^sup>2/4)"
    by (simp only: times_iff_sum_squares)
  also have "\<dots> = (\<lambda>w. (f w + g w)\<^sup>2*inverse 4 - (f w + - g w)\<^sup>2*inverse 4)"
    by simp
  also from f g have "\<dots> \<in> rv M"
  proof -
    from f g have "(\<lambda>w. (f w + g w)\<^sup>2)  \<in> rv M"
      by (simp add: rv_plus_rv rv_square)
    hence "(\<lambda>w. 0+(f w + g w)\<^sup>2*inverse 4) \<in> rv M"
      by (rule affine_rv)
    also from g have "(\<lambda>w. 0 + (g w)*-1 ) \<in> rv M"
      by (rule affine_rv)
    with f have "(\<lambda>w. (f w - g w)\<^sup>2)  \<in> rv M"
      by (simp add: rv_plus_rv rv_square diff_conv_add_uminus del: add_uminus_conv_diff)
    hence "(\<lambda>w. 0+(f w - g w)\<^sup>2*-inverse 4) \<in> rv M"
      by (rule affine_rv)
    ultimately show ?thesis
      by (simp add: rv_plus_rv diff_conv_add_uminus del: add_uminus_conv_diff)
  qed txt\<open>\nopagebreak\<close>
  ultimately show ?thesis by simp
qed

text\<open>The case of substraction is an easy consequence of \<open>rv_plus_rv\<close> and
  \<open>rv_times_rv\<close>.\<close>

theorem rv_minus_rv:
  assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows "(\<lambda>t. f t - g t) \<in> rv M"
(*<*)proof -
  from f have ms: "measure_space M" by (simp add: rv_def)
  hence "(\<lambda>t. -1) \<in> rv M" by (simp add: const_rv)
  from this g have "(\<lambda>t. -1*g t) \<in> rv M" by (rule rv_times_rv)
  hence "(\<lambda>t. -g t) \<in> rv M" by simp
  with f have "(\<lambda>t. f t +-g t) \<in> rv M" by (rule rv_plus_rv)
  thus ?thesis by simp
qed(*>*)
text\<open>Measurability for limit functions of
    monotone convergent series is also surprisingly straightforward.\<close>

theorem assumes u: "\<And>n. u n \<in> rv M" and mon_conv: "u\<up>f"
  shows mon_conv_rv: "f \<in> rv M"
proof -
  from u have ms: "measure_space M"
    by (simp add: rv_def)

  {
    fix a
    {
      fix w
      from mon_conv have up: "(\<lambda>n. u n w)\<up>f w"
        by (simp only: realfun_mon_conv_iff)
      {
        fix i
        from up have "u i w \<le> f w"
          by (rule real_mon_conv_le)
        also assume "f w \<le> a"
        finally have  "u i w \<le> a" .
      }

      also
      { assume "\<And>i. u i w \<le> a"
        also from up have "(\<lambda>n. u n w) \<longlonglongrightarrow> f w"
          by (simp only: mon_conv_real_def)
        ultimately have "f w \<le> a"
          by (simp add: LIMSEQ_le_const2)
      }
      ultimately have "(f w \<le> a) = (\<forall>i. u i w \<le> a)" by fast
    }
    hence "{w. f w \<le> a} = (\<Inter>i. {w. u i w \<le> a})" by fast
    moreover
    from ms u have "\<And>i. {w. u i w \<le> a} \<in> sigma(measurable_sets M)"
      by (simp add: rv_le_iff sigma.intros)
    hence "(\<Inter>i. {w. u i w \<le> a}) \<in> sigma(measurable_sets M)"
      by (rule sigma_Inter)
    with ms have "(\<Inter>i. {w. u i w \<le> a}) \<in> measurable_sets M"
      by (simp only: measure_space_def sigma_sigma_algebra)
    ultimately have "{w. f w \<le> a} \<in> measurable_sets M" by simp
  }
  with ms show ?thesis
    by (simp add: rv_le_iff)
qed

text \<open>Before we end this chapter to start the formalization of the
  integral proper, there is one more concept missing: The
  positive and negative part of a function. Their definition is quite intuitive,
  and some useful properties are given right away, including the fact
  that they are random variables, provided that their argument
  functions are measurable.\<close>

definition
  nonnegative:: "('a \<Rightarrow> ('b::{ord,zero})) \<Rightarrow> bool" where
  "nonnegative f \<longleftrightarrow> (\<forall>x. 0 \<le> f x)"

definition
  positive_part:: "('a \<Rightarrow> ('b::{ord,zero})) \<Rightarrow> ('a \<Rightarrow> 'b)" ("pp") where
  "pp f x = (if 0\<le>f(x) then f x else 0)"

definition
  negative_part:: "('a \<Rightarrow> ('b::{ord,zero,uminus,minus})) \<Rightarrow> ('a \<Rightarrow> 'b)" ("np") where
  "np f x = (if 0\<le>f(x) then 0 else -f(x))"
  (*useful lemmata about positive and negative parts*)
lemma f_plus_minus: "((f x)::real) = pp f x - np f x"
  by (simp add:positive_part_def negative_part_def)

lemma f_plus_minus2: "(f::'a \<Rightarrow> real) = (\<lambda>t. pp f t - np f t)"
  using f_plus_minus
  by (rule ext)

lemma f_abs_plus_minus: "(\<bar>f x\<bar>::real) = pp f x + np f x"
  by  (auto simp add:positive_part_def negative_part_def)

lemma nn_pp_np: assumes "nonnegative f"
  shows "pp f = f" and "np f = (\<lambda>t. 0)" using assms
  by (auto simp add: positive_part_def negative_part_def nonnegative_def ext)

lemma pos_pp_np_help: "\<And>x. 0\<le>f x \<Longrightarrow> pp f x = f x \<and> np f x = 0"
  by (simp add: positive_part_def negative_part_def)

lemma real_neg_pp_np_help: "\<And>x. f x \<le> (0::real) \<Longrightarrow> np f x = -f x \<and> pp f x = 0"
(*<*)proof -
  fix x
  assume le: "f x \<le> 0"
  hence "pp f x = 0 "
    by (cases "f x < 0") (auto simp add: positive_part_def)
  also from le have "np f x = -f x"
    by (cases "f x < 0") (auto simp add: negative_part_def)
  ultimately show "np f x = -f x \<and> pp f x = 0" by fast
qed(*>*)

lemma real_neg_pp_np: assumes "f \<le> (\<lambda>t. (0::real))"
 shows "np f = (\<lambda>t. -f t)" and "pp f = (\<lambda>t. 0)" using assms
  by (auto simp add: real_neg_pp_np_help ext le_fun_def)

lemma assumes a: "0\<le>(a::real)"
  shows real_pp_np_pos_times:
  "pp (\<lambda>t. a*f t) = (\<lambda>t. a*pp f t) \<and>  np (\<lambda>t. a*f t) = (\<lambda>t. a*np f t)"
(*<*)proof -
  { fix t
    have "pp (\<lambda>t. a*f t) t = a*pp f t \<and> np (\<lambda>t. a*f t) t = a*np f t"
    proof (cases "0 \<le> f t")
      case True
      from a this a order_refl[of 0] have le: "0*0\<le>a*f t"
        by (rule mult_mono)
      hence "pp (\<lambda>t. a*f t) t = a*f t" by (simp add: positive_part_def)
      also from True have "\<dots> = a*pp f t" by (simp add: positive_part_def)
      finally have 1: "pp (\<lambda>t. a*f t) t = a*pp f t" .

      from le have "np (\<lambda>t. a*f t) t = 0" by (simp add: negative_part_def)
      also from True have "\<dots> = a*np f t" by (simp add: negative_part_def)
      finally show ?thesis using 1 by fast
    next
      case False
      hence "f t \<le> 0" by simp
      from this a have "(f t)*a \<le> 0*a" by (rule mult_right_mono)
      hence le: "a*f t \<le> 0" by (simp add: mult.commute)
      hence "pp (\<lambda>t. a*f t) t = 0"
        by (cases "a*f t<0") (auto simp add: positive_part_def order_le_less )
      also from False have "\<dots> = a*pp f t" by (simp add: positive_part_def)
      finally have 1: "pp (\<lambda>t. a*f t) t = a*pp f t" .

      from le have "np (\<lambda>t. a*f t) t = -a*f t"
        by (cases "a*f t=0") (auto simp add: negative_part_def order_le_less)
      also from False have "\<dots> = a*np f t" by (simp add: negative_part_def)
      finally show ?thesis using 1 by fast
    qed
  } thus ?thesis by (simp add: ext)
qed(*>*)

lemma assumes a: "(a::real)\<le>0"
  shows real_pp_np_neg_times:
  "pp (\<lambda>t. a*f t) = (\<lambda>t. -a*np f t) \<and>  np (\<lambda>t. a*f t) = (\<lambda>t. -a*pp f t)"
(*<*)proof -
  { fix t
    have "pp (\<lambda>t. a*f t) t = -a*np f t \<and> np (\<lambda>t. a*f t) t = -a*pp f t"
    proof (cases "0 \<le> f t")
      case True
      with a have le: "a*f t\<le>0*f t"
        by (rule mult_right_mono)
      hence "pp (\<lambda>t. a*f t) t = 0" by (simp add: real_neg_pp_np_help)
      also from True have "\<dots> = -a*np f t" by (simp add: negative_part_def)
      finally have 1: "pp (\<lambda>t. a*f t) t = -a*np f t" .

      from le have "np (\<lambda>t. a*f t) t = -a*f t" by (simp add: real_neg_pp_np_help)
      also from True have "\<dots> = -a*pp f t" by (simp add: positive_part_def)
      finally show ?thesis using 1 by fast
    next
      case False
      hence "f t \<le> 0" by simp
      with a have le: "0\<le>a*(f t)" by (simp add: zero_le_mult_iff)
      hence "pp (\<lambda>t. a*f t) t = a*f t" by (simp add: positive_part_def)
      also from False have "\<dots> = -a*np f t" by (simp add: negative_part_def)
      finally have 1: "pp (\<lambda>t. a*f t) t = -a*np f t" .

      from le have "np (\<lambda>t. a*f t) t = 0" by (simp add: negative_part_def)
      also from False have "\<dots> = -a*pp f t" by (simp add: positive_part_def)
      finally show ?thesis using 1 by fast
    qed
  } thus ?thesis by (simp add: ext)
qed(*>*)

lemma pp_np_rv:
  assumes f: "f \<in> rv M"
  shows "pp f \<in> rv M" and "np f \<in> rv M"
proof -
  from f have ms: "measure_space M" by (simp add: rv_def)

  { fix a
    from ms f have fm: "{w. f w \<le> a} \<in> measurable_sets M"
      by (simp add: rv_le_iff)
    have
      "{w. pp f w \<le> a} \<in> measurable_sets M \<and>
      {w. np f w \<le> a} \<in> measurable_sets M"
    proof (cases "0\<le>a")
      case True
      hence "{w. pp f w \<le> a} = {w. f w \<le> a}"
        by (auto simp add: positive_part_def)
      moreover note fm moreover
      from True have "{w. np f w \<le> a} = {w. -a \<le> f w}"
        by (auto simp add: negative_part_def)
      moreover from ms f have "\<dots> \<in> measurable_sets M"
        by (simp add: rv_ge_iff)
      ultimately show ?thesis by simp
    next
      case False
      hence "{w. pp f w \<le> a} = {}"
        by (auto simp add: positive_part_def)
      also from False have "{w. np f w \<le> a} = {}"
        by (auto simp add: negative_part_def)
      moreover from ms have "{} \<in> measurable_sets M"
        by (simp add: measure_space_def sigma_algebra_def)
      ultimately show ?thesis by simp
    qed
  } with ms show "pp f \<in> rv M" and "np f \<in> rv M"
    by (auto simp add: rv_le_iff)
qed

theorem pp_np_rv_iff: "(f::'a \<Rightarrow> real) \<in> rv M = (pp f \<in> rv M \<and> np f \<in> rv M)"
(*<*)proof -
  { assume "pp f \<in> rv M" and "np f \<in> rv M"
    hence "(\<lambda>t. pp f t - np f t) \<in> rv M" by (rule rv_minus_rv)
    also have "f = (\<lambda>t. pp f t - np f t)" by (rule f_plus_minus2)
    ultimately have "f \<in> rv M" by simp
  } also
  have "f \<in> rv M \<Longrightarrow> (pp f \<in> rv M \<and> np f \<in> rv M)" by (simp add: pp_np_rv)
  ultimately show ?thesis by fast
qed(*>*)

text\<open>This completes the chapter about measurable functions. As we
  will see in the next one, measurability is the prime condition on
  Lebesgue integrable functions; and the theorems and lemmata
  established here suffice --- at least in principle --- to show it holds for any
  function that is to be integrated there.\<close>

end


theory Lappend_literates
  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 literates :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Llist"
where "literates f x = LCons x (literates f (f x))"

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

(* Need obs to explore with literates *)
 datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"
lemma "\<exists>(n::integer). n < 0"
  using neg_less_0_iff_less zero_less_one by blast
lemma integerz [simp]: "(\<forall>(n::integer). \<not> n \<le> 0) \<Longrightarrow> False"
  by blast
fun obsLList :: "int \<Rightarrow> 'a Llist \<Rightarrow> 'a Lst" where
"obsLList n s = (if (n \<le> 0) then Emp else Cons (lhd s) (obsLList (n - 1) (ltl s)))"

(*hipster_obs Llist Lst obsLList literates lappend*)
lemma lemma_a [thy_expl]: "lappend (literates z x2) y = literates z x2"
  apply (coinduction  arbitrary: x2 y z rule: Lappend_literates.Llist.coinduct_strong)
  apply simp
  by auto

lemma lemma_aa [thy_expl]: "lappend (LCons z (literates x2 x3)) y = LCons z (literates x2 x3)"
  apply (coinduction  arbitrary: x2 x3 y z rule: Lappend_literates.Llist.coinduct_strong)
  by (simp_all add: lemma_a)

theorem lappend_literates: "lappend (literates f x) xs = literates f x"
(*by hipster_coinduct_sledgehammer works from the start *)
by (simp add: lemma_a)
end


section \<open>Fixed Point Algorithm for Coupled Similarity\<close>

subsection \<open>The Algorithm\<close>

theory CS_Fixpoint_Algo_Delay
imports
  Coupled_Simulation
  "~~/src/HOL/Library/While_Combinator"
  "~~/src/HOL/Library/Finite_Lattice"
begin

context lts_tau
begin

definition fp_step ::
  \<open>'s rel \<Rightarrow> 's rel\<close>
where
  \<open>fp_step R1 \<equiv> { (p,q)\<in>R1.
    (\<forall> p' a. p \<longmapsto>a p' \<longrightarrow>
      (tau a \<longrightarrow> (p',q)\<in>R1) \<and>
      (\<not>tau a \<longrightarrow> (\<exists> q'. ((p',q')\<in>R1) \<and> (q =\<rhd>a q')))) \<and>
    (\<exists> q'. q \<longmapsto>*tau q' \<and> ((q',p)\<in>R1)) }\<close>

definition fp_compute_cs :: \<open>'s rel\<close>
where \<open>fp_compute_cs \<equiv> while (\<lambda>R. fp_step R \<noteq> R) fp_step top\<close>

subsection \<open>Correctness\<close>

lemma mono_fp_step:
  \<open>mono fp_step\<close>
proof (rule, safe)
  fix x y::\<open>'s rel\<close> and p q
  assume
    \<open>x \<subseteq> y\<close>
    \<open>(p, q) \<in> fp_step x\<close>
  thus  \<open>(p, q) \<in> fp_step y\<close>
    unfolding fp_step_def
    by (auto, blast)
qed

lemma fp_fp_step:
  assumes
    \<open>R = fp_step R\<close>
  shows
    \<open>coupled_delay_simulation (\<lambda> p q. (p, q) \<in> R)\<close>
  using assms unfolding fp_step_def coupled_delay_simulation_def delay_simulation_def
  by (auto, blast, fastforce+)

lemma gfp_fp_step_subset_gcs:
  shows \<open>(gfp fp_step) \<subseteq> { (p,q) . greatest_coupled_simulation p q }\<close>
  unfolding  gcs_eq_coupled_sim_by[symmetric]
proof clarify
  fix a b
  assume
    \<open>(a, b) \<in> gfp fp_step\<close>
  thus \<open>a \<sqsubseteq>cs  b\<close>
    unfolding coupled_sim_by_eq_coupled_delay_simulation
    using fp_fp_step mono_fp_step gfp_unfold
    by metis
qed

lemma fp_fp_step_gcs:
  assumes
    \<open>R = { (p,q) . greatest_coupled_simulation p q }\<close>
  shows
    \<open>fp_step R = R\<close>
  unfolding assms
proof safe
  fix p q
  assume
    \<open>(p, q) \<in> fp_step {(x, y). greatest_coupled_simulation x y}\<close>
  hence
    \<open>(\<forall>p' a. p \<longmapsto>a  p' \<longrightarrow>
      (tau a \<longrightarrow> greatest_coupled_simulation p' q) \<and>
      (\<not>tau a \<longrightarrow>  (\<exists>q'. greatest_coupled_simulation p' q' \<and> q =\<rhd>a  q'))) \<and>
    (\<exists>q'. q \<longmapsto>* tau  q' \<and> greatest_coupled_simulation q' p)\<close>
    unfolding fp_step_def by auto
  hence \<open>(\<forall>p' a. p \<longmapsto>a  p' \<longrightarrow> (\<exists>q'. greatest_coupled_simulation p' q' \<and> q \<Rightarrow>^a  q')) \<and>
    (\<exists>q'. q \<longmapsto>* tau  q' \<and> greatest_coupled_simulation q' p)\<close>
    unfolding fp_step_def using weak_step_delay_implies_weak_tau steps.refl by blast
  hence \<open>(\<forall>p' a. p \<longmapsto>a  p' \<longrightarrow> (\<exists>q'. greatest_coupled_simulation p' q' \<and> q \<Rightarrow>^^a  q')) \<and>
    (\<exists>q'. q \<longmapsto>* tau  q' \<and> greatest_coupled_simulation q' p)\<close>
    using weak_step_tau2_def by simp
  thus \<open>greatest_coupled_simulation p q\<close>
    using lts_tau.gcs by metis
next
  fix p q
  assume asm:
    \<open>greatest_coupled_simulation p q\<close>
  then have \<open>(p, q) \<in> {(x, y). greatest_coupled_simulation x y}\<close> by blast
  moreover from asm have \<open>\<exists> R. R p q \<and> coupled_delay_simulation R\<close>
    unfolding gcs_eq_coupled_sim_by[symmetric] coupled_sim_by_eq_coupled_delay_simulation .
  moreover from asm have  \<open>\<forall> p' a. p \<longmapsto>a p' \<and> \<not>tau a \<longrightarrow>
      (\<exists> q'. (greatest_coupled_simulation p' q') \<and> (q =\<rhd>a q'))\<close>
    unfolding  gcs_eq_coupled_sim_by[symmetric] coupled_sim_by_eq_coupled_delay_simulation
    by (metis coupled_delay_simulation_def delay_simulation_def)
  moreover from asm have  \<open>\<forall> p' a. p \<longmapsto>a p' \<and> tau a \<longrightarrow> greatest_coupled_simulation p' q\<close>
    unfolding  gcs_eq_coupled_sim_by[symmetric] coupled_sim_by_eq_coupled_delay_simulation
    by (metis coupled_delay_simulation_def delay_simulation_def)
  moreover have  \<open>(\<exists> q'. q \<longmapsto>*tau q' \<and> (greatest_coupled_simulation q' p))\<close>
    using asm gcs_is_coupled_simulation coupled_simulation_implies_coupling by blast
  ultimately show \<open>(p, q) \<in> fp_step {(x, y). greatest_coupled_simulation x y}\<close>
    unfolding fp_step_def by blast
qed

lemma gfp_fp_step_gcs: \<open>gfp fp_step = { (p,q) . greatest_coupled_simulation p q }\<close>
  using fp_fp_step_gcs gfp_fp_step_subset_gcs
  by (simp add: equalityI gfp_upperbound)

end

context lts_tau_finite
begin
lemma gfp_fp_step_while:
  shows
    \<open>gfp fp_step = fp_compute_cs\<close>
  unfolding fp_compute_cs_def
  using gfp_while_lattice[OF mono_fp_step] finite_state_rel Finite_Set.finite_set by blast

theorem coupled_sim_fp_step_while:
  shows \<open>fp_compute_cs = { (p,q) . greatest_coupled_simulation p q }\<close>
  using gfp_fp_step_while gfp_fp_step_gcs by blast

end

end


section \<open>Dictionary Construction\<close>

theory Introduction
imports Main
begin

subsection \<open>Introduction\<close>

text \<open>
 Isabelle's logic features \emph{type classes}~\cite{haftmann2007typeclasses,wenzel1997typeclasses}.
 These are built into the kernel and are used extensively in theory developments.
 The existing \emph{code generator}, when targeting Standard ML, performs the well-known dictionary
 construction or \emph{dictionary translation}~\cite{haftmann2010codegeneration}.
 This works by replacing type classes with records, instances with values, and occurrences with
 explicit parameters.

 Haftmann and Nipkow give a pen-and-paper correctness proof of this construction
 \cite[\<open>\<section>\<close>4.1]{haftmann2010codegeneration}, based on a notion of \emph{higher-order rewrite
 systems.}
 The resulting theorem then states that any well-typed term is reduction-equivalent before and after
 class elimination.
 In this work, the dictionary construction is performed in a certified fashion, that is, the
 equivalence is a theorem inside the logic.
\<close>

subsection \<open>Encoding classes\<close>

text \<open>
  The choice of representation of a dictionary itself is straightforward: We model it as a
  @{command datatype}, along with functions returning values of that type. The alternative here
  would have been to use the @{command record} package. The obvious advantage is that we could
  easily model subclass relationships through record inheritance. However, records do not support
  multiple inheritance. Since records offer no advantage over datatypes in that regard, we opted for
  the more modern @{command datatype} package.
\<close>

text \<open>Consider the following example:\<close>

class plus =
  fixes plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"

text \<open>
  This will get translated to a @{command datatype} with a single constructor taking a single
  argument:
\<close>

datatype 'a dict_plus =
  mk_plus (param_plus: "'a \<Rightarrow> 'a \<Rightarrow> 'a")

text \<open>A function using the @{class plus} constraint:\<close>

definition double :: "'a::plus \<Rightarrow> 'a" where
"double x = plus x x"

definition double' :: "'a dict_plus \<Rightarrow> 'a \<Rightarrow> 'a" where
"double' dict x = param_plus dict x x"

subsection \<open>Encoding instances\<close>

text \<open>
  A more controversial design decision is how to represent dictionary certificates. For example,
  given a value of type @{typ "nat dict_plus"}, how do we know that this is a faithful representation
  of the @{class plus} instance for @{typ nat}?
\<close>

text \<open>
  \<^item> Florian Haftmann proposed a ``shallow encoding''. It works by exploiting the internal treatment
    of constants with sort constraints in the Isabelle kernel. Constants themselves do not carry
    sort constraints, only their definitional equations. The fact that a constant only appears with
    these constraints on the surface of the system is a feature of type inference.

    Instead, we can instruct the system to ignore these constraints. However, any attempt at
    ``hiding'' the constraints behind a type definition ultimately does not work: The nonemptiness
    proof requires a witness of a valid dictionary for an arbitrary, but fixed type @{typ 'a}, which
    is of course not possible (see \<open>\<section>\<close>\ref{sec:impossibility} for details).

  \<^item> The certificates contain the class axioms directly. For example, the @{class semigroup_add}
    class requires @{term "(a + b) + c = a + (b + c)"}.

    Translated into a definition, this would look as follows:

    @{term
      "cert_plus dict \<longleftrightarrow>
        (\<forall>a b c. param_plus dict (param_plus dict a b) c = param_plus dict a (param_plus dict b c))"}

    Proving that instances satisfy this certificate is trivial.

    However, the equality proof of \<open>f'\<close> and \<open>f\<close> is impossible: they are simply not equal in general.
    Nothing would prevent someone from defining an alternative dictionary using multiplication
    instead of addition and the certificate would still hold; but obviously functions using
    @{const plus} on numbers would expect addition.

    Intuitively, this makes sense: the above notion of ``certificate'' establishes no connection
    between original instantiation and newly-generated dictionaries.

    Instead of proving equality, one would have to ``lift'' all existing theorems over the old
    constants to the new constants.

  \<^item> In order for equality between new and old constants to hold, the certificate needs to capture
    that the dictionary corresponds exactly to the class constants. This is achieved by the
    representation below.
    It literally states that the fields of the dictionary are equal to the class constants.
    The condition of the resulting equation can only be instantiated with dictionaries corresponding
    to existing class instances. This constitutes a \<^emph>\<open>closed world\<close> assumption, i.e., callers of
    generated code may not invent own instantiations.
\<close>

definition cert_plus :: "'a::plus dict_plus \<Rightarrow> bool" where
"cert_plus dict \<longleftrightarrow> (param_plus dict = plus)"

text \<open>
  Based on that definition, we can prove that @{const double} and @{const double'} are equivalent:
\<close>

lemma "cert_plus dict \<Longrightarrow> double' dict = double"
unfolding cert_plus_def double'_def double_def
by auto

text \<open>
  An unconditional equation can be obtained by specializing the theorem to a ground type and
  supplying a valid dictionary.
\<close>

subsection \<open>Implementation\<close>

text \<open>
  When translating a constant \<open>f\<close>, we use existing mechanisms in Isabelle to obtain its
  \<^emph>\<open>code graph\<close>. The graph contains the code equations of all transitive dependencies (i.e.,
  other constants) of \<open>f\<close>. In general, we have to re-define each of these dependencies. For that,
  we use the internal interface of the @{command function} package and feed it the code equations
  after performing the dictionary construction. In the standard case, where the user has not
  performed a custom code setup, the resulting function looks similar to its original definition.
  But the user may have also changed the implementation of a function significantly afterwards.
  This imposes some restrictions:

  \<^item> The new constant needs to be proven terminating. We apply some heuristics to transfer the
    original termination proof to the new definition. This only works when the termination condition
    does not rely on class axioms. (See \<open>\<section>\<close>\ref{sec:termination} for details.)
  \<^item> Pattern matching must be performed on datatypes, instead of the more general
    @{command code_datatype}s.
  \<^item> The set of code equations must be exhaustive and non-overlapping.
\<close>

end