(*  Title:       Safe OCL
    Author:      Denis Nikiforov, March 2019
    Maintainer:  Denis Nikiforov <denis.nikif at gmail.com>
    License:     LGPL
*)
section \<open>Finite Maps\<close>
theory Finite_Map_Ext
  imports "HOL-Library.Finite_Map"
begin

type_notation fmap ("(_ \<rightharpoonup>\<^sub>f /_)" [22, 21] 21)

nonterminal fmaplets and fmaplet

syntax
  "_fmaplet"  :: "['a, 'a] \<Rightarrow> fmaplet"              ("_ /\<mapsto>\<^sub>f/ _")
  "_fmaplets" :: "['a, 'a] \<Rightarrow> fmaplet"              ("_ /[\<mapsto>\<^sub>f]/ _")
  ""          :: "fmaplet \<Rightarrow> fmaplets"              ("_")
  "_FMaplets" :: "[fmaplet, fmaplets] \<Rightarrow> fmaplets"  ("_,/ _")
  "_FMapUpd"  :: "['a \<rightharpoonup> 'b, fmaplets] \<Rightarrow> 'a \<rightharpoonup> 'b" ("_/'(_')" [900, 0] 900)
  "_FMap"     :: "fmaplets \<Rightarrow> 'a \<rightharpoonup> 'b"             ("(1[_])")

syntax (ASCII)
  "_fmaplet"  :: "['a, 'a] \<Rightarrow> fmaplet"              ("_ /|->f/ _")
  "_fmaplets" :: "['a, 'a] \<Rightarrow> fmaplet"              ("_ /[|->f]/ _")

translations
  "_FMapUpd m (_FMaplets xy ms)"      \<rightleftharpoons> "_FMapUpd (_FMapUpd m xy) ms"
  "_FMapUpd m (_fmaplet  x y)"        \<rightleftharpoons> "CONST fmupd x y m"
  "_FMap ms"                          \<rightleftharpoons> "_FMapUpd (CONST fmempty) ms"
  "_FMap (_FMaplets ms1 ms2)"         \<leftharpoondown> "_FMapUpd (_FMap ms1) ms2"
  "_FMaplets ms1 (_FMaplets ms2 ms3)" \<leftharpoondown> "_FMaplets (_FMaplets ms1 ms2) ms3"

(*** Helper Lemmas **********************************************************)

subsection \<open>Helper Lemmas\<close>

lemma fmrel_on_fset_fmdom:
  "fmrel_on_fset (fmdom ym) f xm ym \<Longrightarrow>
   k |\<in>| fmdom ym \<Longrightarrow>
   k |\<in>| fmdom xm"
  by (metis fmdom_notD fmdom_notI fmrel_on_fsetD option.rel_sel)

lemma not_fmempty_eq_fmran_not_fempty:
  "(xm \<noteq> fmempty) = (fmran xm \<noteq> fempty)"
  apply (induct xm)
  apply simp
  by (metis fempty_iff fmranI fmran_empty fmupd_lookup)

(*** Finite Map Merge *******************************************************)

subsection \<open>Merge Operation\<close>

definition "fmmerge f xm ym \<equiv>
  fmap_of_list (map
    (\<lambda>k. (k, f (the (fmlookup xm k)) (the (fmlookup ym k))))
    (sorted_list_of_fset (fmdom xm |\<inter>| fmdom ym)))"

lemma fmdom_fmmerge [simp]:
  "fmdom (fmmerge g xm ym) = fmdom xm |\<inter>| fmdom ym"
  by (auto simp add: fmmerge_def fmdom_of_list)

lemma fmmerge_commut:
  assumes "\<And>x y. x \<in> fmran' xm \<Longrightarrow> f x y = f y x"
  shows "fmmerge f xm ym = fmmerge f ym xm"
proof -
  obtain zm where zm: "zm = sorted_list_of_fset (fmdom xm |\<inter>| fmdom ym)"
    by auto
  with assms have
    "map (\<lambda>k. (k, f (the (fmlookup xm k)) (the (fmlookup ym k)))) zm =
     map (\<lambda>k. (k, f (the (fmlookup ym k)) (the (fmlookup xm k)))) zm"
    by (auto) (metis fmdom_notI fmran'I notin_fset option.collapse)
  thus ?thesis
    unfolding fmmerge_def zm
    by (metis (no_types, lifting) inf_commute)
qed

lemma fmrel_on_fset_fmmerge1 [intro]:
  assumes "\<And>x y z. z \<in> fmran' zm \<Longrightarrow> f x z \<Longrightarrow> f y z \<Longrightarrow> f (g x y) z"
  assumes "fmrel_on_fset (fmdom zm) f xm zm"
  assumes "fmrel_on_fset (fmdom zm) f ym zm"
  shows "fmrel_on_fset (fmdom zm) f (fmmerge g xm ym) zm"
proof -
  {
    fix x a b c
    assume "x |\<in>| fmdom zm"
    moreover hence "x |\<in>| fmdom xm |\<inter>| fmdom ym"
      by (meson assms(2) assms(3) finterI fmrel_on_fset_fmdom)
    moreover assume "fmlookup xm x = Some a"
                and "fmlookup ym x = Some b"
                and "fmlookup zm x = Some c"
    moreover from assms calculation have "f (g a b) c"
      by (metis fmran'I fmrel_on_fsetD option.rel_inject(2))
    ultimately have
      "rel_option f (fmlookup (fmmerge g xm ym) x) (fmlookup zm x)"
      unfolding fmmerge_def fmlookup_of_list apply simp
      unfolding option_rel_Some2 apply (rule_tac ?x="g a b" in exI)
      unfolding map_of_map_restrict restrict_map_def
      by (auto simp: fmember.rep_eq)
  }
  with assms(2) assms(3) show ?thesis
    by (meson fmdomE fmrel_on_fsetI fmrel_on_fset_fmdom)
qed

lemma fmrel_on_fset_fmmerge2 [intro]:
  assumes "\<And>x y. x \<in> fmran' xm \<Longrightarrow> f x (g x y)"
  shows "fmrel_on_fset (fmdom ym) f xm (fmmerge g xm ym)"
proof -
  {
    fix x a b
    assume "x |\<in>| fmdom xm |\<inter>| fmdom ym"
       and "fmlookup xm x = Some a"
       and "fmlookup ym x = Some b"
    hence "rel_option f (fmlookup xm x) (fmlookup (fmmerge g xm ym) x)"
      unfolding fmmerge_def fmlookup_of_list apply simp
      unfolding option_rel_Some1 apply (rule_tac ?x="g a b" in exI)
      by (auto simp add: map_of_map_restrict fmember.rep_eq assms fmran'I)
  }
  with assms show ?thesis
    apply simp
    apply (rule fmrel_on_fsetI)
    by (metis (full_types) finterD1 fmdomE fmdom_fmmerge
        fmdom_notD rel_option_None2)
qed

(*** Acyclicity *************************************************************)

subsection \<open>Acyclicity\<close>

abbreviation "acyclic_on xs r \<equiv> (\<forall>x. x \<in> xs \<longrightarrow> (x, x) \<notin> r\<^sup>+)"

abbreviation "acyclicP_on xs r \<equiv> acyclic_on xs {(x, y). r x y}"

lemma fmrel_acyclic:
  "acyclicP_on (fmran' xm) R \<Longrightarrow>
   fmrel R\<^sup>+\<^sup>+ xm ym \<Longrightarrow>
   fmrel R ym xm \<Longrightarrow>
   xm = ym"
  by (metis (full_types) fmap_ext fmran'I fmrel_cases option.sel
        tranclp.trancl_into_trancl tranclp_unfold)

lemma fmrel_acyclic':
  assumes "acyclicP_on (fmran' ym) R"
  assumes "fmrel R\<^sup>+\<^sup>+ xm ym"
  assumes "fmrel R ym xm"
  shows "xm = ym"
proof -
  {
    fix x
    from assms(1) have
      "rel_option R\<^sup>+\<^sup>+ (fmlookup xm x) (fmlookup ym x) \<Longrightarrow>
       rel_option R (fmlookup ym x) (fmlookup xm x) \<Longrightarrow>
       rel_option R (fmlookup xm x) (fmlookup ym x)"
      by (metis (full_types) fmdom'_notD fmlookup_dom'_iff
            fmran'I option.rel_sel option.sel
            tranclp_into_tranclp2 tranclp_unfold)
  }
  with assms show ?thesis
    unfolding fmrel_iff
    by (metis fmap.rel_mono_strong fmrelI fmrel_acyclic tranclp.simps)
qed

lemma fmrel_on_fset_acyclic:
  "acyclicP_on (fmran' xm) R \<Longrightarrow>
   fmrel_on_fset (fmdom ym) R\<^sup>+\<^sup>+ xm ym \<Longrightarrow>
   fmrel_on_fset (fmdom xm) R ym xm \<Longrightarrow>
   xm = ym"
  unfolding fmrel_on_fset_fmrel_restrict
  by (metis (no_types, lifting) fmdom_filter fmfilter_alt_defs(5)
        fmfilter_cong fmlookup_filter fmrel_acyclic fmrel_fmdom_eq
        fmrestrict_fset_dom option.simps(3))

lemma fmrel_on_fset_acyclic':
  "acyclicP_on (fmran' ym) R \<Longrightarrow>
   fmrel_on_fset (fmdom ym) R\<^sup>+\<^sup>+ xm ym \<Longrightarrow>
   fmrel_on_fset (fmdom xm) R ym xm \<Longrightarrow>
   xm = ym"
  unfolding fmrel_on_fset_fmrel_restrict
  by (metis (no_types, lifting) ffmember_filter fmdom_filter
        fmfilter_alt_defs(5) fmfilter_cong fmrel_acyclic'
        fmrel_fmdom_eq fmrestrict_fset_dom)

(*** Transitive Closures ****************************************************)

subsection \<open>Transitive Closures\<close>

lemma fmrel_trans [trans]:
  "fmrel P xm ym \<Longrightarrow> fmrel Q ym zm \<Longrightarrow>
   (\<And>x y z. x \<in> fmran' xm \<Longrightarrow> P x y \<Longrightarrow> Q y z \<Longrightarrow> R x z) \<Longrightarrow>
   fmrel R xm zm"
  unfolding fmrel_iff
  by (metis fmdomE fmdom_notD fmran'I option.rel_inject(2) option.rel_sel)

lemma fmrel_on_fset_trans [trans]:
  "fmrel_on_fset (fmdom ym) P xm ym \<Longrightarrow>
   fmrel_on_fset (fmdom zm) Q ym zm \<Longrightarrow>
   (\<And>x y z. x \<in> fmran' xm \<Longrightarrow> P x y \<Longrightarrow> Q y z \<Longrightarrow> R x z) \<Longrightarrow>
   fmrel_on_fset (fmdom zm) R xm zm"
  apply (rule fmrel_on_fsetI)
  unfolding option.rel_sel apply simp
  apply (meson fmdom_notI fmrel_on_fset_fmdom)
  by (metis fmdom_notI fmran'I fmrel_on_fsetD fmrel_on_fset_fmdom
            option.rel_sel option.sel)

lemma trancl_to_fmrel:
  "(fmrel R)\<^sup>+\<^sup>+ xm ym \<Longrightarrow> fmrel R\<^sup>+\<^sup>+ xm ym"
  apply (induct rule: tranclp_induct)
  apply (simp add: fmap.rel_mono_strong)
  by (rule_tac ?P="R\<^sup>+\<^sup>+" and ?Q="R" in fmrel_trans; auto)

lemma fmrel_trancl_fmdom_eq:
  "(fmrel R)\<^sup>+\<^sup>+ xm ym \<Longrightarrow> fmdom xm = fmdom ym"
  by (induct rule: tranclp_induct; simp add: fmrel_fmdom_eq)

text \<open>
  The proof was derived from the accepted answer on the website
  Stack Overflow that is available at
  @{url "https://stackoverflow.com/a/53585232/632199"}
  and provided with the permission of the author of the answer.\<close>

lemma fmupd_fmdrop:
  "fmlookup xm k = Some x \<Longrightarrow>
   xm = fmupd k x (fmdrop k xm)"
  apply (rule fmap_ext)
  unfolding fmlookup_drop fmupd_lookup
  by auto

lemma fmap_eqdom_Cons1:
  assumes "fmlookup xm i = None"
      and "fmdom (fmupd i x xm) = fmdom ym"
      and "fmrel R (fmupd i x xm) ym"
    shows "(\<exists>z zm. fmlookup zm i = None \<and> ym = (fmupd i z zm) \<and>
                   R x z \<and> fmrel R xm zm)"
proof -
  from assms(2) obtain y where "fmlookup ym i = Some y" by force
  then obtain z zm where z_zm: "ym = fmupd i z zm \<and> fmlookup zm i = None"
    using fmupd_fmdrop by force
  {
    assume "\<not> R x z"
    with z_zm have "\<not> fmrel R (fmupd i x xm) ym"
      by (metis fmrel_iff fmupd_lookup option.simps(11))
  }
  with assms(3) moreover have "R x z" by auto
  {
    assume "\<not> fmrel R xm zm"
    with assms(1) have "\<not> fmrel R (fmupd i x xm) ym"
      by (metis fmrel_iff fmupd_lookup option.rel_sel z_zm)
  }
  with assms(3) moreover have "fmrel R xm zm" by auto
  ultimately show ?thesis using z_zm by blast
qed

text \<open>
  The proof was derived from the accepted answer on the website
  Stack Overflow that is available at
  @{url "https://stackoverflow.com/a/53585232/632199"}
  and provided with the permission of the author of the answer.\<close>

lemma fmap_eqdom_induct [consumes 2, case_names nil step]:
  assumes R: "fmrel R xm ym"
    and dom_eq: "fmdom xm = fmdom ym"
    and nil: "P (fmap_of_list []) (fmap_of_list [])"
    and step:
    "\<And>x xm y ym i.
    \<lbrakk>R x y; fmrel R xm ym; fmdom xm = fmdom ym; P xm ym\<rbrakk> \<Longrightarrow>
    P (fmupd i x xm) (fmupd i y ym)"
  shows "P xm ym"
  using R dom_eq
proof (induct xm arbitrary: ym)
  case fmempty thus ?case
    by (metis fempty_iff fmdom_empty fmempty_of_list fmfilter_alt_defs(5)
              fmfilter_false fmrestrict_fset_dom local.nil)
next
  case (fmupd i x xm) show ?case
  proof -
    obtain y where "fmlookup ym i = Some y"
      by (metis fmupd.prems(1) fmrel_cases fmupd_lookup option.discI)
    from fmupd.hyps(2) fmupd.prems(1) fmupd.prems(2) obtain z zm where
      "fmlookup zm i = None" and
      ym_eq_z_zm: "ym = (fmupd i z zm)" and
      R_x_z: "R x z" and
      R_xm_zm: "fmrel R xm zm"
      using fmap_eqdom_Cons1 by metis
    hence dom_xm_eq_dom_zm: "fmdom xm = fmdom zm"
      using fmrel_fmdom_eq by blast
    with R_xm_zm fmupd.hyps(1) have "P xm zm" by blast
    with R_x_z R_xm_zm dom_xm_eq_dom_zm have
      "P (fmupd i x xm) (fmupd i z zm)"
      by (rule step)
    thus ?thesis by (simp add: ym_eq_z_zm)
  qed
qed

text \<open>
  The proof was derived from the accepted answer on the website
  Stack Overflow that is available at
  @{url "https://stackoverflow.com/a/53585232/632199"}
  and provided with the permission of the author of the answer.\<close>

lemma fmrel_to_rtrancl:
  assumes as_r: "reflp R"
      and rel_rpp_xm_ym: "fmrel R\<^sup>*\<^sup>* xm ym"
    shows "(fmrel R)\<^sup>*\<^sup>* xm ym"
proof -
  from rel_rpp_xm_ym have "fmdom xm = fmdom ym"
    using fmrel_fmdom_eq by blast
  with rel_rpp_xm_ym show "(fmrel R)\<^sup>*\<^sup>* xm ym"
  proof (induct rule: fmap_eqdom_induct)
    case nil show ?case by auto
  next
    case (step x xm y ym i) show ?case
    proof -
      from step.hyps(1) have "(fmrel R)\<^sup>*\<^sup>* (fmupd i x xm) (fmupd i y xm)"
      proof (induct rule: rtranclp_induct)
        case base show ?case by simp
      next
        case (step y z) show ?case
        proof -
          from as_r have "fmrel R xm xm"
            by (simp add: fmap.rel_reflp reflpD)
          with step.hyps(2) have "(fmrel R)\<^sup>*\<^sup>* (fmupd i y xm) (fmupd i z xm)"
            by (simp add: fmrel_upd r_into_rtranclp)
          with step.hyps(3) show ?thesis by simp
        qed
      qed
      also from step.hyps(4) have "(fmrel R)\<^sup>*\<^sup>* (fmupd i y xm) (fmupd i y ym)"
      proof (induct rule: rtranclp_induct)
        case base show ?case by simp
      next
        case (step ya za) show ?case
        proof -
          from step.hyps(2) as_r have "(fmrel R)\<^sup>*\<^sup>* (fmupd i y ya) (fmupd i y za)"
            by (simp add: fmrel_upd r_into_rtranclp reflp_def)
          with step.hyps(3) show ?thesis by simp
        qed
      qed
      finally show ?thesis by simp
    qed
  qed
qed

text \<open>
  The proof was derived from the accepted answer on the website
  Stack Overflow that is available at
  @{url "https://stackoverflow.com/a/53585232/632199"}
  and provided with the permission of the author of the answer.\<close>

lemma fmrel_to_trancl:
  assumes "reflp R"
      and "fmrel R\<^sup>+\<^sup>+ xm ym"
    shows "(fmrel R)\<^sup>+\<^sup>+ xm ym"
proof -
  from assms(2) have "fmrel R\<^sup>*\<^sup>* xm ym"
    by (drule_tac ?Ra="R\<^sup>*\<^sup>*" in fmap.rel_mono_strong; auto)
  with assms(1) have "(fmrel R)\<^sup>*\<^sup>* xm ym"
    by (simp add: fmrel_to_rtrancl)
  with assms(1) show ?thesis
    by (metis fmap.rel_reflp reflpD rtranclpD tranclp.r_into_trancl)
qed

lemma fmrel_tranclp_induct:
  "fmrel R\<^sup>+\<^sup>+ a b \<Longrightarrow>
   reflp R \<Longrightarrow>
   (\<And>y. fmrel R a y \<Longrightarrow> P y) \<Longrightarrow>
   (\<And>y z. (fmrel R)\<^sup>+\<^sup>+ a y \<Longrightarrow> fmrel R y z \<Longrightarrow> P y \<Longrightarrow> P z) \<Longrightarrow> P b"
  apply (drule fmrel_to_trancl, simp)
  by (erule tranclp_induct; simp)

lemma fmrel_converse_tranclp_induct:
  "fmrel R\<^sup>+\<^sup>+ a b \<Longrightarrow>
   reflp R \<Longrightarrow>
   (\<And>y. fmrel R y b \<Longrightarrow> P y) \<Longrightarrow>
   (\<And>y z. fmrel R y z \<Longrightarrow> fmrel R\<^sup>+\<^sup>+ z b \<Longrightarrow> P z \<Longrightarrow> P y) \<Longrightarrow> P a"
  apply (drule fmrel_to_trancl, simp)
  by (erule converse_tranclp_induct; simp add: trancl_to_fmrel)

lemma fmrel_tranclp_trans_induct:
  "fmrel R\<^sup>+\<^sup>+ a b \<Longrightarrow>
   reflp R \<Longrightarrow>
   (\<And>x y. fmrel R x y \<Longrightarrow> P x y) \<Longrightarrow>
   (\<And>x y z. fmrel R\<^sup>+\<^sup>+ x y \<Longrightarrow> P x y \<Longrightarrow> fmrel R\<^sup>+\<^sup>+ y z \<Longrightarrow> P y z \<Longrightarrow> P x z) \<Longrightarrow>
   P a b"
  apply (drule fmrel_to_trancl, simp)
  apply (erule tranclp_trans_induct, simp)
  using trancl_to_fmrel by blast

(*** Finite Map Size Calculation ********************************************)

subsection \<open>Size Calculation\<close>

text \<open>
  The contents of the subsection was derived from the accepted answer
  on the website Stack Overflow that is available at
  @{url "https://stackoverflow.com/a/53244203/632199"}
  and provided with the permission of the author of the answer.\<close>

abbreviation "tcf \<equiv> (\<lambda> v::('a \<times> nat). (\<lambda> r::nat. snd v + r))"

interpretation tcf: comp_fun_commute tcf
proof
  fix x y :: "'a \<times> nat"
  show "tcf y \<circ> tcf x = tcf x \<circ> tcf y"
  proof -
    fix z
    have "(tcf y \<circ> tcf x) z = snd y + snd x + z" by auto
    also have "(tcf x \<circ> tcf y) z = snd y + snd x + z" by auto
    finally have "(tcf y \<circ> tcf x) z = (tcf x \<circ> tcf y) z" by auto
    thus "(tcf y \<circ> tcf x) = (tcf x \<circ> tcf y)" by auto
  qed
qed

lemma ffold_rec_exp:
  assumes "k |\<in>| fmdom xm"
    and "ky = (k, the (fmlookup (fmmap f xm) k))"
  shows "ffold tcf 0 (fset_of_fmap (fmmap f xm)) =
        tcf ky (ffold tcf 0 ((fset_of_fmap (fmmap f xm)) |-| {|ky|}))"
proof -
  have "ky |\<in>| (fset_of_fmap (fmmap f xm))"
    using assms by auto
  thus ?thesis
    by (simp add: tcf.ffold_rec)
qed

lemma elem_le_ffold' [intro]:
  "z \<in> fmran' xm \<Longrightarrow>
   f z < Suc (ffold tcf 0 (fset_of_fmap (fmmap f xm)))"
  apply (erule fmran'E)
  apply (frule fmdomI)
  by (subst ffold_rec_exp, auto)

(*** Code Setup *************************************************************)

subsection \<open>Code Setup\<close>

abbreviation "fmmerge_fun f xm ym \<equiv>
  fmap_of_list (map
    (\<lambda>k. if k |\<in>| fmdom xm \<and> k |\<in>| fmdom ym
         then (k, f (the (fmlookup xm k)) (the (fmlookup ym k)))
         else (k, undefined))
    (sorted_list_of_fset (fmdom xm |\<inter>| fmdom ym)))"

lemma fmmerge_fun_simp [code_abbrev, simp]:
  "fmmerge_fun f xm ym = fmmerge f xm ym"
  unfolding fmmerge_def
  apply (rule_tac ?f="fmap_of_list" in HOL.arg_cong)
  by (simp add: notin_fset)

end


section \<open>Standard Models\<close>
text \<open>We define the kind of models we are interested in here.
      In particular, we care about standard graphs.
      To allow some reuse, we distinguish a generic version called @{term standard},
      from an instantiated abbreviation @{term standard'}.
      There is little we can prove about these definition here, except for Lemma 2.\<close>
theory StandardModels
imports LabeledGraphSemantics Main
begin

abbreviation "a_bot \<equiv> A_Lbl S_Bot"
abbreviation "a_top \<equiv> A_Lbl S_Top"
abbreviation "a_idt \<equiv> A_Lbl S_Idt"
notation a_bot ("\<bottom>")
notation a_top ("\<top>")
notation a_idt ("\<one>")

type_synonym 'v std_term = "'v Standard_Constant allegorical_term"
type_synonym 'v std_sentence = "'v std_term \<times> 'v std_term"
type_synonym ('v,'a) std_graph = "('v Standard_Constant, ('v+'a)) labeled_graph"

abbreviation ident_rel where
"ident_rel idt G \<equiv> getRel idt G = (\<lambda> x.(x,x)) ` vertices G"

lemma ident_relI[intro]:
  assumes min:"\<And> x. x \<in> vertices G \<Longrightarrow> (x,x) \<in> getRel idt G"
  and max1:"\<And> x y. (x,y) \<in> getRel idt G \<Longrightarrow> x = y"
  and max2:"\<And> x y. (x,y) \<in> getRel idt G \<Longrightarrow> x \<in> vertices G"
shows "ident_rel idt G"
proof
  from max1 max2 have "\<And> x y. (x,y) \<in> getRel idt G \<Longrightarrow> (x = y \<and> x \<in> vertices G)" by simp
  thus "getRel idt G \<subseteq> (\<lambda>x. (x, x)) ` vertices G" by auto
  show "(\<lambda>x. (x, x)) ` vertices G \<subseteq> getRel idt G" using min by auto
qed

text \<open>Definition 4, generically.\<close>
definition standard :: "('l \<times> 'v) set \<Rightarrow> 'l \<Rightarrow> 'l \<Rightarrow> 'l \<Rightarrow> ('l, 'v) labeled_graph \<Rightarrow> bool" where
"standard C b t idt G
   \<equiv> G = restrict G
   \<and> vertices G \<noteq> {}
   \<and> ident_rel idt G
   \<and> getRel b G = {}
   \<and> getRel t G = {(x,y). x\<in>vertices G \<and> y\<in>vertices G}
   \<and> (\<forall> (l,v) \<in> C. getRel l G = {(v,v)})"

text \<open>Definition 4.\<close>
abbreviation standard' :: "'v set \<Rightarrow> ('v,'a) std_graph \<Rightarrow> bool" where
"standard' C \<equiv> standard ((\<lambda> c. (S_Const c,Inl c)) ` C) S_Bot S_Top S_Idt"

text \<open>Definition 5.\<close>
definition model :: "'v set \<Rightarrow> ('v,'a) std_graph \<Rightarrow> ('v std_sentence) set \<Rightarrow> bool" where
"model C G T \<equiv> standard' C G \<and> (\<forall> S \<in> T. G \<Turnstile> S)"

text \<open>Definition 5.\<close>
abbreviation consistent :: "'b itself \<Rightarrow> 'v set \<Rightarrow> ('v std_sentence) set \<Rightarrow> bool" where
"consistent _ C T \<equiv> \<exists> (G::('v,'b) std_graph). model C G T"

text \<open>Definition 6.\<close>
definition entails :: "'b itself \<Rightarrow> 'v set \<Rightarrow> ('v std_sentence) set \<Rightarrow> 'v std_sentence \<Rightarrow> bool"  where
"entails _ C T S \<equiv> \<forall> (G::('v,'b) std_graph). model C G T \<longrightarrow> G \<Turnstile> S"

lemma standard_top_not_bot[intro]:
"standard' C G \<Longrightarrow> :G:\<lbrakk>\<bottom>\<rbrakk> \<noteq> :G:\<lbrakk>\<top>\<rbrakk>"
  unfolding standard_def by auto

text \<open>Lemma 2.\<close>
lemma consistent_iff_entails_nonsense:
"consistent t C T = (\<not> entails t C T (\<bottom>,\<top>))"
proof
  show "consistent t C T \<Longrightarrow> \<not> entails t C T (\<bottom>, \<top>)"
    using standard_top_not_bot unfolding entails_def model_def
    by fastforce
qed (auto simp:entails_def model_def)

end


(* Author: Gerwin Klein, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

header "Standard Heaps as an Instance of Separation Algebra"

theory Sep_Heap_Instance
imports Separation_Algebra
begin

text {*
  Example instantiation of a the separation algebra to a map, i.e.\ a
  function from any type to @{typ "'a option"}.
*}

class opt =
  fixes none :: 'a
begin
  definition "domain f \<equiv> {x. f x \<noteq> none}"
end

instantiation option :: (type) opt
begin
  definition none_def [simp]: "none \<equiv> None"
  instance ..
end

instantiation "fun" :: (type, opt) zero
begin
  definition zero_fun_def: "0 \<equiv> \<lambda>s. none"
  instance ..
end

instantiation "fun" :: (type, opt) sep_algebra
begin

definition
  plus_fun_def: "m1 + m2 \<equiv> \<lambda>x. if m2 x = none then m1 x else m2 x"

definition
  sep_disj_fun_def: "sep_disj m1 m2 \<equiv> domain m1 \<inter> domain m2 = {}"

instance
  apply default
        apply (simp add: sep_disj_fun_def domain_def zero_fun_def)
       apply (fastforce simp: sep_disj_fun_def)
      apply (simp add: plus_fun_def zero_fun_def)
     apply (simp add: plus_fun_def sep_disj_fun_def domain_def)
     apply (rule ext)
     apply fastforce
    apply (rule ext)
    apply (simp add: plus_fun_def)
   apply (simp add: sep_disj_fun_def domain_def plus_fun_def)
   apply fastforce
  apply (simp add: sep_disj_fun_def domain_def plus_fun_def)
  apply fastforce
  done

end

text {*
  For the actual option type @{const domain} and @{text "+"} are
  just @{const dom} and @{text "++"}:
*}

lemma domain_conv: "domain = dom"
  by (rule ext) (simp add: domain_def dom_def)

lemma plus_fun_conv: "a + b = a ++ b"
  by (auto simp: plus_fun_def map_add_def split: option.splits)

lemmas map_convs = domain_conv plus_fun_conv

text {*
  Any map can now act as a separation heap without further work:
*}
lemma
  fixes h :: "(nat => nat) => 'foo option"
  shows "(P ** Q ** H) h = (Q ** H ** P) h"
  by (simp add: sep_conj_ac)

end


(*  Title:      ZF/Induct/Tree_Forest.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Trees and forests, a mutually recursive type definition\<close>

theory Tree_Forest imports ZF begin

subsection \<open>Datatype definition\<close>

consts
  tree :: "i => i"
  forest :: "i => i"
  tree_forest :: "i => i"

datatype "tree(A)" = Tcons ("a \<in> A", "f \<in> forest(A)")
  and "forest(A)" = Fnil | Fcons ("t \<in> tree(A)", "f \<in> forest(A)")

(* FIXME *)
lemmas tree'induct =
    tree_forest.mutual_induct [THEN conjunct1, THEN spec, THEN [2] rev_mp, of concl: _ t, consumes 1]
  and forest'induct =
    tree_forest.mutual_induct [THEN conjunct2, THEN spec, THEN [2] rev_mp, of concl: _ f, consumes 1]
  for t f

declare tree_forest.intros [simp, TC]

lemma tree_def: "tree(A) == Part(tree_forest(A), Inl)"
  by (simp only: tree_forest.defs)

lemma forest_def: "forest(A) == Part(tree_forest(A), Inr)"
  by (simp only: tree_forest.defs)

text \<open>
  \medskip \<^term>\<open>tree_forest(A)\<close> as the union of \<^term>\<open>tree(A)\<close>
  and \<^term>\<open>forest(A)\<close>.
\<close>

lemma tree_subset_TF: "tree(A) \<subseteq> tree_forest(A)"
  apply (unfold tree_forest.defs)
  apply (rule Part_subset)
  done

lemma treeI [TC]: "x \<in> tree(A) ==> x \<in> tree_forest(A)"
  by (rule tree_subset_TF [THEN subsetD])

lemma forest_subset_TF: "forest(A) \<subseteq> tree_forest(A)"
  apply (unfold tree_forest.defs)
  apply (rule Part_subset)
  done

lemma treeI' [TC]: "x \<in> forest(A) ==> x \<in> tree_forest(A)"
  by (rule forest_subset_TF [THEN subsetD])

lemma TF_equals_Un: "tree(A) \<union> forest(A) = tree_forest(A)"
  apply (insert tree_subset_TF forest_subset_TF)
  apply (auto intro!: equalityI tree_forest.intros elim: tree_forest.cases)
  done

lemma tree_forest_unfold:
  "tree_forest(A) = (A \<times> forest(A)) + ({0} + tree(A) \<times> forest(A))"
    \<comment> \<open>NOT useful, but interesting \dots\<close>
  supply rews = tree_forest.con_defs tree_def forest_def
  apply (unfold tree_def forest_def)
  apply (fast intro!: tree_forest.intros [unfolded rews, THEN PartD1]
    elim: tree_forest.cases [unfolded rews])
  done

lemma tree_forest_unfold':
  "tree_forest(A) =
    A \<times> Part(tree_forest(A), \<lambda>w. Inr(w)) +
    {0} + Part(tree_forest(A), \<lambda>w. Inl(w)) * Part(tree_forest(A), \<lambda>w. Inr(w))"
  by (rule tree_forest_unfold [unfolded tree_def forest_def])

lemma tree_unfold: "tree(A) = {Inl(x). x \<in> A \<times> forest(A)}"
  apply (unfold tree_def forest_def)
  apply (rule Part_Inl [THEN subst])
  apply (rule tree_forest_unfold' [THEN subst_context])
  done

lemma forest_unfold: "forest(A) = {Inr(x). x \<in> {0} + tree(A)*forest(A)}"
  apply (unfold tree_def forest_def)
  apply (rule Part_Inr [THEN subst])
  apply (rule tree_forest_unfold' [THEN subst_context])
  done

text \<open>
  \medskip Type checking for recursor: Not needed; possibly interesting?
\<close>

lemma TF_rec_type:
  "[| z \<in> tree_forest(A);
      !!x f r. [| x \<in> A;  f \<in> forest(A);  r \<in> C(f)
                |] ==> b(x,f,r) \<in> C(Tcons(x,f));
      c \<in> C(Fnil);
      !!t f r1 r2. [| t \<in> tree(A);  f \<in> forest(A);  r1 \<in> C(t); r2 \<in> C(f)
                    |] ==> d(t,f,r1,r2) \<in> C(Fcons(t,f))
   |] ==> tree_forest_rec(b,c,d,z) \<in> C(z)"
  by (induct_tac z) simp_all

lemma tree_forest_rec_type:
  "[| !!x f r. [| x \<in> A;  f \<in> forest(A);  r \<in> D(f)
                |] ==> b(x,f,r) \<in> C(Tcons(x,f));
      c \<in> D(Fnil);
      !!t f r1 r2. [| t \<in> tree(A);  f \<in> forest(A);  r1 \<in> C(t); r2 \<in> D(f)
                    |] ==> d(t,f,r1,r2) \<in> D(Fcons(t,f))
   |] ==> (\<forall>t \<in> tree(A).    tree_forest_rec(b,c,d,t) \<in> C(t)) \<and>
          (\<forall>f \<in> forest(A). tree_forest_rec(b,c,d,f) \<in> D(f))"
    \<comment> \<open>Mutually recursive version.\<close>
  apply (unfold Ball_def)
  apply (rule tree_forest.mutual_induct)
  apply simp_all
  done

subsection \<open>Operations\<close>

consts
  map :: "[i => i, i] => i"
  size :: "i => i"
  preorder :: "i => i"
  list_of_TF :: "i => i"
  of_list :: "i => i"
  reflect :: "i => i"

primrec
  "list_of_TF (Tcons(x,f)) = [Tcons(x,f)]"
  "list_of_TF (Fnil) = []"
  "list_of_TF (Fcons(t,tf)) = Cons (t, list_of_TF(tf))"

primrec
  "of_list([]) = Fnil"
  "of_list(Cons(t,l)) = Fcons(t, of_list(l))"

primrec
  "map (h, Tcons(x,f)) = Tcons(h(x), map(h,f))"
  "map (h, Fnil) = Fnil"
  "map (h, Fcons(t,tf)) = Fcons (map(h, t), map(h, tf))"

primrec
  "size (Tcons(x,f)) = succ(size(f))"
  "size (Fnil) = 0"
  "size (Fcons(t,tf)) = size(t) #+ size(tf)"

primrec
  "preorder (Tcons(x,f)) = Cons(x, preorder(f))"
  "preorder (Fnil) = Nil"
  "preorder (Fcons(t,tf)) = preorder(t) @ preorder(tf)"

primrec
  "reflect (Tcons(x,f)) = Tcons(x, reflect(f))"
  "reflect (Fnil) = Fnil"
  "reflect (Fcons(t,tf)) =
    of_list (list_of_TF (reflect(tf)) @ Cons(reflect(t), Nil))"

text \<open>
  \medskip \<open>list_of_TF\<close> and \<open>of_list\<close>.
\<close>

lemma list_of_TF_type [TC]:
    "z \<in> tree_forest(A) ==> list_of_TF(z) \<in> list(tree(A))"
  by (induct set: tree_forest) simp_all

lemma of_list_type [TC]: "l \<in> list(tree(A)) ==> of_list(l) \<in> forest(A)"
  by (induct set: list) simp_all

text \<open>
  \medskip \<open>map\<close>.
\<close>

lemma
  assumes "!!x. x \<in> A ==> h(x): B"
  shows map_tree_type: "t \<in> tree(A) ==> map(h,t) \<in> tree(B)"
    and map_forest_type: "f \<in> forest(A) ==> map(h,f) \<in> forest(B)"
  using assms
  by (induct rule: tree'induct forest'induct) simp_all

text \<open>
  \medskip \<open>size\<close>.
\<close>

lemma size_type [TC]: "z \<in> tree_forest(A) ==> size(z) \<in> nat"
  by (induct set: tree_forest) simp_all

text \<open>
  \medskip \<open>preorder\<close>.
\<close>

lemma preorder_type [TC]: "z \<in> tree_forest(A) ==> preorder(z) \<in> list(A)"
  by (induct set: tree_forest) simp_all

text \<open>
  \medskip Theorems about \<open>list_of_TF\<close> and \<open>of_list\<close>.
\<close>

lemma forest_induct [consumes 1, case_names Fnil Fcons]:
  "[| f \<in> forest(A);
      R(Fnil);
      !!t f. [| t \<in> tree(A);  f \<in> forest(A);  R(f) |] ==> R(Fcons(t,f))
   |] ==> R(f)"
  \<comment> \<open>Essentially the same as list induction.\<close>
  apply (erule tree_forest.mutual_induct
      [THEN conjunct2, THEN spec, THEN [2] rev_mp])
    apply (rule TrueI)
   apply simp
  apply simp
  done

lemma forest_iso: "f \<in> forest(A) ==> of_list(list_of_TF(f)) = f"
  by (induct rule: forest_induct) simp_all

lemma tree_list_iso: "ts: list(tree(A)) ==> list_of_TF(of_list(ts)) = ts"
  by (induct set: list) simp_all

text \<open>
  \medskip Theorems about \<open>map\<close>.
\<close>

lemma map_ident: "z \<in> tree_forest(A) ==> map(\<lambda>u. u, z) = z"
  by (induct set: tree_forest) simp_all

lemma map_compose:
    "z \<in> tree_forest(A) ==> map(h, map(j,z)) = map(\<lambda>u. h(j(u)), z)"
  by (induct set: tree_forest) simp_all

text \<open>
  \medskip Theorems about \<open>size\<close>.
\<close>

lemma size_map: "z \<in> tree_forest(A) ==> size(map(h,z)) = size(z)"
  by (induct set: tree_forest) simp_all

lemma size_length: "z \<in> tree_forest(A) ==> size(z) = length(preorder(z))"
  by (induct set: tree_forest) (simp_all add: length_app)

text \<open>
  \medskip Theorems about \<open>preorder\<close>.
\<close>

lemma preorder_map:
    "z \<in> tree_forest(A) ==> preorder(map(h,z)) = List.map(h, preorder(z))"
  by (induct set: tree_forest) (simp_all add: map_app_distrib)

end


section\<open>Number theory problems\<close>

subsection \<open>IMO 2017 SL - N1\<close>

theory IMO_2017_SL_N1
imports Complex_Main
begin
(*
lemma square_mod_3:
  fixes x :: nat
  shows "(x * x) mod 3 = 0 \<longleftrightarrow> x mod 3 = 0"
  sorry

lemma square_mod_3_not_2:
  fixes s :: nat
  shows "(s * s) mod 3 \<noteq> 2"
  sorry

lemma not_square_3:
  shows "\<not> (\<exists> s::nat. s * s = 3)"
  sorry

lemma not_square_6:
  shows "\<not> (\<exists> s::nat. s * s = 6)"
  sorry

lemma not_square_7:
  shows "\<not> (\<exists> s::nat. s * s = 7)"
  sorry

lemma not_square_10:
  shows "\<not> (\<exists> s::nat. s * s = 10)"
  sorry

lemma not_square_13:
  shows "\<not> (\<exists> s::nat. s * s = 13)"
  sorry

lemma consecutive_squares_mod_3:
  fixes t :: nat
  shows "{(t + 1)\<^sup>2 mod 3, (t + 2)\<^sup>2 mod 3, (t + 3)\<^sup>2 mod 3} = {0, 1}"
  sorry

definition eventually_periodic :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
  "eventually_periodic a \<longleftrightarrow> (\<exists> p > 0. \<exists> n0. \<forall> n \<ge> n0. a (n + p) = a n)"

lemma initial_condition:
  fixes a :: "nat \<Rightarrow> 'a"
  assumes "\<forall> n. a (n + 1) = f (a n)" "a n1 = a n2"
  shows "a (n1 + k) = a (n2 + k)"
  sorry

lemma two_same_periodic:
  fixes a :: "nat \<Rightarrow> 'a"
  assumes "\<forall> n. a (n + 1) = f (a n)" "n1 < n2" "a n1 = a n2"
  shows "eventually_periodic a"
  sorry

lemma eventually_periodic_repeats:
  fixes a :: "nat \<Rightarrow> 'a"
  assumes "\<forall> n \<ge> n0. a (n + p) = a n"
  shows "\<forall> k. a (n0 + k * p) = a n0"
  sorry

lemma infinite_periodic:
  fixes a :: "nat \<Rightarrow> 'a"
  assumes "\<forall> n. a (n + 1) = f (a n)"
  shows "(\<exists> A. infinite {n. a n = A}) \<longleftrightarrow> eventually_periodic a"
  sorry

definition eventually_increasing :: "(nat \<Rightarrow> nat) \<Rightarrow> bool" where
  "eventually_increasing a \<longleftrightarrow> (\<exists> n0. \<forall> n \<ge> n0. a n < a (n + 1))"

lemma eventually_increasing:
  shows "eventually_increasing a \<longleftrightarrow> (\<exists> n0. \<forall> i j. n0 \<le> i \<and> i < j \<longrightarrow> a i < a j)"
  sorry

lemma increasing_non_periodic:
  assumes "eventually_increasing a"
  shows "\<not> eventually_periodic a"
  sorry
*)
definition sqrt_nat :: "nat \<Rightarrow> nat" where
  "sqrt_nat x = (THE s. x = s * s)"
(*
lemma sqrt_nat:
  fixes x s :: nat
  assumes "x = s * s"
  shows "sqrt_nat x = s"
  sorry

lemma Least_nat_in:
  fixes A :: "nat set"
  assumes "A \<noteq> {}"
  shows "(LEAST x. x \<in> A) \<in> A"
  sorry

lemma Least_nat_le:
  fixes A :: "nat set"
  assumes "A \<noteq> {}"
  shows "\<forall> x \<in> A. (LEAST x. x \<in> A) \<le> x"
  sorry
*)
theorem IMO_2017_SL_N1:
  fixes a :: "nat \<Rightarrow> nat"
  assumes "\<forall> n. a (n + 1) = (if (\<exists> s. a n  = s * s)
                                     then sqrt_nat (a n)
                                     else (a n) + 3)"
         and  "a 0 > 1"
  shows "(\<exists> A. infinite {n. a n = A}) \<longleftrightarrow> a 0 mod 3 = 0"
  sorry

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{Skalberg}. 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{mesfunc1,mesfunc2}. 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[p.~32f]{hurd2002}. 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{Billingsley86}. It requires some concepts of
  topologic spaces, which made the following elementary
  course, based on Bauer's excellent book \cite{Bauer}, 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{Fleuriot:2000:MNR}.}, 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 E3_2
  imports Main
begin

inductive palindromes :: "'a list \<Rightarrow> bool" where
pp0 : "palindromes []" |
pp1 : "palindromes [x]" |
ppn : "palindromes xs \<Longrightarrow> palindromes (a # xs @ [a])"

lemma "palindromes xs \<Longrightarrow> rev xs = xs"
  apply(induction xs rule : palindromes.induct)
  by auto

end


(*  Title:      ZF/Univ.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Standard notation for Vset(i) is V(i), but users might want V for a
variable.

NOTE: univ(A) could be a translation; would simplify many proofs!
  But Ind_Syntax.univ refers to the constant "Univ.univ"
*)

section\<open>The Cumulative Hierarchy and a Small Universe for Recursive Types\<close>

theory Univ imports Epsilon Cardinal begin

definition
  Vfrom       :: "[i,i]=>i"  where
    "Vfrom(A,i) == transrec(i, %x f. A \<union> (\<Union>y\<in>x. Pow(f`y)))"

abbreviation
  Vset :: "i=>i" where
  "Vset(x) == Vfrom(0,x)"

definition
  Vrec        :: "[i, [i,i]=>i] =>i"  where
    "Vrec(a,H) == transrec(rank(a), %x g. \<lambda>z\<in>Vset(succ(x)).
                           H(z, \<lambda>w\<in>Vset(x). g`rank(w)`w)) ` a"

definition
  Vrecursor   :: "[[i,i]=>i, i] =>i"  where
    "Vrecursor(H,a) == transrec(rank(a), %x g. \<lambda>z\<in>Vset(succ(x)).
                                H(\<lambda>w\<in>Vset(x). g`rank(w)`w, z)) ` a"

definition
  univ        :: "i=>i"  where
    "univ(A) == Vfrom(A,nat)"

subsection\<open>Immediate Consequences of the Definition of \<^term>\<open>Vfrom(A,i)\<close>\<close>

text\<open>NOT SUITABLE FOR REWRITING -- RECURSIVE!\<close>
lemma Vfrom: "Vfrom(A,i) = A \<union> (\<Union>j\<in>i. Pow(Vfrom(A,j)))"
by (subst Vfrom_def [THEN def_transrec], simp)

subsubsection\<open>Monotonicity\<close>

lemma Vfrom_mono [rule_format]:
     "A<=B ==> \<forall>j. i<=j \<longrightarrow> Vfrom(A,i) \<subseteq> Vfrom(B,j)"
apply (rule_tac a=i in eps_induct)
apply (rule impI [THEN allI])
apply (subst Vfrom [of A])
apply (subst Vfrom [of B])
apply (erule Un_mono)
apply (erule UN_mono, blast)
done

lemma VfromI: "[| a \<in> Vfrom(A,j);  j<i |] ==> a \<in> Vfrom(A,i)"
by (blast dest: Vfrom_mono [OF subset_refl le_imp_subset [OF leI]])

subsubsection\<open>A fundamental equality: Vfrom does not require ordinals!\<close>

lemma Vfrom_rank_subset1: "Vfrom(A,x) \<subseteq> Vfrom(A,rank(x))"
proof (induct x rule: eps_induct)
  fix x
  assume "\<forall>y\<in>x. Vfrom(A,y) \<subseteq> Vfrom(A,rank(y))"
  thus "Vfrom(A, x) \<subseteq> Vfrom(A, rank(x))"
    by (simp add: Vfrom [of _ x] Vfrom [of _ "rank(x)"],
        blast intro!: rank_lt [THEN ltD])
qed

lemma Vfrom_rank_subset2: "Vfrom(A,rank(x)) \<subseteq> Vfrom(A,x)"
apply (rule_tac a=x in eps_induct)
apply (subst Vfrom)
apply (subst Vfrom, rule subset_refl [THEN Un_mono])
apply (rule UN_least)
txt\<open>expand \<open>rank(x1) = (\<Union>y\<in>x1. succ(rank(y)))\<close> in assumptions\<close>
apply (erule rank [THEN equalityD1, THEN subsetD, THEN UN_E])
apply (rule subset_trans)
apply (erule_tac [2] UN_upper)
apply (rule subset_refl [THEN Vfrom_mono, THEN subset_trans, THEN Pow_mono])
apply (erule ltI [THEN le_imp_subset])
apply (rule Ord_rank [THEN Ord_succ])
apply (erule bspec, assumption)
done

lemma Vfrom_rank_eq: "Vfrom(A,rank(x)) = Vfrom(A,x)"
apply (rule equalityI)
apply (rule Vfrom_rank_subset2)
apply (rule Vfrom_rank_subset1)
done

subsection\<open>Basic Closure Properties\<close>

lemma zero_in_Vfrom: "y:x ==> 0 \<in> Vfrom(A,x)"
by (subst Vfrom, blast)

lemma i_subset_Vfrom: "i \<subseteq> Vfrom(A,i)"
apply (rule_tac a=i in eps_induct)
apply (subst Vfrom, blast)
done

lemma A_subset_Vfrom: "A \<subseteq> Vfrom(A,i)"
apply (subst Vfrom)
apply (rule Un_upper1)
done

lemmas A_into_Vfrom = A_subset_Vfrom [THEN subsetD]

lemma subset_mem_Vfrom: "a \<subseteq> Vfrom(A,i) ==> a \<in> Vfrom(A,succ(i))"
by (subst Vfrom, blast)

subsubsection\<open>Finite sets and ordered pairs\<close>

lemma singleton_in_Vfrom: "a \<in> Vfrom(A,i) ==> {a} \<in> Vfrom(A,succ(i))"
by (rule subset_mem_Vfrom, safe)

lemma doubleton_in_Vfrom:
     "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i) |] ==> {a,b} \<in> Vfrom(A,succ(i))"
by (rule subset_mem_Vfrom, safe)

lemma Pair_in_Vfrom:
    "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i) |] ==> <a,b> \<in> Vfrom(A,succ(succ(i)))"
apply (unfold Pair_def)
apply (blast intro: doubleton_in_Vfrom)
done

lemma succ_in_Vfrom: "a \<subseteq> Vfrom(A,i) ==> succ(a) \<in> Vfrom(A,succ(succ(i)))"
apply (intro subset_mem_Vfrom succ_subsetI, assumption)
apply (erule subset_trans)
apply (rule Vfrom_mono [OF subset_refl subset_succI])
done

subsection\<open>0, Successor and Limit Equations for \<^term>\<open>Vfrom\<close>\<close>

lemma Vfrom_0: "Vfrom(A,0) = A"
by (subst Vfrom, blast)

lemma Vfrom_succ_lemma: "Ord(i) ==> Vfrom(A,succ(i)) = A \<union> Pow(Vfrom(A,i))"
apply (rule Vfrom [THEN trans])
apply (rule equalityI [THEN subst_context,
                       OF _ succI1 [THEN RepFunI, THEN Union_upper]])
apply (rule UN_least)
apply (rule subset_refl [THEN Vfrom_mono, THEN Pow_mono])
apply (erule ltI [THEN le_imp_subset])
apply (erule Ord_succ)
done

lemma Vfrom_succ: "Vfrom(A,succ(i)) = A \<union> Pow(Vfrom(A,i))"
apply (rule_tac x1 = "succ (i)" in Vfrom_rank_eq [THEN subst])
apply (rule_tac x1 = i in Vfrom_rank_eq [THEN subst])
apply (subst rank_succ)
apply (rule Ord_rank [THEN Vfrom_succ_lemma])
done

(*The premise distinguishes this from Vfrom(A,0);  allowing X=0 forces
  the conclusion to be Vfrom(A,\<Union>(X)) = A \<union> (\<Union>y\<in>X. Vfrom(A,y)) *)
lemma Vfrom_Union: "y:X ==> Vfrom(A,\<Union>(X)) = (\<Union>y\<in>X. Vfrom(A,y))"
apply (subst Vfrom)
apply (rule equalityI)
txt\<open>first inclusion\<close>
apply (rule Un_least)
apply (rule A_subset_Vfrom [THEN subset_trans])
apply (rule UN_upper, assumption)
apply (rule UN_least)
apply (erule UnionE)
apply (rule subset_trans)
apply (erule_tac [2] UN_upper,
       subst Vfrom, erule subset_trans [OF UN_upper Un_upper2])
txt\<open>opposite inclusion\<close>
apply (rule UN_least)
apply (subst Vfrom, blast)
done

subsection\<open>\<^term>\<open>Vfrom\<close> applied to Limit Ordinals\<close>

(*NB. limit ordinals are non-empty:
      Vfrom(A,0) = A = A \<union> (\<Union>y\<in>0. Vfrom(A,y)) *)
lemma Limit_Vfrom_eq:
    "Limit(i) ==> Vfrom(A,i) = (\<Union>y\<in>i. Vfrom(A,y))"
apply (rule Limit_has_0 [THEN ltD, THEN Vfrom_Union, THEN subst], assumption)
apply (simp add: Limit_Union_eq)
done

lemma Limit_VfromE:
    "[| a \<in> Vfrom(A,i);  ~R ==> Limit(i);
        !!x. [| x<i;  a \<in> Vfrom(A,x) |] ==> R
     |] ==> R"
apply (rule classical)
apply (rule Limit_Vfrom_eq [THEN equalityD1, THEN subsetD, THEN UN_E])
  prefer 2 apply assumption
 apply blast
apply (blast intro: ltI Limit_is_Ord)
done

lemma singleton_in_VLimit:
    "[| a \<in> Vfrom(A,i);  Limit(i) |] ==> {a} \<in> Vfrom(A,i)"
apply (erule Limit_VfromE, assumption)
apply (erule singleton_in_Vfrom [THEN VfromI])
apply (blast intro: Limit_has_succ)
done

lemmas Vfrom_UnI1 =
    Un_upper1 [THEN subset_refl [THEN Vfrom_mono, THEN subsetD]]
lemmas Vfrom_UnI2 =
    Un_upper2 [THEN subset_refl [THEN Vfrom_mono, THEN subsetD]]

text\<open>Hard work is finding a single j:i such that {a,b}<=Vfrom(A,j)\<close>
lemma doubleton_in_VLimit:
    "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i) |] ==> {a,b} \<in> Vfrom(A,i)"
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption)
apply (blast intro:  VfromI [OF doubleton_in_Vfrom]
                     Vfrom_UnI1 Vfrom_UnI2 Limit_has_succ Un_least_lt)
done

lemma Pair_in_VLimit:
    "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i) |] ==> <a,b> \<in> Vfrom(A,i)"
txt\<open>Infer that a, b occur at ordinals x,xa < i.\<close>
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption)
txt\<open>Infer that \<^term>\<open>succ(succ(x \<union> xa)) < i\<close>\<close>
apply (blast intro: VfromI [OF Pair_in_Vfrom]
                    Vfrom_UnI1 Vfrom_UnI2 Limit_has_succ Un_least_lt)
done

lemma product_VLimit: "Limit(i) ==> Vfrom(A,i) * Vfrom(A,i) \<subseteq> Vfrom(A,i)"
by (blast intro: Pair_in_VLimit)

lemmas Sigma_subset_VLimit =
     subset_trans [OF Sigma_mono product_VLimit]

lemmas nat_subset_VLimit =
     subset_trans [OF nat_le_Limit [THEN le_imp_subset] i_subset_Vfrom]

lemma nat_into_VLimit: "[| n: nat;  Limit(i) |] ==> n \<in> Vfrom(A,i)"
by (blast intro: nat_subset_VLimit [THEN subsetD])

subsubsection\<open>Closure under Disjoint Union\<close>

lemmas zero_in_VLimit = Limit_has_0 [THEN ltD, THEN zero_in_Vfrom]

lemma one_in_VLimit: "Limit(i) ==> 1 \<in> Vfrom(A,i)"
by (blast intro: nat_into_VLimit)

lemma Inl_in_VLimit:
    "[| a \<in> Vfrom(A,i); Limit(i) |] ==> Inl(a) \<in> Vfrom(A,i)"
apply (unfold Inl_def)
apply (blast intro: zero_in_VLimit Pair_in_VLimit)
done

lemma Inr_in_VLimit:
    "[| b \<in> Vfrom(A,i); Limit(i) |] ==> Inr(b) \<in> Vfrom(A,i)"
apply (unfold Inr_def)
apply (blast intro: one_in_VLimit Pair_in_VLimit)
done

lemma sum_VLimit: "Limit(i) ==> Vfrom(C,i)+Vfrom(C,i) \<subseteq> Vfrom(C,i)"
by (blast intro!: Inl_in_VLimit Inr_in_VLimit)

lemmas sum_subset_VLimit = subset_trans [OF sum_mono sum_VLimit]

subsection\<open>Properties assuming \<^term>\<open>Transset(A)\<close>\<close>

lemma Transset_Vfrom: "Transset(A) ==> Transset(Vfrom(A,i))"
apply (rule_tac a=i in eps_induct)
apply (subst Vfrom)
apply (blast intro!: Transset_Union_family Transset_Un Transset_Pow)
done

lemma Transset_Vfrom_succ:
     "Transset(A) ==> Vfrom(A, succ(i)) = Pow(Vfrom(A,i))"
apply (rule Vfrom_succ [THEN trans])
apply (rule equalityI [OF _ Un_upper2])
apply (rule Un_least [OF _ subset_refl])
apply (rule A_subset_Vfrom [THEN subset_trans])
apply (erule Transset_Vfrom [THEN Transset_iff_Pow [THEN iffD1]])
done

lemma Transset_Pair_subset: "[| <a,b> \<subseteq> C; Transset(C) |] ==> a: C & b: C"
by (unfold Pair_def Transset_def, blast)

lemma Transset_Pair_subset_VLimit:
     "[| <a,b> \<subseteq> Vfrom(A,i);  Transset(A);  Limit(i) |]
      ==> <a,b> \<in> Vfrom(A,i)"
apply (erule Transset_Pair_subset [THEN conjE])
apply (erule Transset_Vfrom)
apply (blast intro: Pair_in_VLimit)
done

lemma Union_in_Vfrom:
     "[| X \<in> Vfrom(A,j);  Transset(A) |] ==> \<Union>(X) \<in> Vfrom(A, succ(j))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def, blast)
done

lemma Union_in_VLimit:
     "[| X \<in> Vfrom(A,i);  Limit(i);  Transset(A) |] ==> \<Union>(X) \<in> Vfrom(A,i)"
apply (rule Limit_VfromE, assumption+)
apply (blast intro: Limit_has_succ VfromI Union_in_Vfrom)
done

(*** Closure under product/sum applied to elements -- thus Vfrom(A,i)
     is a model of simple type theory provided A is a transitive set
     and i is a limit ordinal
***)

text\<open>General theorem for membership in Vfrom(A,i) when i is a limit ordinal\<close>
lemma in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);
      !!x y j. [| j<i; 1:j; x \<in> Vfrom(A,j); y \<in> Vfrom(A,j) |]
               ==> \<exists>k. h(x,y) \<in> Vfrom(A,k) & k<i |]
   ==> h(a,b) \<in> Vfrom(A,i)"
txt\<open>Infer that a, b occur at ordinals x,xa < i.\<close>
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption, atomize)
apply (drule_tac x=a in spec)
apply (drule_tac x=b in spec)
apply (drule_tac x="x \<union> xa \<union> 2" in spec)
apply (simp add: Un_least_lt_iff lt_Ord Vfrom_UnI1 Vfrom_UnI2)
apply (blast intro: Limit_has_0 Limit_has_succ VfromI)
done

subsubsection\<open>Products\<close>

lemma prod_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A) |]
     ==> a*b \<in> Vfrom(A, succ(succ(succ(j))))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def)
apply (blast intro: Pair_in_Vfrom)
done

lemma prod_in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A) |]
   ==> a*b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: prod_in_Vfrom Limit_has_succ)
done

subsubsection\<open>Disjoint Sums, or Quine Ordered Pairs\<close>

lemma sum_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A);  1:j |]
     ==> a+b \<in> Vfrom(A, succ(succ(succ(j))))"
apply (unfold sum_def)
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def)
apply (blast intro: zero_in_Vfrom Pair_in_Vfrom i_subset_Vfrom [THEN subsetD])
done

lemma sum_in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A) |]
   ==> a+b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: sum_in_Vfrom Limit_has_succ)
done

subsubsection\<open>Function Space!\<close>

lemma fun_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A) |] ==>
          a->b \<in> Vfrom(A, succ(succ(succ(succ(j)))))"
apply (unfold Pi_def)
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (rule Collect_subset [THEN subset_trans])
apply (subst Vfrom)
apply (rule subset_trans [THEN subset_trans])
apply (rule_tac [3] Un_upper2)
apply (rule_tac [2] succI1 [THEN UN_upper])
apply (rule Pow_mono)
apply (unfold Transset_def)
apply (blast intro: Pair_in_Vfrom)
done

lemma fun_in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A) |]
   ==> a->b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: fun_in_Vfrom Limit_has_succ)
done

lemma Pow_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  Transset(A) |] ==> Pow(a) \<in> Vfrom(A, succ(succ(j)))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def)
apply (subst Vfrom, blast)
done

lemma Pow_in_VLimit:
     "[| a \<in> Vfrom(A,i);  Limit(i);  Transset(A) |] ==> Pow(a) \<in> Vfrom(A,i)"
by (blast elim: Limit_VfromE intro: Limit_has_succ Pow_in_Vfrom VfromI)

subsection\<open>The Set \<^term>\<open>Vset(i)\<close>\<close>

lemma Vset: "Vset(i) = (\<Union>j\<in>i. Pow(Vset(j)))"
by (subst Vfrom, blast)

lemmas Vset_succ = Transset_0 [THEN Transset_Vfrom_succ]
lemmas Transset_Vset = Transset_0 [THEN Transset_Vfrom]

subsubsection\<open>Characterisation of the elements of \<^term>\<open>Vset(i)\<close>\<close>

lemma VsetD [rule_format]: "Ord(i) ==> \<forall>b. b \<in> Vset(i) \<longrightarrow> rank(b) < i"
apply (erule trans_induct)
apply (subst Vset, safe)
apply (subst rank)
apply (blast intro: ltI UN_succ_least_lt)
done

lemma VsetI_lemma [rule_format]:
     "Ord(i) ==> \<forall>b. rank(b) \<in> i \<longrightarrow> b \<in> Vset(i)"
apply (erule trans_induct)
apply (rule allI)
apply (subst Vset)
apply (blast intro!: rank_lt [THEN ltD])
done

lemma VsetI: "rank(x)<i ==> x \<in> Vset(i)"
by (blast intro: VsetI_lemma elim: ltE)

text\<open>Merely a lemma for the next result\<close>
lemma Vset_Ord_rank_iff: "Ord(i) ==> b \<in> Vset(i) \<longleftrightarrow> rank(b) < i"
by (blast intro: VsetD VsetI)

lemma Vset_rank_iff [simp]: "b \<in> Vset(a) \<longleftrightarrow> rank(b) < rank(a)"
apply (rule Vfrom_rank_eq [THEN subst])
apply (rule Ord_rank [THEN Vset_Ord_rank_iff])
done

text\<open>This is rank(rank(a)) = rank(a)\<close>
declare Ord_rank [THEN rank_of_Ord, simp]

lemma rank_Vset: "Ord(i) ==> rank(Vset(i)) = i"
apply (subst rank)
apply (rule equalityI, safe)
apply (blast intro: VsetD [THEN ltD])
apply (blast intro: VsetD [THEN ltD] Ord_trans)
apply (blast intro: i_subset_Vfrom [THEN subsetD]
                    Ord_in_Ord [THEN rank_of_Ord, THEN ssubst])
done

lemma Finite_Vset: "i \<in> nat ==> Finite(Vset(i))"
apply (erule nat_induct)
 apply (simp add: Vfrom_0)
apply (simp add: Vset_succ)
done

subsubsection\<open>Reasoning about Sets in Terms of Their Elements' Ranks\<close>

lemma arg_subset_Vset_rank: "a \<subseteq> Vset(rank(a))"
apply (rule subsetI)
apply (erule rank_lt [THEN VsetI])
done

lemma Int_Vset_subset:
    "[| !!i. Ord(i) ==> a \<inter> Vset(i) \<subseteq> b |] ==> a \<subseteq> b"
apply (rule subset_trans)
apply (rule Int_greatest [OF subset_refl arg_subset_Vset_rank])
apply (blast intro: Ord_rank)
done

subsubsection\<open>Set Up an Environment for Simplification\<close>

lemma rank_Inl: "rank(a) < rank(Inl(a))"
apply (unfold Inl_def)
apply (rule rank_pair2)
done

lemma rank_Inr: "rank(a) < rank(Inr(a))"
apply (unfold Inr_def)
apply (rule rank_pair2)
done

lemmas rank_rls = rank_Inl rank_Inr rank_pair1 rank_pair2

subsubsection\<open>Recursion over Vset Levels!\<close>

text\<open>NOT SUITABLE FOR REWRITING: recursive!\<close>
lemma Vrec: "Vrec(a,H) = H(a, \<lambda>x\<in>Vset(rank(a)). Vrec(x,H))"
apply (unfold Vrec_def)
apply (subst transrec, simp)
apply (rule refl [THEN lam_cong, THEN subst_context], simp add: lt_def)
done

text\<open>This form avoids giant explosions in proofs.  NOTE USE OF ==\<close>
lemma def_Vrec:
    "[| !!x. h(x)==Vrec(x,H) |] ==>
     h(a) = H(a, \<lambda>x\<in>Vset(rank(a)). h(x))"
apply simp
apply (rule Vrec)
done

text\<open>NOT SUITABLE FOR REWRITING: recursive!\<close>
lemma Vrecursor:
     "Vrecursor(H,a) = H(\<lambda>x\<in>Vset(rank(a)). Vrecursor(H,x),  a)"
apply (unfold Vrecursor_def)
apply (subst transrec, simp)
apply (rule refl [THEN lam_cong, THEN subst_context], simp add: lt_def)
done

text\<open>This form avoids giant explosions in proofs.  NOTE USE OF ==\<close>
lemma def_Vrecursor:
     "h == Vrecursor(H) ==> h(a) = H(\<lambda>x\<in>Vset(rank(a)). h(x),  a)"
apply simp
apply (rule Vrecursor)
done

subsection\<open>The Datatype Universe: \<^term>\<open>univ(A)\<close>\<close>

lemma univ_mono: "A<=B ==> univ(A) \<subseteq> univ(B)"
apply (unfold univ_def)
apply (erule Vfrom_mono)
apply (rule subset_refl)
done

lemma Transset_univ: "Transset(A) ==> Transset(univ(A))"
apply (unfold univ_def)
apply (erule Transset_Vfrom)
done

subsubsection\<open>The Set \<^term>\<open>univ(A)\<close> as a Limit\<close>

lemma univ_eq_UN: "univ(A) = (\<Union>i\<in>nat. Vfrom(A,i))"
apply (unfold univ_def)
apply (rule Limit_nat [THEN Limit_Vfrom_eq])
done

lemma subset_univ_eq_Int: "c \<subseteq> univ(A) ==> c = (\<Union>i\<in>nat. c \<inter> Vfrom(A,i))"
apply (rule subset_UN_iff_eq [THEN iffD1])
apply (erule univ_eq_UN [THEN subst])
done

lemma univ_Int_Vfrom_subset:
    "[| a \<subseteq> univ(X);
        !!i. i:nat ==> a \<inter> Vfrom(X,i) \<subseteq> b |]
     ==> a \<subseteq> b"
apply (subst subset_univ_eq_Int, assumption)
apply (rule UN_least, simp)
done

lemma univ_Int_Vfrom_eq:
    "[| a \<subseteq> univ(X);   b \<subseteq> univ(X);
        !!i. i:nat ==> a \<inter> Vfrom(X,i) = b \<inter> Vfrom(X,i)
     |] ==> a = b"
apply (rule equalityI)
apply (rule univ_Int_Vfrom_subset, assumption)
apply (blast elim: equalityCE)
apply (rule univ_Int_Vfrom_subset, assumption)
apply (blast elim: equalityCE)
done

subsection\<open>Closure Properties for \<^term>\<open>univ(A)\<close>\<close>

lemma zero_in_univ: "0 \<in> univ(A)"
apply (unfold univ_def)
apply (rule nat_0I [THEN zero_in_Vfrom])
done

lemma zero_subset_univ: "{0} \<subseteq> univ(A)"
by (blast intro: zero_in_univ)

lemma A_subset_univ: "A \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule A_subset_Vfrom)
done

lemmas A_into_univ = A_subset_univ [THEN subsetD]

subsubsection\<open>Closure under Unordered and Ordered Pairs\<close>

lemma singleton_in_univ: "a: univ(A) ==> {a} \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: singleton_in_VLimit Limit_nat)
done

lemma doubleton_in_univ:
    "[| a: univ(A);  b: univ(A) |] ==> {a,b} \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: doubleton_in_VLimit Limit_nat)
done

lemma Pair_in_univ:
    "[| a: univ(A);  b: univ(A) |] ==> <a,b> \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: Pair_in_VLimit Limit_nat)
done

lemma Union_in_univ:
     "[| X: univ(A);  Transset(A) |] ==> \<Union>(X) \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: Union_in_VLimit Limit_nat)
done

lemma product_univ: "univ(A)*univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN product_VLimit])
done

subsubsection\<open>The Natural Numbers\<close>

lemma nat_subset_univ: "nat \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule i_subset_Vfrom)
done

text\<open>n:nat ==> n:univ(A)\<close>
lemmas nat_into_univ = nat_subset_univ [THEN subsetD]

subsubsection\<open>Instances for 1 and 2\<close>

lemma one_in_univ: "1 \<in> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN one_in_VLimit])
done

text\<open>unused!\<close>
lemma two_in_univ: "2 \<in> univ(A)"
by (blast intro: nat_into_univ)

lemma bool_subset_univ: "bool \<subseteq> univ(A)"
apply (unfold bool_def)
apply (blast intro!: zero_in_univ one_in_univ)
done

lemmas bool_into_univ = bool_subset_univ [THEN subsetD]

subsubsection\<open>Closure under Disjoint Union\<close>

lemma Inl_in_univ: "a: univ(A) ==> Inl(a) \<in> univ(A)"
apply (unfold univ_def)
apply (erule Inl_in_VLimit [OF _ Limit_nat])
done

lemma Inr_in_univ: "b: univ(A) ==> Inr(b) \<in> univ(A)"
apply (unfold univ_def)
apply (erule Inr_in_VLimit [OF _ Limit_nat])
done

lemma sum_univ: "univ(C)+univ(C) \<subseteq> univ(C)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN sum_VLimit])
done

lemmas sum_subset_univ = subset_trans [OF sum_mono sum_univ]

lemma Sigma_subset_univ:
  "[|A \<subseteq> univ(D); \<And>x. x \<in> A \<Longrightarrow> B(x) \<subseteq> univ(D)|] ==> Sigma(A,B) \<subseteq> univ(D)"
apply (simp add: univ_def)
apply (blast intro: Sigma_subset_VLimit del: subsetI)
done

(*Closure under binary union -- use Un_least
  Closure under Collect -- use  Collect_subset [THEN subset_trans]
  Closure under RepFun -- use   RepFun_subset *)

subsection\<open>Finite Branching Closure Properties\<close>

subsubsection\<open>Closure under Finite Powerset\<close>

lemma Fin_Vfrom_lemma:
     "[| b: Fin(Vfrom(A,i));  Limit(i) |] ==> \<exists>j. b \<subseteq> Vfrom(A,j) & j<i"
apply (erule Fin_induct)
apply (blast dest!: Limit_has_0, safe)
apply (erule Limit_VfromE, assumption)
apply (blast intro!: Un_least_lt intro: Vfrom_UnI1 Vfrom_UnI2)
done

lemma Fin_VLimit: "Limit(i) ==> Fin(Vfrom(A,i)) \<subseteq> Vfrom(A,i)"
apply (rule subsetI)
apply (drule Fin_Vfrom_lemma, safe)
apply (rule Vfrom [THEN ssubst])
apply (blast dest!: ltD)
done

lemmas Fin_subset_VLimit = subset_trans [OF Fin_mono Fin_VLimit]

lemma Fin_univ: "Fin(univ(A)) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN Fin_VLimit])
done

subsubsection\<open>Closure under Finite Powers: Functions from a Natural Number\<close>

lemma nat_fun_VLimit:
     "[| n: nat;  Limit(i) |] ==> n -> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (erule nat_fun_subset_Fin [THEN subset_trans])
apply (blast del: subsetI
    intro: subset_refl Fin_subset_VLimit Sigma_subset_VLimit nat_subset_VLimit)
done

lemmas nat_fun_subset_VLimit = subset_trans [OF Pi_mono nat_fun_VLimit]

lemma nat_fun_univ: "n: nat ==> n -> univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (erule nat_fun_VLimit [OF _ Limit_nat])
done

subsubsection\<open>Closure under Finite Function Space\<close>

text\<open>General but seldom-used version; normally the domain is fixed\<close>
lemma FiniteFun_VLimit1:
     "Limit(i) ==> Vfrom(A,i) -||> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (rule FiniteFun.dom_subset [THEN subset_trans])
apply (blast del: subsetI
             intro: Fin_subset_VLimit Sigma_subset_VLimit subset_refl)
done

lemma FiniteFun_univ1: "univ(A) -||> univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN FiniteFun_VLimit1])
done

text\<open>Version for a fixed domain\<close>
lemma FiniteFun_VLimit:
     "[| W \<subseteq> Vfrom(A,i); Limit(i) |] ==> W -||> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (rule subset_trans)
apply (erule FiniteFun_mono [OF _ subset_refl])
apply (erule FiniteFun_VLimit1)
done

lemma FiniteFun_univ:
    "W \<subseteq> univ(A) ==> W -||> univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (erule FiniteFun_VLimit [OF _ Limit_nat])
done

lemma FiniteFun_in_univ:
     "[| f: W -||> univ(A);  W \<subseteq> univ(A) |] ==> f \<in> univ(A)"
by (erule FiniteFun_univ [THEN subsetD], assumption)

text\<open>Remove \<open>\<subseteq>\<close> from the rule above\<close>
lemmas FiniteFun_in_univ' = FiniteFun_in_univ [OF _ subsetI]

subsection\<open>* For QUniv.  Properties of Vfrom analogous to the "take-lemma" *\<close>

text\<open>Intersecting a*b with Vfrom...\<close>

text\<open>This version says a, b exist one level down, in the smaller set Vfrom(X,i)\<close>
lemma doubleton_in_Vfrom_D:
     "[| {a,b} \<in> Vfrom(X,succ(i));  Transset(X) |]
      ==> a \<in> Vfrom(X,i)  &  b \<in> Vfrom(X,i)"
by (drule Transset_Vfrom_succ [THEN equalityD1, THEN subsetD, THEN PowD],
    assumption, fast)

text\<open>This weaker version says a, b exist at the same level\<close>
lemmas Vfrom_doubleton_D = Transset_Vfrom [THEN Transset_doubleton_D]

(** Using only the weaker theorem would prove <a,b> \<in> Vfrom(X,i)
      implies a, b \<in> Vfrom(X,i), which is useless for induction.
    Using only the stronger theorem would prove <a,b> \<in> Vfrom(X,succ(succ(i)))
      implies a, b \<in> Vfrom(X,i), leaving the succ(i) case untreated.
    The combination gives a reduction by precisely one level, which is
      most convenient for proofs.
**)

lemma Pair_in_Vfrom_D:
    "[| <a,b> \<in> Vfrom(X,succ(i));  Transset(X) |]
     ==> a \<in> Vfrom(X,i)  &  b \<in> Vfrom(X,i)"
apply (unfold Pair_def)
apply (blast dest!: doubleton_in_Vfrom_D Vfrom_doubleton_D)
done

lemma product_Int_Vfrom_subset:
     "Transset(X) ==>
      (a*b) \<inter> Vfrom(X, succ(i)) \<subseteq> (a \<inter> Vfrom(X,i)) * (b \<inter> Vfrom(X,i))"
by (blast dest!: Pair_in_Vfrom_D)

ML
\<open>
val rank_ss =
  simpset_of (\<^context> addsimps [@{thm VsetI}]
    addsimps @{thms rank_rls} @ (@{thms rank_rls} RLN (2, [@{thm lt_trans}])));
\<close>

end