theory Abstract_Formula
imports
  Main
  "HOL-Library.FSet"
  "HOL-Library.Stream"
  Indexed_FSet
begin

text \<open>
The following locale describes an abstract interface for a set of formulas, without fixing the
concret shape, or set of variables.

The variables mentioned in this locale are only the @{emph \<open>locally fixed constants\<close>} occurring in
formulas, e.g.\@ in the introduction rule for the universal quantifier. Normal variables are not
something we care about at this point; they are handled completely abstractly by the abstract notion
of a substitution.
\<close>

locale Abstract_Formulas =
  \<comment> \<open>Variables can be renamed injectively\<close>
  fixes freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
  \<comment> \<open>A variable-changing function can be mapped over a formula\<close>
  fixes renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('form \<Rightarrow> 'form)"
  \<comment> \<open>The set of variables occurring in a formula\<close>
  fixes lconsts :: "'form \<Rightarrow> 'var set"
  \<comment> \<open>A closed formula has no variables, and substitions do not affect it.\<close>
  fixes closed :: "'form \<Rightarrow> bool"
  \<comment> \<open>A substitution can be applied to a formula.\<close>
  fixes subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
  \<comment> \<open>The set of variables occurring (in the image) of a substitution.\<close>
  fixes subst_lconsts :: "'subst \<Rightarrow> 'var set"
  \<comment> \<open>A variable-changing function can be mapped over a substitution\<close>
  fixes subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
  \<comment> \<open>A most generic formula, can be substitutied to anything.\<close>
  fixes anyP :: "'form"

  assumes freshenLC_eq_iff[simp]: "freshenLC a v = freshenLC a' v' \<longleftrightarrow> a = a' \<and> v = v'"
  assumes lconsts_renameLCs: "lconsts (renameLCs p f) = p ` lconsts f"
  assumes rename_closed: "lconsts f = {} \<Longrightarrow> renameLCs p f = f"
  assumes subst_closed: "closed f \<Longrightarrow> subst s f = f"
  assumes closed_no_lconsts: "closed f \<Longrightarrow> lconsts f = {}"
  assumes fv_subst: "lconsts (subst s f) \<subseteq> lconsts f \<union> subst_lconsts s"
  assumes rename_rename: "renameLCs p1 (renameLCs p2 f) = renameLCs (p1 \<circ> p2) f"
  assumes rename_subst: "renameLCs p (subst s f) = subst (subst_renameLCs p s) (renameLCs p f)"
  assumes renameLCs_cong: "(\<And> x. x \<in> lconsts f \<Longrightarrow> f1 x = f2 x) \<Longrightarrow> renameLCs f1 f = renameLCs f2 f"
  assumes subst_renameLCs_cong: "(\<And> x. x \<in> subst_lconsts s \<Longrightarrow> f1 x = f2 x) \<Longrightarrow> subst_renameLCs f1 s = subst_renameLCs f2 s"
  assumes subst_lconsts_subst_renameLCs: "subst_lconsts (subst_renameLCs p s) = p ` subst_lconsts s"
  assumes lconsts_anyP: "lconsts anyP = {}"
  assumes empty_subst: "\<exists> s. (\<forall> f. subst s f = f) \<and> subst_lconsts s = {}"
  assumes anyP_is_any: "\<exists> s. subst s anyP = f"
begin
  definition freshen :: "nat \<Rightarrow> 'form \<Rightarrow> 'form" where
    "freshen n = renameLCs (freshenLC n)"

  definition empty_subst :: "'subst" where
    "empty_subst = (SOME s. (\<forall> f. subst s f = f) \<and> subst_lconsts s = {})"

  lemma empty_subst_spec:
    "(\<forall> f. subst empty_subst f = f) \<and> subst_lconsts empty_subst = {}"
    unfolding empty_subst_def using empty_subst by (rule someI_ex)
  lemma subst_empty_subst[simp]: "subst empty_subst f = f"
    by (metis empty_subst_spec)
  lemma subst_lconsts_empty_subst[simp]: "subst_lconsts empty_subst = {}"
    by (metis empty_subst_spec)

  lemma lconsts_freshen: "lconsts (freshen a f) = freshenLC a ` lconsts f"
    unfolding freshen_def by (rule lconsts_renameLCs)

  lemma freshen_closed: "lconsts f = {} \<Longrightarrow> freshen a f = f"
    unfolding freshen_def by (rule rename_closed)

  lemma closed_eq:
    assumes "closed f1"
    assumes "closed f2"
    shows "subst s1 (freshen a1 f1) = subst s2 (freshen a2 f2) \<longleftrightarrow> f1 = f2"
  using assms
    by (auto simp add: closed_no_lconsts freshen_def lconsts_freshen subst_closed rename_closed)

  lemma freshenLC_range_eq_iff[simp]: "freshenLC a v \<in> range (freshenLC a') \<longleftrightarrow> a = a'"
    by auto

  definition rerename :: "'var set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('var \<Rightarrow> 'var) \<Rightarrow> ('var \<Rightarrow> 'var)" where
    "rerename V from to f x = (if x \<in> freshenLC from ` V then freshenLC to (inv (freshenLC from) x) else f x)"

  lemma inj_freshenLC[simp]: "inj (freshenLC i)"
    by (rule injI) simp

  lemma rerename_freshen[simp]: "x \<in> V \<Longrightarrow> rerename  V i (isidx is) f (freshenLC i x) = freshenLC (isidx is) x"
    unfolding rerename_def by simp

  lemma range_rerename: "range (rerename V  from to f) \<subseteq> freshenLC to ` V \<union> range f"
    by (auto simp add: rerename_def split: if_splits)

  lemma rerename_noop:
      "x \<notin> freshenLC from ` V  \<Longrightarrow> rerename V from to f x = f x"
    by (auto simp add: rerename_def split: if_splits)

  lemma rerename_rename_noop:
      "freshenLC from ` V \<inter> lconsts form  = {}  \<Longrightarrow> renameLCs (rerename V from to f) form = renameLCs f form"
      by (intro renameLCs_cong rerename_noop) auto

  lemma rerename_subst_noop:
      "freshenLC from ` V \<inter> subst_lconsts s  = {}  \<Longrightarrow> subst_renameLCs (rerename V from to f) s = subst_renameLCs f s"
      by (intro subst_renameLCs_cong rerename_noop) auto
end
end


theory Numbers
imports Complex_Main
begin

text{*

numeric literals; default simprules; can re-orient
*}

lemma "2 * m = m + m"
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
oops

fun h :: "nat \<Rightarrow> nat" where
"h i = (if i = 3 then 2 else i)"

text{*
@{term"h 3 = 2"}
@{term"h i  = i"}
*}

text{*
@{thm[display] numeral_One[no_vars]}
\rulename{numeral_One}

@{thm[display] add_2_eq_Suc[no_vars]}
\rulename{add_2_eq_Suc}

@{thm[display] add_2_eq_Suc'[no_vars]}
\rulename{add_2_eq_Suc'}

@{thm[display] add.assoc[no_vars]}
\rulename{add.assoc}

@{thm[display] add.commute[no_vars]}
\rulename{add.commute}

@{thm[display] add.left_commute[no_vars]}
\rulename{add.left_commute}

these form ac_simps; similarly there is ac_simps
*}

lemma "Suc(i + j*l*k + m*n) = f (n*m + i + k*j*l)"
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
apply (simp add: ac_simps ac_simps)
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
oops

text{*

@{thm[display] div_le_mono[no_vars]}
\rulename{div_le_mono}

@{thm[display] diff_mult_distrib[no_vars]}
\rulename{diff_mult_distrib}

@{thm[display] mult_mod_left[no_vars]}
\rulename{mult_mod_left}

@{thm[display] nat_diff_split[no_vars]}
\rulename{nat_diff_split}
*}

lemma "(n - 1) * (n + 1) = n * n - (1::nat)"
apply (clarsimp split: nat_diff_split iff del: less_Suc0)
 --{* @{subgoals[display,indent=0,margin=65]} *}
apply (subgoal_tac "n=0", force, arith)
done

lemma "(n - 2) * (n + 2) = n * n - (4::nat)"
apply (simp split: nat_diff_split, clarify)
 --{* @{subgoals[display,indent=0,margin=65]} *}
apply (subgoal_tac "n=0 | n=1", force, arith)
done

text{*
@{thm[display] mod_if[no_vars]}
\rulename{mod_if}

@{thm[display] div_mult_mod_eq[no_vars]}
\rulename{div_mult_mod_eq}

@{thm[display] div_mult1_eq[no_vars]}
\rulename{div_mult1_eq}

@{thm[display] mod_mult_right_eq[no_vars]}
\rulename{mod_mult_right_eq}

@{thm[display] div_mult2_eq[no_vars]}
\rulename{div_mult2_eq}

@{thm[display] mod_mult2_eq[no_vars]}
\rulename{mod_mult2_eq}

@{thm[display] div_mult_mult1[no_vars]}
\rulename{div_mult_mult1}

@{thm[display] div_by_0 [no_vars]}
\rulename{div_by_0}

@{thm[display] mod_by_0 [no_vars]}
\rulename{mod_by_0}

@{thm[display] dvd_antisym[no_vars]}
\rulename{dvd_antisym}

@{thm[display] dvd_add[no_vars]}
\rulename{dvd_add}

For the integers, I'd list a few theorems that somehow involve negative
numbers.*}

text{*
Division, remainder of negatives

@{thm[display] pos_mod_sign[no_vars]}
\rulename{pos_mod_sign}

@{thm[display] pos_mod_bound[no_vars]}
\rulename{pos_mod_bound}

@{thm[display] neg_mod_sign[no_vars]}
\rulename{neg_mod_sign}

@{thm[display] neg_mod_bound[no_vars]}
\rulename{neg_mod_bound}

@{thm[display] zdiv_zadd1_eq[no_vars]}
\rulename{zdiv_zadd1_eq}

@{thm[display] mod_add_eq[no_vars]}
\rulename{mod_add_eq}

@{thm[display] zdiv_zmult1_eq[no_vars]}
\rulename{zdiv_zmult1_eq}

@{thm[display] mod_mult_right_eq[no_vars]}
\rulename{mod_mult_right_eq}

@{thm[display] zdiv_zmult2_eq[no_vars]}
\rulename{zdiv_zmult2_eq}

@{thm[display] zmod_zmult2_eq[no_vars]}
\rulename{zmod_zmult2_eq}
*}

lemma "abs (x+y) \<le> abs x + abs (y :: int)"
by arith

lemma "abs (2*x) = 2 * abs (x :: int)"
by (simp add: abs_if)

text {*Induction rules for the Integers

@{thm[display] int_ge_induct[no_vars]}
\rulename{int_ge_induct}

@{thm[display] int_gr_induct[no_vars]}
\rulename{int_gr_induct}

@{thm[display] int_le_induct[no_vars]}
\rulename{int_le_induct}

@{thm[display] int_less_induct[no_vars]}
\rulename{int_less_induct}
*}

text {*FIELDS

@{thm[display] dense[no_vars]}
\rulename{dense}

@{thm[display] times_divide_eq_right[no_vars]}
\rulename{times_divide_eq_right}

@{thm[display] times_divide_eq_left[no_vars]}
\rulename{times_divide_eq_left}

@{thm[display] divide_divide_eq_right[no_vars]}
\rulename{divide_divide_eq_right}

@{thm[display] divide_divide_eq_left[no_vars]}
\rulename{divide_divide_eq_left}

@{thm[display] minus_divide_left[no_vars]}
\rulename{minus_divide_left}

@{thm[display] minus_divide_right[no_vars]}
\rulename{minus_divide_right}

This last NOT a simprule

@{thm[display] add_divide_distrib[no_vars]}
\rulename{add_divide_distrib}
*}

lemma "3/4 < (7/8 :: real)"
by simp

lemma "P ((3/4) * (8/15 :: real))"
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
apply simp
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
oops

lemma "(3/4) * (8/15) < (x :: real)"
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
apply simp
txt{*
@{subgoals[display,indent=0,margin=65]}
*}
oops

text{*
Ring and Field

Requires a field, or else an ordered ring

@{thm[display] mult_eq_0_iff[no_vars]}
\rulename{mult_eq_0_iff}

@{thm[display] mult_cancel_right[no_vars]}
\rulename{mult_cancel_right}

@{thm[display] mult_cancel_left[no_vars]}
\rulename{mult_cancel_left}
*}

text{*
effect of show sorts on the above

@{thm[display,show_sorts] mult_cancel_left[no_vars]}
\rulename{mult_cancel_left}
*}

text{*
absolute value

@{thm[display] abs_mult[no_vars]}
\rulename{abs_mult}

@{thm[display] abs_le_iff[no_vars]}
\rulename{abs_le_iff}

@{thm[display] abs_triangle_ineq[no_vars]}
\rulename{abs_triangle_ineq}

@{thm[display] power_add[no_vars]}
\rulename{power_add}

@{thm[display] power_mult[no_vars]}
\rulename{power_mult}

@{thm[display] power_abs[no_vars]}
\rulename{power_abs}

*}

end


theory T118
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=10,timeout=86400]
oops
end


theory plus
imports Main
        "../data/Natu"
        "$HIPSTER_HOME/IsaHipster"
begin

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

(*hipster plus*)
lemma lemma_a [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_aa [thy_expl]: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

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

lemma lemma_ac [thy_expl]: "plus x1 (plus y1 x1) = plus y1 (plus x1 x1)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ad [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

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

lemma lemma_af [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ag [thy_expl]: "plus (plus x2 y2) (plus x2 z2) =
plus (plus x2 z2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ah [thy_expl]: "plus (plus x2 y2) (plus z2 x2) = plus (plus z2 x2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus z2 x2)"
by (hipster_induct_schemes plus.simps)

end


theory second_incompleteness_par
  imports embedding
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format = 3]

section \<open>Second Incompleteness Theorem (paraconsistent scenario)\<close>

(* Here we reconstruct the proofs of Gödel's second theorem (file "second_incompleteness_class.thy")
but this time employing the paraconsistent logic (R)mbC (featuring a paraconsistent negation). *)

abbreviation neg :: "wo\<Rightarrow>wo" ("\<^bold>\<not>_" [54] 55) where "\<^bold>\<not>\<phi> \<equiv> \<^bold>\<not>\<^sup>p\<phi>" (* negation is paraconsistent *)
abbreviation circ :: "wo\<Rightarrow>wo" ("\<^bold>\<circ>_" [54] 55) where "\<^bold>\<circ>\<phi> \<equiv> \<^bold>\<circ>\<^sup>m\<^sup>b\<^sup>c\<phi>" (* logic is (R)mbC *)

(* If F is consistent, then F \<^bold>\<turnstile> G\<^sub>(\<^sub>F\<^sub>) \<^bold>\<leftrightarrow> Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma G_eq_Cons: fixes G
                 assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi> \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<box>\<phi>]"                (* axiom 4 *)
                 and "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G]"                   (* G's fixed-point *)
                 and "[\<^bold>\<turnstile> \<^bold>\<circ>G]"                     (* \<^bold>\<box>G is \<^bold>\<circ>-consistent *)
                 and "[\<^bold>\<turnstile> \<^bold>\<circ>\<^bold>\<box>G]"                     (* \<^bold>\<box>G is \<^bold>\<circ>-consistent *)
                 and "[\<^bold>\<turnstile> \<^bold>\<circ>\<^bold>\<box>\<^bold>\<bottom>]"                    (* \<^bold>\<box>\<^bold>\<bottom> is \<^bold>\<circ>-consistent *)
                 shows "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>\<^bold>\<bottom>]" (*using assms by smt*)
proof -
  have "[\<^bold>\<turnstile> \<^bold>\<bottom> \<^bold>\<rightarrow> G]" by simp                 (* since \<^bold>\<bottom> implies everything *)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<bottom> \<^bold>\<rightarrow> G)]" by simp                       (* by necessitation *)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> \<^bold>\<box>G]" by simp                        (* by modal axiom K *)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> \<^bold>\<not>G]" using assms(2) assms(4) (* use fixed-point + \<^bold>\<circ>\<^bold>\<box>G \<dots>*)
                          by blast      (*\<dots> by contraposition + chain rule*)
  hence LtoR: "[\<^bold>\<turnstile> G \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>\<box>\<^bold>\<bottom>]" using  assms(3) by blast (*by contrap.*)

  have "[\<^bold>\<turnstile> G \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>\<box>G]" using assms(2) by blast
  hence "[\<^bold>\<turnstile> \<^bold>\<box>G \<^bold>\<rightarrow> \<^bold>\<not>G]" using assms(4) by blast
  hence "[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<box>G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<not>G]" by simp (* necessitation followed by K*)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>G \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<not>G]"  using assms(1) by blast (* by chain rule *)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>G \<^bold>\<rightarrow> (\<^bold>\<box>G \<^bold>\<and> \<^bold>\<box>\<^bold>\<not>G)]" by simp (* trivial*)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>G \<^bold>\<rightarrow> \<^bold>\<box>(G \<^bold>\<and> \<^bold>\<not>G)]" by simp (* property of normal modal logics*)
  hence "[\<^bold>\<turnstile> \<^bold>\<box>G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<bottom>]" using assms(3) by blast (*definition of \<^bold>\<bottom>*)
  hence "[\<^bold>\<turnstile> \<^bold>\<not>\<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>\<box>G]" using assms(5) by blast (*contraposition*)
  hence RtoL: "[\<^bold>\<turnstile> \<^bold>\<not>\<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> G]" using assms(2) by blast (*fixd-point*)

  thus "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>\<^bold>\<bottom>]" using LtoR RtoL by blast
qed

(* lemma  "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G] \<Longrightarrow>[\<^bold>\<turnstile> \<^bold>\<circ>\<^bold>\<box>\<^bold>\<bottom>] \<Longrightarrow>[\<^bold>\<turnstile> \<^bold>\<circ>\<^bold>\<box>G] \<Longrightarrow> [\<^bold>\<turnstile> \<^bold>\<circ>G]" nitpick *)
(*
(* If F is consistent, then (assuming Löb's theorem) F \<^bold>\<turnstile>/ Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma nonProv_Cons: assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<phi>\<^bold>\<rightarrow>\<phi>) \<^bold>\<rightarrow> \<^bold>\<box>\<phi>]"         (* axiom L *)
                    and "[\<^bold>\<turnstile> \<^bold>\<circ>\<^bold>\<box>\<^bold>\<bottom>]"                 (* \<^bold>\<box>\<^bold>\<bottom> is \<^bold>\<circ>-consistent *)
                    shows "\<sim>[\<^bold>\<turnstile> \<^bold>\<not>\<^bold>\<box>\<^bold>\<bottom>]"
proof
  assume provCons: "[\<^bold>\<turnstile> \<^bold>\<not>\<^bold>\<box>\<^bold>\<bottom>]"                 (* assume Cons were provable *)
  hence neg:"[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> \<^bold>\<bottom>]" using assms(2) by blast (*prop. negation + \<^bold>\<circ>\<^bold>\<box>\<^bold>\<bottom> *)
  hence 1: "[\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> \<^bold>\<bottom>)]" by simp                  (* by necessitation *)
  have  2: "[\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<^bold>\<bottom> \<^bold>\<rightarrow> \<^bold>\<bottom>) \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<bottom>]" using assms(1) by (rule allE) (*inst. L*)
  from 1 2 have provIncons: "[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom>]" by simp           (* by modus ponens *)
  from provCons provIncons have "[\<^bold>\<turnstile> \<^bold>\<bottom>]" using assms(2)    (* using  \<^bold>\<circ>\<^bold>\<box>\<^bold>\<bottom> \<dots>*)
                              by simp          (*\<dots> by LFI definition of \<^bold>\<bottom> *)
  thus False by simp
qed

section \<open>Experiments with other variants\<close>

abbreviation "star_consistency \<equiv> \<forall>\<phi>. \<sim>[\<^bold>\<turnstile> \<^bold>\<not>\<phi> \<^bold>\<and> \<^bold>\<box>\<phi>]"
abbreviation star_consistency_obj::"wo" ("*-Cons") where "*-Cons \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<not>\<^bold>\<box>(\<^bold>\<not>\<phi> \<^bold>\<and> \<^bold>\<box>\<phi>)"

abbreviation "P_consistency_a  \<equiv>  \<sim>[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom>]"
abbreviation P_consistency_a_obj::"wo" ("P-Cons-a") where "P-Cons-a \<equiv> \<^bold>\<not>\<^bold>\<box>\<^bold>\<box>\<^bold>\<bottom>"

abbreviation "circ_consistency \<equiv> \<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<circ>\<phi>]"
abbreviation circ_consistency_obj::"wo" ("\<^bold>\<circ>-Cons") where "\<^bold>\<circ>-Cons \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<circ>\<phi>"

(*********** Variant 1 ************)

(* If F is *-consistent, then F \<^bold>\<turnstile> G\<^sub>(\<^sub>F\<^sub>) \<^bold>\<leftrightarrow> *-Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma G_eq_starCons: fixes G
                     assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<box>\<phi>]"                 (* axiom 4 *)
                     and   "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G]"                 (* G's fixed-point *)
                     and   star_consistency
                     shows "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> *-Cons]"   (* equivalence of G and *-Cons *)
  nitpick oops (* countermodel found *)

(* If F is P-consistent-a, then F \<^bold>\<turnstile> G\<^sub>(\<^sub>F\<^sub>) \<^bold>\<leftrightarrow> P-Cons-a\<^sub>(\<^sub>F\<^sub>) *)
lemma G_eq_PCons_a:  fixes G
                     assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<box>\<phi>]"                 (* axiom 4 *)
                     and   "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G]"                 (* G's fixed-point *)
                     and   P_consistency_a
                     shows "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> P-Cons-a]" (* equivalence of G and P-Cons-a *)
  nitpick oops (* countermodel found *)

(* If F is \<^bold>\<circ>-consistent, then F \<^bold>\<turnstile> G\<^sub>(\<^sub>F\<^sub>) \<^bold>\<leftrightarrow> S-Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma G_eq_circCons: fixes G
                     assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<box>\<phi>]"                 (* axiom 4 *)
                     and   "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<not>\<^bold>\<box>G]"                 (* G's fixed-point *)
                     and   circ_consistency
                     shows "[\<^bold>\<turnstile> G \<^bold>\<leftrightarrow> \<^bold>\<circ>-Cons]"   (* equivalence of G and \<circ>-Cons *)
  nitpick oops (* countermodel found *)

(*********** Variant 2 **************)

(* If F is *-consistent, then (assuming Löb's theorem) F \<^bold>\<turnstile>/ *-Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma nonProv_starCons: assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<phi>\<^bold>\<rightarrow>\<phi>) \<^bold>\<rightarrow> \<^bold>\<box>\<phi>]"           (* axiom L *)
                        (* and   star_consistency     (* strengthening the assumptions *)  *)
                        shows "\<sim>[\<^bold>\<turnstile> *-Cons]"           (* *-Cons is non-provable *)
  nitpick oops (* countermodel found *)
  (* TODO: prove or refute if strengthening the assumptions with star_consistency*)

(* If F is P-consistent-a, then (assuming Löb's theorem) F \<^bold>\<turnstile>/ P-Cons-a\<^sub>(\<^sub>F\<^sub>) *)
lemma nonProv_PCons_a: assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<phi>\<^bold>\<rightarrow>\<phi>) \<^bold>\<rightarrow> \<^bold>\<box>\<phi>]"           (* axiom L *)
                       and   P_consistency_a     (* strengthening the assumptions *)
                       shows "\<sim>[\<^bold>\<turnstile> P-Cons-a]"         (* P-Cons-a is non-provable *)
  nitpick oops (* countermodel found *)

(* If F is circ-consistent, then (assuming Löb's theorem) F \<^bold>\<turnstile>/ \<^bold>\<circ>-Cons\<^sub>(\<^sub>F\<^sub>) *)
lemma nonProv_circCons: assumes "\<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>(\<^bold>\<box>\<phi>\<^bold>\<rightarrow>\<phi>) \<^bold>\<rightarrow> \<^bold>\<box>\<phi>]"           (* axiom L *)
                        and   circ_consistency     (* strengthening the assumptions *)
                        shows "\<sim>[\<^bold>\<turnstile> \<^bold>\<circ>-Cons]"           (* \<^bold>\<circ>-Cons is non-provable *)
  nitpick oops (* countermodel found *)
*)
end


(* Author: Tobias Nipkow *)

section \<open>Pairing Heap According to Okasaki\<close>

theory Pairing_Heap_List1
imports
  "HOL-Library.Multiset"
  "HOL-Library.Pattern_Aliases"
  "HOL-Data_Structures.Priority_Queue_Specs"
begin

subsection \<open>Definitions\<close>

text
\<open>This implementation follows Okasaki \cite{Okasaki}.
It satisfies the invariant that \<open>Empty\<close> only occurs
at the root of a pairing heap. The functional correctness proof does not
require the invariant but the amortized analysis (elsewhere) makes use of it.\<close>

datatype 'a heap = Empty | Hp 'a "'a heap list"

fun get_min  :: "'a heap \<Rightarrow> 'a" where
"get_min (Hp x _) = x"

hide_const (open) insert

context includes pattern_aliases
begin

fun merge :: "('a::linorder) heap \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"merge h Empty = h" |
"merge Empty h = h" |
"merge (Hp x lx =: hx) (Hp y ly =: hy) =
    (if x < y then Hp x (hy # lx) else Hp y (hx # ly))"

end

fun insert :: "('a::linorder) \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"insert x h = merge (Hp x []) h"

fun pass\<^sub>1 :: "('a::linorder) heap list \<Rightarrow> 'a heap list" where
  "pass\<^sub>1 [] = []"
| "pass\<^sub>1 [h] = [h]"
| "pass\<^sub>1 (h1#h2#hs) = merge h1 h2 # pass\<^sub>1 hs"

fun pass\<^sub>2 :: "('a::linorder) heap list \<Rightarrow> 'a heap" where
  "pass\<^sub>2 [] = Empty"
| "pass\<^sub>2 (h#hs) = merge h (pass\<^sub>2 hs)"

fun merge_pairs :: "('a::linorder)  heap list \<Rightarrow> 'a heap" where
  "merge_pairs [] = Empty"
| "merge_pairs [h] = h"
| "merge_pairs (h1 # h2 # hs) = merge (merge h1 h2) (merge_pairs hs)"

fun del_min :: "('a::linorder) heap \<Rightarrow> 'a heap" where
  "del_min Empty = Empty"
| "del_min (Hp x hs) = pass\<^sub>2 (pass\<^sub>1 hs)"

subsection \<open>Correctness Proofs\<close>

text \<open>An optimization:\<close>

lemma pass12_merge_pairs: "pass\<^sub>2 (pass\<^sub>1 hs) = merge_pairs hs"
by (induction hs rule: merge_pairs.induct) (auto split: option.split)

declare pass12_merge_pairs[code_unfold]

subsubsection \<open>Invariants\<close>

fun mset_heap :: "'a heap \<Rightarrow>'a multiset" where
"mset_heap Empty = {#}" |
"mset_heap (Hp x hs) = {#x#} + Union_mset(mset(map mset_heap hs))"

fun pheap :: "('a :: linorder) heap \<Rightarrow> bool" where
"pheap Empty = True" |
"pheap (Hp x hs) = (\<forall>h \<in> set hs. (\<forall>y \<in># mset_heap h. x \<le> y) \<and> pheap h)"

lemma pheap_merge: "pheap h1 \<Longrightarrow> pheap h2 \<Longrightarrow> pheap (merge h1 h2)"
by (induction h1 h2 rule: merge.induct) fastforce+

lemma pheap_insert: "pheap h \<Longrightarrow> pheap (insert x h)"
by (auto simp: pheap_merge)

lemma pheap_pass1: "\<forall>h \<in> set hs. pheap h \<Longrightarrow> \<forall>h \<in> set (pass\<^sub>1 hs). pheap h"
by(induction hs rule: pass\<^sub>1.induct) (auto simp: pheap_merge)

lemma pheap_pass2: "\<forall>h \<in> set hs. pheap h \<Longrightarrow> pheap (pass\<^sub>2 hs)"
by (induction hs)(auto simp: pheap_merge)

lemma pheap_del_min: "pheap h \<Longrightarrow> pheap (del_min h)"
by(induction h rule: del_min.induct) (auto intro!: pheap_pass1 pheap_pass2)

subsubsection \<open>Functional Correctness\<close>

lemma mset_heap_empty_iff: "mset_heap h = {#} \<longleftrightarrow> h = Empty"
by (cases h) auto

lemma get_min_in: "h \<noteq> Empty \<Longrightarrow> get_min h \<in># mset_heap(h)"
by(induction rule: get_min.induct)(auto)

lemma get_min_min: "\<lbrakk> h \<noteq> Empty; pheap h; x \<in># mset_heap(h) \<rbrakk> \<Longrightarrow> get_min h \<le> x"
by(induction h rule: get_min.induct)(auto)

lemma get_min: "\<lbrakk> pheap h;  h \<noteq> Empty \<rbrakk> \<Longrightarrow> get_min h = Min_mset (mset_heap h)"
by (metis Min_eqI finite_set_mset get_min_in get_min_min )

lemma mset_merge: "mset_heap (merge h1 h2) = mset_heap h1 + mset_heap h2"
by(induction h1 h2 rule: merge.induct)(auto simp: add_ac)

lemma mset_insert: "mset_heap (insert a h) = {#a#} + mset_heap h"
by(cases h) (auto simp add: mset_merge insert_def add_ac)

lemma mset_merge_pairs: "mset_heap (merge_pairs hs) = Union_mset(image_mset mset_heap(mset hs))"
by(induction hs rule: merge_pairs.induct)(auto simp: mset_merge)

lemma mset_del_min: "h \<noteq> Empty \<Longrightarrow>
  mset_heap (del_min h) = mset_heap h - {#get_min h#}"
by(induction h rule: del_min.induct) (auto simp: pass12_merge_pairs mset_merge_pairs)

text \<open>Last step: prove all axioms of the priority queue specification:\<close>

interpretation pairing: Priority_Queue_Merge
where empty = Empty and is_empty = "\<lambda>h. h = Empty"
and merge = merge and insert = insert
and del_min = del_min and get_min = get_min
and invar = pheap and mset = mset_heap
proof(standard, goal_cases)
  case 1 show ?case by simp
next
  case (2 q) show ?case by (cases q) auto
next
  case 3 show ?case by(simp add: mset_insert mset_merge)
next
  case 4 thus ?case by(simp add: mset_del_min mset_heap_empty_iff)
next
  case 5 thus ?case using get_min mset_heap.simps(1) by blast
next
  case 6 thus ?case by(simp)
next
  case 7 thus ?case by(rule pheap_insert)
next
  case 8 thus ?case by (simp add: pheap_del_min)
next
  case 9 thus ?case by (simp add: mset_merge)
next
  case 10 thus ?case by (simp add: pheap_merge)
qed

end


(* Title: Quantic Nuclei and Conuclei
   Author: Georg Struth
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Quantic Nuclei and Conuclei\<close>

theory Quantic_Nuclei_Conuclei
  imports Quantale_Models

begin

text \<open>Quantic nuclei and conuclei are an important part of the structure theory of quantales. I formalise
the basics, following Rosenthal's book~\<^cite>\<open>"Rosenthal90"\<close>. In the structure theorems, I collect all parts
of the proof, but do not present the theorems in compact form due to difficulties to speak about subalgebras
and homomorphic images without explicit carrier sets. Nuclei also arise in the context of complete Heyting algebras,
frames and locales~\<^cite>\<open>"Johnstone82"\<close>. Their formalisation seems an interesting future task.\<close>

subsection \<open>Nuclei\<close>

definition nucleus :: "('a::quantale \<Rightarrow> 'a::quantale) \<Rightarrow> bool" where
  "nucleus f = (clop f \<and> (\<forall>x y. f x \<cdot> f y \<le> f (x \<cdot> y)))"

lemma nuc_lax: "nucleus f \<Longrightarrow> f x \<cdot> f y \<le> f (x \<cdot> y)"
  by (simp add: nucleus_def)

definition unucleus :: "('a::unital_quantale \<Rightarrow> 'a::unital_quantale) \<Rightarrow> bool" where
  "unucleus f = (nucleus f \<and> 1 \<le> f 1)"

lemma "nucleus f \<Longrightarrow> f \<bottom> = \<bottom>" (*nitpick*)
  oops

lemma "conucleus f \<Longrightarrow> f \<top> = \<top>" (*nitpick*)
  oops

lemma nuc_prop1: "nucleus f \<Longrightarrow> f (x \<cdot> y) = f (x \<cdot> f y)"
  apply (rule antisym)
   apply (simp add: clop_extensive_var clop_iso_var nucleus_def psrpq.mult_isol)
  by (metis clop_alt clop_extensive_var dual_order.trans nucleus_def psrpq.mult_isol_var)

lemma nuc_prop2: "nucleus f \<Longrightarrow> f (x \<cdot> y) = f (f x \<cdot> y)"
  apply (rule antisym)
  apply (simp add: clop_extensive_var clop_iso_var nsrnq.mult_isor nucleus_def)
  by (metis (mono_tags, opaque_lifting) clop_alt nuc_prop1 nucleus_def)

lemma nuc_comp_prop: "nucleus f \<Longrightarrow>  f (f x \<cdot> f y) = f (x \<cdot> y)"
  using nuc_prop1 nuc_prop2 by force

lemma nucleus_alt_def1: "nucleus f \<Longrightarrow> f x \<rightarrow> f y = x \<rightarrow> f y"
proof (rule antisym)
  assume h: "nucleus f"
  hence "x \<le> f x"
    by (simp add: clop_def nucleus_def clop_extensive_var)
  thus "f x \<rightarrow> f y \<le> x \<rightarrow> f y"
    by (simp add: bres_anti)
  have "f x \<cdot> (x \<rightarrow> f y) \<le> f x \<cdot> f (x \<rightarrow> f y)"
    using clop_extensive_var h nucleus_def proto_pre_quantale_class.mult_isol by blast
  also have "... \<le> f (x \<cdot> (x \<rightarrow> f y))"
    by (simp add: h nuc_lax)
  also have "... \<le> f (f y)"
    using h by (simp add: bres_canc1 nucleus_def clop_iso_var)
  finally have "f x \<cdot> (x \<rightarrow> f y) \<le> f y"
    using h by (metis clop_alt dual_order.trans nucleus_def order_refl)
  thus "x \<rightarrow> f y \<le> f x \<rightarrow> f y"
    by (simp add: bres_galois_imp)
qed

lemma nucleus_alt_def2: "nucleus f \<Longrightarrow> f y \<leftarrow> f x = f y \<leftarrow> x"
proof (rule antisym)
  assume h: "nucleus f"
  hence "x \<le> f x"
    by (simp add: clop_extensive_var nucleus_def)
  thus "f y \<leftarrow> f x \<le> f y \<leftarrow> x"
    by (simp add: fres_anti)
  have "(f y \<leftarrow> x) \<cdot> f x \<le> f (f y \<leftarrow> x) \<cdot> f x"
    using clop_extensive_var h nsrnq.mult_isor nucleus_def by blast
  also have "... \<le> f ((f y \<leftarrow> x) \<cdot> x)"
    by (simp add: h nuc_lax)
  also have "... \<le> f (f y)"
    using clop_iso_var fres_canc1 h nucleus_def by blast
  finally have "(f y \<leftarrow> x) \<cdot> f x \<le> f y"
    using h by (metis clop_alt dual_order.trans nucleus_def order_refl)
  thus "f y \<leftarrow> x \<le> f y \<leftarrow> f x"
    by (simp add: fres_galois)
qed

lemma nucleus_alt_def3:
  fixes f :: "'a::unital_quantale \<Rightarrow> 'a"
  shows "\<forall>x y. f x \<rightarrow> f y = x \<rightarrow> f y \<Longrightarrow> \<forall>x y. f y \<leftarrow> f x = f y \<leftarrow> x \<Longrightarrow> nucleus f"
proof-
  assume h1: "\<forall>x y. f x \<rightarrow> f y = x \<rightarrow> f y"
  and h2: "\<forall>x y. f y \<leftarrow> f x = f y \<leftarrow> x"
  hence ext: "\<forall>x. x \<le> f x"
    by (metis (full_types) fres_galois fres_one mult.left_neutral)
  have iso: "\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"
    by (metis (full_types) bres_galois dual_order.trans h1 ext nsrnqo.mult_oner)
  have trans: "\<forall>x. f (f x) \<le> f x"
    by (metis fres_canc2 fres_galois h2 nsrnqo.mult_onel)
  have lax: "\<forall>x y. f x \<cdot> f y \<le> f (x \<cdot> y)"
    by (metis h1 h2 bres_galois ext fres_galois)
  show ?thesis
    by (simp add: clop_def iso lax le_funI ext trans monoI nucleus_def)
qed

lemma nucleus_alt_def:
  fixes f :: "'a::unital_quantale \<Rightarrow> 'a"
  shows "nucleus f = (\<forall> x y. f x \<rightarrow> f y = x \<rightarrow> f y \<and> f y \<leftarrow> f x = f y \<leftarrow> x)"
  using nucleus_alt_def1 nucleus_alt_def2 nucleus_alt_def3 by blast

lemma nucleus_alt_def_cor1: "nucleus f \<Longrightarrow> f (x \<rightarrow> y) \<le> x \<rightarrow> f y"
  by (metis bres_galois bres_iso clop_extensive_var fres_galois nucleus_alt_def2 nucleus_def)

lemma nucleus_alt_def_cor2: "nucleus f \<Longrightarrow> f (y \<leftarrow> x) \<le> f y \<leftarrow> x"
  by (metis bres_galois clop_extensive_var fres_galois fres_iso nucleus_alt_def1 nucleus_def)

lemma nucleus_ab_unital:
  fixes f :: "'a::ab_unital_quantale \<Rightarrow> 'a"
  shows "nucleus f = (\<forall>x y. f x \<rightarrow> f y = x \<rightarrow> f y)"
  by (simp add: bres_fres_eq nucleus_alt_def)

lemma nuc_comp_assoc: "nucleus f \<Longrightarrow> f (x \<cdot> f (y \<cdot> z)) = f (f (x \<cdot> y) \<cdot> z)"
  by (metis mult.assoc nuc_prop1 nuc_prop2)

lemma nuc_Sup_closed: "nucleus f \<Longrightarrow> f \<circ> Sup \<circ> (`) f = (f \<circ> Sup)"
  apply (simp add: nucleus_def fun_eq_iff, safe, rule antisym)
  apply (meson SUP_least Sup_upper clop_alt clop_def monoD)
  by (simp add: SUP_upper2 Sup_le_iff clop_extensive_var clop_iso_var)

lemma nuc_Sup_closed_var: "nucleus f \<Longrightarrow> f (\<Squnion>x \<in> X. f x) = f (\<Squnion>X)"
  by (metis nuc_Sup_closed o_apply)

lemma nuc_Inf_closed: "nucleus f \<Longrightarrow> Sup_closed_set (Fix f)" (* nitpick *)
  oops

lemma nuc_Inf_closed: "nucleus f \<Longrightarrow> Inf_closed_set (Fix f)"
  by (simp add: clop_Inf_closed nucleus_def)

lemma nuc_comp_distl: "nucleus f \<Longrightarrow> f (x \<cdot> f (\<Squnion>Y)) = f (\<Squnion>y \<in> Y. f (x \<cdot> y))"
  by (metis Sup_distl image_image nuc_Sup_closed_var nuc_prop1)

lemma nuc_comp_distr: "nucleus f \<Longrightarrow> f (f (\<Squnion>X) \<cdot> y) = f (\<Squnion>x \<in> X. f (x \<cdot> y))"
  by (metis image_image Sup_distr nuc_Sup_closed_var nuc_prop2)

lemma "nucleus f \<Longrightarrow> f (x \<cdot> y) = f x \<cdot> f y" (*nitpick*)
  oops

lemma nuc_bres_closed: "nucleus f \<Longrightarrow> f (f x \<rightarrow> f y) = f x \<rightarrow> f y"
  unfolding nucleus_def apply clarsimp
  by (smt clop_closure clop_extensive_var nucleus_alt_def_cor1 nucleus_def order_class.order.antisym rangeI)

lemma "nucleus f \<Longrightarrow> f (x \<rightarrow> y) = f x \<rightarrow> f y" (*nitpick*)
  oops

lemma nuc_fres_closed: "nucleus f \<Longrightarrow> f (f x \<leftarrow> f y) = f x \<leftarrow> f y"
  unfolding nucleus_def apply clarsimp
  by (smt clop_closure clop_extensive_var eq_iff nucleus_alt_def_cor2 nucleus_def rangeI)

lemma nuc_fres_closed: "nucleus f \<Longrightarrow> f (x \<leftarrow> y) = f x \<leftarrow> f y" (*nitpick*)
  oops

lemma nuc_inf_closed: "nucleus f \<Longrightarrow> inf_closed_set (Fix f)"
  by (simp add: Inf_inf_closed nuc_Inf_closed)

lemma nuc_inf_closed_var: "nucleus f \<Longrightarrow> f (f x \<sqinter> f y) = f x \<sqinter> f y"
  by (smt antisym_conv clop_alt clop_extensive_var inf_le2 inf_sup_ord(1) le_inf_iff nucleus_def)

text \<open>Taken together these facts show that, for $f:Q\to Q$, $f[Q]$ forms a quantale with
composition $f\, (-\cdot -)$ and sup $f\, (\bigsqcup -)$, and that $f:Q\to f[Q]$ is a quantale morphism.
This is the first part of Theorem 3.1.1 in Rosenthal's book.\<close>

class quantale_with_nuc = quantale + cl_op +
  assumes cl_op_nuc: "cl_op x \<cdot> cl_op y \<le> cl_op (x \<cdot> y)"

begin

subclass clattice_with_clop..

end

class unital_quantale_with_nuc = quantale_with_nuc + unital_quantale +
  assumes one_nuc: "1 \<le> cl_op 1"

lemma nucleus_cl_op: "nucleus (cl_op::'a::quantale_with_nuc \<Rightarrow> 'a)"
  by (simp add: cl_op_class.clop_iso cl_op_nuc  clop_def clop_ext le_funI monoI nucleus_def)

lemma unucleus_cl_op: "unucleus (cl_op::'a::unital_quantale_with_nuc \<Rightarrow> 'a)"
  by (simp add: nucleus_cl_op one_nuc unucleus_def)

instantiation cl_op_im :: (quantale_with_nuc) quantale
begin

lift_definition times_cl_op_im :: "'a::quantale_with_nuc cl_op_im \<Rightarrow> 'a cl_op_im \<Rightarrow> 'a cl_op_im" is "\<lambda>x y. cl_op (x \<cdot> y)"
  by simp

instance
  by (intro_classes; transfer, auto simp: nuc_comp_assoc nuc_comp_distr nucleus_cl_op nuc_comp_distl)

end

instantiation cl_op_im :: (unital_quantale_with_nuc) unital_quantale
begin

lift_definition one_cl_op_im :: "'a::unital_quantale_with_nuc cl_op_im" is "cl_op 1"
  by simp

instance
  by (intro_classes; transfer) (metis clop_closure nsrnqo.mult_onel nuc_prop2 nucleus_cl_op nucleus_def nsrnqo.mult_oner nuc_prop1)+

end

text \<open>The usefulness of these theorems remains unclear; it seems difficult to make them collaborate with concrete nuclei.\<close>

lemma nuc_hom: "Abs_cl_op_im \<circ> cl_op \<in> quantale_homset"
  unfolding quantale_homset_iff comp_def fun_eq_iff
  apply safe
  apply (metis (no_types, lifting) Abs_cl_op_im_inverse Rep_cl_op_im_inverse nuc_comp_prop nucleus_cl_op rangeI times_cl_op_im.rep_eq)
  unfolding Sup_cl_op_im_def by (smt Abs_cl_op_im_inverse SUP_cong image_image map_fun_apply nuc_Sup_closed_var nucleus_cl_op rangeI)

text \<open>This finishes the first statement of Theorem 3.1.1. The second part follows. It states that for every
surjective quantale homomorphism there is a nucleus such that the range of the nucleus is isomorphic to the range of the surjection.\<close>

lemma quant_morph_nuc:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  assumes "f \<in> quantale_homset"
  shows "nucleus ((radj f) \<circ> f)"
proof-
  let ?\<phi> = "(radj f) \<circ> f"
  have adj: "f \<stileturn> (radj f)"
    by (simp add: assms quantale_hom_radj)
  hence a: "clop ?\<phi>"
    by (simp add: clop_adj)
  {fix x y
    have "f (?\<phi> x \<cdot> ?\<phi> y) = (f \<circ> ?\<phi>) x \<cdot> (f \<circ> ?\<phi>) y"
      by (metis assms comp_eq_dest_lhs quantale_homset_iff)
  also have "... = f x \<cdot> f y"
    by (simp add: adj adj_cancel_eq1 fun.map_comp)
  also have "... = f (x \<cdot> y)"
    by (metis assms quantale_homset_iff)
  finally have "?\<phi> x \<cdot> ?\<phi> y \<le> ?\<phi> (x \<cdot> y)"
    by (metis adj adj_def comp_apply order_refl)}
  thus ?thesis
    by (simp add: a nucleus_def)
qed

lemma surj_quantale_hom_bij_on:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  assumes "surj f"
  and "f \<in> quantale_homset"
  shows "bij_betw f (range (radj f \<circ> f)) UNIV"
  using assms quantale_homset_iff surj_Sup_pres_bij_on by blast

text \<open>This establishes the bijection, extending a similar fact about closure operators and complete lattices (surj-Sup-pres-bij).
It remains to show that $f$ is a quantale morphism, that is, it preserves Sups and compositions of closed elements with operations
defined as in the previous instantiation statement. Sup-preservation holds already for closure operators on complete lattices (surj-Sup-pres-iso).
Hence it remains to prove preservation of compositions.\<close>

lemma surj_comp_pres_iso:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  assumes "f \<in> quantale_homset"
  shows "f ((radj f \<circ> f) (x \<cdot> y)) = f x \<cdot> f y"
proof-
  have "f \<stileturn> (radj f)"
    by (simp add: assms quantale_hom_radj)
  hence "f ((radj f \<circ> f) (x \<cdot> y)) = f (x \<cdot> y)"
    by (metis adj_cancel_eq1 comp_eq_dest_lhs)
  thus ?thesis
    using assms quantale_homset_iff by auto
qed

text \<open>This establishes the quantale isomorphism and finishes the proof of Theorem 3.1.1.\<close>

text \<open>Next I prove Theorem 3.1.2 in Rosenthal's book. nuc-Inf-closed shows that $\mathit{Fix}\, f$ is Inf-closed. Hence the two following
lemmas show one direction.\<close>

lemma nuc_bres_pres: "nucleus f \<Longrightarrow> y \<in> Fix f \<Longrightarrow> x \<rightarrow> y \<in> Fix f"
proof -
  assume a1: "nucleus f"
  assume a2: "y \<in> Fix f"
  have "clop f"
    using a1 by (simp add: nucleus_def)
  thus ?thesis
    using a2 a1
    by (metis clop_Fix_range clop_closure clop_extensive_var dual_order.antisym nucleus_alt_def_cor1)
qed

lemma nuc_fres_pres: "nucleus f \<Longrightarrow> y \<in> Fix f \<Longrightarrow> y \<leftarrow> x \<in> Fix f"
proof -
  assume a1: "nucleus f"
  assume a2: "y \<in> Fix f"
  have "clop f"
    using a1 by (simp add: nucleus_def)
  thus ?thesis
    using a2 a1 by (metis antisym_conv clop_Fix_range clop_closure clop_extensive_var nucleus_alt_def_cor2)
qed

lemma lax_aux:
  fixes X :: "'a::quantale set"
  assumes "\<forall>x.\<forall>y \<in> X. x \<rightarrow> y \<in> X"
  and "\<forall>x. \<forall>y \<in> X. y \<leftarrow> x \<in> X"
shows "\<Sqinter>{z \<in> X. x \<le> z} \<cdot> \<Sqinter>{z \<in> X. y \<le> z} \<le> \<Sqinter>{z \<in> X. x \<cdot> y \<le> z}"
proof-
  let ?\<phi> = "\<lambda>x. \<Sqinter>{w \<in> X. x \<le> w}"
  {fix z
  assume a: "x \<cdot> y \<le> z"
  and b: "z \<in> X"
  hence c: "x \<le> z \<leftarrow> y"
    by (simp add: fres_galois)
  hence "z \<leftarrow> y \<in> X"
    by (simp add: assms(2) b)
  hence "?\<phi> x \<le> z \<leftarrow> y"
    by (simp add: Inf_lower c)
  hence d: "y \<le> ?\<phi> x \<rightarrow> z"
    by (simp add: bres_galois_imp fres_galois)
  hence "?\<phi> x  \<rightarrow> z \<in> X"
    by (simp add: assms(1) b)
  hence "?\<phi> x \<cdot> ?\<phi> y \<le> z"
    by (simp add: Inf_lower d bres_galois)}
  thus ?thesis
    by (simp add: le_Inf_iff)
qed

lemma Inf_closed_res_nuc:
  fixes X :: "'a::quantale set"
  assumes "Inf_closed_set X"
  and  "\<forall>x. \<forall>y \<in> X. x \<rightarrow> y \<in> X"
  and "\<forall>x. \<forall>y \<in> X. y \<leftarrow> x \<in> X"
  shows "nucleus (\<lambda>y. \<Sqinter>{x \<in> X. y \<le> x})"
  unfolding nucleus_def by (simp add: Inf_closed_clop assms lax_aux)

lemma Inf_closed_res_Fix:
  fixes X :: "'a::quantale set"
  assumes "Inf_closed_set X"
  and  "\<forall>x. \<forall>y \<in> X. x \<rightarrow> y \<in> X"
  and "\<forall>x. \<forall>y \<in> X. y \<leftarrow> x \<in> X"
shows "X = Fix (\<lambda>y. \<Sqinter>{x \<in> X. y \<le> x})"
  unfolding Fix_def
  apply safe
   apply (rule antisym, simp_all add: Inf_lower le_Inf_iff)
  by (metis (no_types, lifting) Inf_closed_set_def assms(1) mem_Collect_eq subsetI)

text \<open>This finishes the proof of Theorem 3.1.2\<close>

subsection \<open>A Representation Theorem\<close>

text \<open>The final proofs for nuclei lead to Rosenthal's representation theorem for quantales (Theorem 3.1.2).\<close>

lemma down_set_lax_morph: "(\<down> \<circ> Sup) (X::'a::quantale set) \<cdot> (\<down> \<circ> Sup) Y \<subseteq> (\<down> \<circ> Sup) (X \<cdot> Y)"
proof-
  have "\<Squnion>((\<down> \<circ> Sup) X \<cdot> (\<down> \<circ> Sup) Y) = \<Squnion>(X \<cdot> Y)"
    by (smt Sup_downset_adj adj_cancel_eq1 comp_apply comp_dist_mix)
  thus ?thesis
    by (simp add: Sup_downset_adj_var eq_iff)
qed

lemma downset_Sup_nuc: "nucleus (\<down> \<circ> (Sup::'a::quantale set \<Rightarrow> 'a))"
  using Sup_downset_adj clop_adj down_set_lax_morph nucleus_def by blast

lemma downset_surj: "surj_on \<down> (range (\<down> \<circ> Sup))"
  using surj_on_def by fastforce

text \<open>In addition, $\downarrow$ is injective by Lemma downset-inj. Hence it is a bijection between the quantale and the powerset quantale.
It remains to show that $\downarrow$ is a quantale morphism.\<close>

lemma downset_Sup_pres_var: "\<down> (\<Squnion>X) = (\<down> \<circ> Sup) (\<Down> (X::'a::quantale set))"
  unfolding comp_def downset_prop downset_set_def
  apply safe
  apply (smt Sup_subset_mono dual_order.refl mem_Collect_eq order_subst1 subset_iff)
  by (smt Sup_mono le_iff_inf le_infI2 mem_Collect_eq)

lemma downset_Sup_pres: "\<down> (\<Squnion>X) = (\<down> \<circ> Sup) (\<Union> (\<down> ` (X::'a::quantale set)))"
  by (metis downset_Sup_pres_var downset_set_prop_var)

text \<open>This finishes the proof of Theorem 3.1.2.\<close>

subsection \<open>Conuclei\<close>

definition conucleus :: "('a::quantale \<Rightarrow> 'a::quantale) \<Rightarrow> bool" where
  "conucleus f = (coclop f \<and> (\<forall>x y. f x \<cdot> f y \<le> f (x \<cdot> y)))"

lemma conuc_lax: "conucleus f \<Longrightarrow> f x \<cdot> f y \<le> f (x \<cdot> y)"
  by (simp add: conucleus_def)

definition uconucleus :: "('a::unital_quantale \<Rightarrow> 'a::unital_quantale) \<Rightarrow> bool" where
  "uconucleus f = (conucleus f \<and> f 1 \<le> 1)"

text \<open>Next I prove Theorem 3.1.3.\<close>

lemma conuc_Sup_closed: "conucleus f \<Longrightarrow> f \<circ> Sup \<circ> (`) f = Sup \<circ> (`) f"
  unfolding conucleus_def fun_eq_iff comp_def
  by (smt coclop_coextensive_var coclop_idem coclop_iso image_comp image_image le_iff_sup mono_SUP sup.orderE)

lemma conuc_comp_closed: "conucleus f \<Longrightarrow> f (f x \<cdot> f y) = f x \<cdot> f y"
  unfolding conucleus_def by (metis antisym_conv coclop_coextensive_var coclop_idem_var)

text \<open>The sets of fixpoints of conuclei are closed under Sups and composition; hence they form subquantales.\<close>

lemma conuc_Sup_qclosed: "conucleus f \<Longrightarrow> Sup_closed_set (Fix f) \<and> comp_closed_set (Fix f)"
  apply safe
   apply (simp add: coclop_Sup_closed conucleus_def)
  unfolding conucleus_def comp_closed_set_def by (metis coclop_coclosure coclop_coclosure_set coclop_coextensive_var dual_order.antisym)

text \<open>This shows that the subset $\mathit{Fix} f$ of a quantale, for conucleus $f$, is closed under Sups and composition.
It is therefore a subquantale. $f:f[Q]\to Q$ is an embedding. As before, this could be shown by formalising a type class of quantales with a conucleus operation,
converting the range of the conucleus into a type and providing a sublocale proof. First, this would require showing that the coclosed
elements of a complete lattice form a complete sublattice. Relative to the proofs for closure operators and nuclei there is nothing to
be learned. I provide this proof in the section on left-sided elements, where the conucleus can be expressed within the language of quantales.\<close>

text \<open>The second part of Theorem 3.1.3 states that every subquantale of a given quantale is equal to $\mathit{Fix} f$ for some conucleus $f$.\<close>

lemma lax_aux2:
  fixes X :: "'a::quantale set"
  assumes "Sup_closed_set X"
  and "comp_closed_set X"
  shows "\<Squnion>{z \<in> X. z \<le> x} \<cdot> \<Squnion>{z \<in> X. z \<le> y} \<le> \<Squnion>{z \<in> X. z \<le> x \<cdot> y}"
proof-
  let ?\<phi> = "\<lambda>x. \<Squnion>{z \<in> X. z \<le> x}"
  have "?\<phi> x \<cdot> ?\<phi> y = \<Squnion>{\<Squnion>{v \<cdot> w |v. v \<in> X \<and> v \<le> x} |w. w \<in> X \<and> w \<le> y}"
    by (simp add: Sup_distr Sup_distl setcompr_eq_image)
  also have "... = \<Squnion>{v \<cdot> w |v w. v \<in> X \<and> v \<le> x \<and> w \<in> X \<and> w \<le> y}"
    apply (rule antisym)
    apply (rule Sup_least, clarsimp, smt Collect_mono_iff Sup_subset_mono)
    by (rule Sup_least, clarsimp, smt Sup_upper2 eq_iff mem_Collect_eq)
  also have "... \<le> ?\<phi> (x \<cdot> y)"
    by (smt Collect_mono_iff Sup_subset_mono assms(2) comp_closed_set_def psrpq.mult_isol_var)
  finally show ?thesis
    by force
qed

lemma subquantale_conucleus:
  fixes X :: "'a::quantale set"
  assumes "Sup_closed_set X"
  and "comp_closed_set X"
  shows "conucleus (\<lambda>x. \<Squnion>{y \<in> X. y \<le> x})"
  unfolding conucleus_def by (safe, simp_all add: Sup_closed_coclop assms(1) assms(2) lax_aux2)

lemma subquantale_Fix:
  fixes X :: "'a::quantale set"
  assumes "Sup_closed_set X"
  and "comp_closed_set X"
  shows "X = Fix (\<lambda>x. \<Squnion>{y \<in> X. y \<le> x})"
  unfolding Fix_def
  apply safe
  apply (metis (mono_tags, lifting) Sup_least Sup_upper antisym mem_Collect_eq order_refl)
  by (metis (no_types, lifting) Sup_closed_set_def assms(1) mem_Collect_eq subsetI)

text \<open>This finishes the proof of Theorem 3.1.3\<close>

end


(*  Title:      HOL/Probability/Tree_Space.thy
    Author:     Johannes Hölzl, CMU *)

theory Tree_Space
  imports "HOL-Analysis.Analysis" "HOL-Library.Tree"
begin

lemma countable_lfp:
  assumes step: "\<And>Y. countable Y \<Longrightarrow> countable (F Y)"
  and cont: "Order_Continuity.sup_continuous F"
  shows "countable (lfp F)"
by(subst sup_continuous_lfp[OF cont])(simp add: countable_funpow[OF step])

lemma countable_lfp_apply:
  assumes step: "\<And>Y x. (\<And>x. countable (Y x)) \<Longrightarrow> countable (F Y x)"
  and cont: "Order_Continuity.sup_continuous F"
  shows "countable (lfp F x)"
proof -
  { fix n
    have "\<And>x. countable ((F ^^ n) bot x)"
      by(induct n)(auto intro: step) }
  thus ?thesis using cont by(simp add: sup_continuous_lfp)
qed

inductive_set trees :: "'a set \<Rightarrow> 'a tree set" for S :: "'a set" where
  [intro!]: "Leaf \<in> trees S"
| "l \<in> trees S \<Longrightarrow> r \<in> trees S \<Longrightarrow> v \<in> S \<Longrightarrow> Node l v r \<in> trees S"

lemma Node_in_trees_iff[simp]: "Node l v r \<in> trees S \<longleftrightarrow> (l \<in> trees S \<and> v \<in> S \<and> r \<in> trees S)"
  by (subst trees.simps) auto

lemma trees_sub_lfp: "trees S \<subseteq> lfp (\<lambda>T. T \<union> {Leaf} \<union> (\<Union>l\<in>T. (\<Union>v\<in>S. (\<Union>r\<in>T. {Node l v r}))))"
proof
  have mono: "mono (\<lambda>T. T \<union> {Leaf} \<union> (\<Union>l\<in>T. (\<Union>v\<in>S. (\<Union>r\<in>T. {Node l v r}))))"
    by (auto simp: mono_def)
  fix t assume "t \<in> trees S" then show "t \<in> lfp (\<lambda>T. T \<union> {Leaf} \<union> (\<Union>l\<in>T. (\<Union>v\<in>S. (\<Union>r\<in>T. {Node l v r}))))"
  proof induction
    case 1 then show ?case
      by (subst lfp_unfold[OF mono]) auto
  next
    case 2 then show ?case
      by (subst lfp_unfold[OF mono]) auto
  qed
qed

lemma countable_trees: "countable A \<Longrightarrow> countable (trees A)"
proof (intro countable_subset[OF trees_sub_lfp] countable_lfp
         sup_continuous_sup sup_continuous_const sup_continuous_id)
  show "sup_continuous (\<lambda>T. (\<Union>l\<in>T. \<Union>v\<in>A. \<Union>r\<in>T. {\<langle>l, v, r\<rangle>}))"
    unfolding sup_continuous_def
  proof (intro allI impI equalityI subsetI, goal_cases)
    case (1 M t)
    then obtain i j :: nat and l x r  where "t = Node l x r" "x \<in> A" "l \<in> M i" "r \<in> M j"
      by auto
    hence "l \<in> M (max i j)" "r \<in> M (max i j)"
      using incseqD[OF \<open>incseq M\<close>, of i "max i j"] incseqD[OF \<open>incseq M\<close>, of j "max i j"] by auto
    with \<open>t = Node l x r\<close> and \<open>x \<in> A\<close> show ?case by auto
  qed auto
qed auto

lemma trees_UNIV[simp]: "trees UNIV = UNIV"
proof -
  have "t \<in> trees UNIV" for t :: "'a tree"
    by (induction t) (auto intro: trees.intros(2))
  then show ?thesis by auto
qed

instance tree :: (countable) countable
proof
  have "countable (UNIV :: 'a tree set)"
    by (subst trees_UNIV[symmetric]) (intro countable_trees[OF countableI_type])
  then show "\<exists>to_nat::'a tree \<Rightarrow> nat. inj to_nat"
    by (auto simp: countable_def)
qed

lemma map_in_trees[intro]: "(\<And>x. x \<in> set_tree t \<Longrightarrow> f x \<in> S) \<Longrightarrow> map_tree f t \<in> trees S"
  by (induction t) (auto intro: trees.intros(2))

primrec trees_cyl :: "'a set tree \<Rightarrow> 'a tree set" where
  "trees_cyl Leaf = {Leaf} "
| "trees_cyl (Node l v r) = (\<Union>l'\<in>trees_cyl l. (\<Union>v'\<in>v. (\<Union>r'\<in>trees_cyl r. {Node l' v' r'})))"

definition tree_sigma :: "'a measure \<Rightarrow> 'a tree measure"
where
  "tree_sigma M = sigma (trees (space M)) (trees_cyl ` trees (sets M))"

lemma Node_in_trees_cyl: "Node l' v' r' \<in> trees_cyl t \<longleftrightarrow>
  (\<exists>l v r. t = Node l v r \<and> l' \<in> trees_cyl l \<and> r' \<in> trees_cyl r \<and> v' \<in> v)"
  by (cases t) auto

lemma trees_cyl_sub_trees:
  assumes "t \<in> trees A" "A \<subseteq> Pow B" shows "trees_cyl t \<subseteq> trees B"
  using assms(1)
proof induction
  case (2 l v r) with \<open>A \<subseteq> Pow B\<close> show ?case
    by (auto intro!: trees.intros(2))
qed auto

lemma trees_cyl_sets_in_space: "trees_cyl ` trees (sets M) \<subseteq> Pow (trees (space M))"
  using trees_cyl_sub_trees[OF _ sets.space_closed, of _ M] by auto

lemma space_tree_sigma: "space (tree_sigma M) = trees (space M)"
  unfolding tree_sigma_def by (rule space_measure_of_conv)

lemma sets_tree_sigma_eq: "sets (tree_sigma M) = sigma_sets (trees (space M)) (trees_cyl ` trees (sets M))"
  unfolding tree_sigma_def by (rule sets_measure_of) (rule trees_cyl_sets_in_space)

lemma Leaf_in_space_tree_sigma [measurable, simp, intro]: "Leaf \<in> space (tree_sigma M)"
  by (auto simp: space_tree_sigma)

lemma Leaf_in_tree_sigma [measurable, simp, intro]: "{Leaf} \<in> sets (tree_sigma M)"
  unfolding sets_tree_sigma_eq
  by (rule sigma_sets.Basic) (auto intro: trees.intros(2) image_eqI[where x=Leaf])

lemma trees_cyl_map_treeI: "t \<in> trees_cyl (map_tree (\<lambda>x. A) t)" if *: "t \<in> trees A"
  using * by induction auto

lemma trees_cyl_map_in_sets:
  "(\<And>x. x \<in> set_tree t \<Longrightarrow> f x \<in> sets M) \<Longrightarrow> trees_cyl (map_tree f t) \<in> sets (tree_sigma M)"
  by (subst sets_tree_sigma_eq) auto

lemma Node_in_tree_sigma:
  assumes L: "X \<in> sets (M \<Otimes>\<^sub>M (tree_sigma M \<Otimes>\<^sub>M tree_sigma M))"
  shows "{Node l v r | l v r. (v, l, r) \<in> X} \<in> sets (tree_sigma M)"
proof -
  let ?E = "\<lambda>s::unit tree. trees_cyl (map_tree (\<lambda>_. space M) s)"
  have 1: "countable (range ?E)"
    by (intro countable_image countableI_type)
  have 2: "trees_cyl ` trees (sets M) \<subseteq> Pow (space (tree_sigma M))"
    using trees_cyl_sets_in_space[of M] by (simp add: space_tree_sigma)
  have 3: "sets (tree_sigma M) = sigma_sets (space (tree_sigma M)) (trees_cyl ` trees (sets M))"
    unfolding sets_tree_sigma_eq by (simp add: space_tree_sigma)
  have 4: "(\<Union>s. ?E s) = space (tree_sigma M)"
  proof (safe; clarsimp simp: space_tree_sigma)
    fix t s assume "t \<in> trees_cyl (map_tree (\<lambda>_::unit. space M) s)"
    then show "t \<in> trees (space M)"
      by (induction s arbitrary: t) auto
  next
    fix t assume "t \<in> trees (space M)"
    then show "\<exists>t'. t \<in> ?E t'"
      by (intro exI[of _ "map_tree (\<lambda>_. ()) t"])
         (auto simp: tree.map_comp comp_def intro: trees_cyl_map_treeI)
  qed
  have 5: "range ?E \<subseteq> trees_cyl ` trees (sets M)" by auto
  let ?P = "{A \<times> B | A B. A \<in> trees_cyl ` trees (sets M) \<and> B \<in> trees_cyl ` trees (sets M)}"
  have P: "sets (tree_sigma M \<Otimes>\<^sub>M tree_sigma M) = sets (sigma (space (tree_sigma M) \<times> space (tree_sigma M)) ?P)"
    by (rule sets_pair_eq[OF 2 3 1 5 4 2 3 1 5 4])

  have "sets (M \<Otimes>\<^sub>M (tree_sigma M \<Otimes>\<^sub>M tree_sigma M)) =
    sets (sigma (space M \<times> space (tree_sigma M \<Otimes>\<^sub>M tree_sigma M)) {A \<times> BC | A BC. A \<in> sets M \<and> BC \<in> ?P})"
  proof (rule sets_pair_eq)
    show "sets M \<subseteq> Pow (space M)" "sets M = sigma_sets (space M) (sets M)"
      by (auto simp: sets.sigma_sets_eq sets.space_closed)
    show "countable {space M}" "{space M} \<subseteq> sets M" "\<Union>{space M} = space M"
      by auto
    show "?P \<subseteq> Pow (space (tree_sigma M \<Otimes>\<^sub>M tree_sigma M))"
      using trees_cyl_sets_in_space[of M]
      by (auto simp: space_pair_measure space_tree_sigma subset_eq)
    then show "sets (tree_sigma M \<Otimes>\<^sub>M tree_sigma M) =
      sigma_sets (space (tree_sigma M \<Otimes>\<^sub>M tree_sigma M)) ?P"
      by (subst P, subst sets_measure_of) (auto simp: space_tree_sigma space_pair_measure)
    show "countable ((\<lambda>(a, b). a \<times> b) ` (range ?E \<times> range ?E))"
      by (intro countable_image countable_SIGMA countableI_type)
    show "(\<lambda>(a, b). a \<times> b) ` (range ?E \<times> range ?E) \<subseteq> ?P"
      by auto
  qed (insert 4, auto simp: space_pair_measure space_tree_sigma set_eq_iff)
  also have "\<dots> = sigma_sets (space M \<times> trees (space M) \<times> trees (space M))
                    {A \<times> BC |A BC. A \<in> sets M \<and> BC \<in> {A \<times> B |A B.
                       A \<in> trees_cyl ` trees (sets M) \<and> B \<in> trees_cyl ` trees (sets M)}}"
    (is "_ = sigma_sets ?X ?Y") using sets.space_closed[of M] trees_cyl_sub_trees[of _ "sets M" "space M"]
    by (subst sets_measure_of)
       (auto simp: space_pair_measure space_tree_sigma)
  also have "?Y = {A \<times> trees_cyl B \<times> trees_cyl C | A B C. A \<in> sets M \<and>
                     B \<in> trees (sets M) \<and> C \<in> trees (sets M)}" by blast
  finally have "X \<in> sigma_sets (space M \<times> trees (space M) \<times> trees (space M))
    {A \<times> trees_cyl B \<times> trees_cyl C | A B C. A \<in> sets M \<and> B \<in> trees (sets M) \<and> C \<in> trees (sets M) }"
    using assms by blast
  then show ?thesis
  proof induction
    case (Basic A')
    then obtain A B C where "A' = A \<times> trees_cyl B \<times> trees_cyl C"
      and *: "A \<in> sets M" "B \<in> trees (sets M)" "C \<in> trees (sets M)"
      by auto
    then have "{Node l v r |l v r. (v, l, r) \<in> A'} = trees_cyl (Node B A C)"
      by auto
    then show ?case
      by (auto simp del: trees_cyl.simps simp: sets_tree_sigma_eq intro!: sigma_sets.Basic *)
  next
    case Empty show ?case by auto
  next
    case (Compl A)
    have "{Node l v r |l v r. (v, l, r) \<in> space M \<times> trees (space M) \<times> trees (space M) - A} =
      (space (tree_sigma M) - {Node l v r |l v r. (v, l, r) \<in> A}) - {Leaf}"
      by (auto simp: space_tree_sigma elim: trees.cases)
    also have "\<dots> \<in> sets (tree_sigma M)"
      by (intro sets.Diff Compl) auto
    finally show ?case .
  next
    case (Union I)
    have *: "{Node l v r |l v r. (v, l, r) \<in> \<Union>(I ` UNIV)} =
      (\<Union>i. {Node l v r |l v r. (v, l, r) \<in> I i})" by auto
    show ?case unfolding * using Union(2) by (intro sets.countable_UN) auto
  qed
qed

lemma measurable_left[measurable]: "left \<in> tree_sigma M \<rightarrow>\<^sub>M tree_sigma M"
proof (rule measurableI)
  show "t \<in> space (tree_sigma M) \<Longrightarrow> left t \<in> space (tree_sigma M)" for t
    by (cases t) (auto simp: space_tree_sigma)
  fix A assume A: "A \<in> sets (tree_sigma M)"
  from sets.sets_into_space[OF this]
  have *: "left -` A \<inter> space (tree_sigma M) =
    (if Leaf \<in> A then {Leaf} else {}) \<union>
    {Node a v r | a v r. (v, a, r) \<in> space M \<times> A \<times> space (tree_sigma M)}"
    by (auto simp: space_tree_sigma elim: trees.cases)
  show "left -` A \<inter> space (tree_sigma M) \<in> sets (tree_sigma M)"
    unfolding * using A by (intro sets.Un Node_in_tree_sigma pair_measureI) auto
qed

lemma measurable_right[measurable]: "right \<in> tree_sigma M \<rightarrow>\<^sub>M tree_sigma M"
proof (rule measurableI)
  show "t \<in> space (tree_sigma M) \<Longrightarrow> right t \<in> space (tree_sigma M)" for t
    by (cases t) (auto simp: space_tree_sigma)
  fix A assume A: "A \<in> sets (tree_sigma M)"
  from sets.sets_into_space[OF this]
  have *: "right -` A \<inter> space (tree_sigma M) =
    (if Leaf \<in> A then {Leaf} else {}) \<union>
    {Node l v a | l v a. (v, l, a) \<in> space M \<times> space (tree_sigma M) \<times> A}"
    by (auto simp: space_tree_sigma elim: trees.cases)
  show "right -` A \<inter> space (tree_sigma M) \<in> sets (tree_sigma M)"
    unfolding * using A by (intro sets.Un Node_in_tree_sigma pair_measureI) auto
qed

lemma measurable_value': "value \<in> restrict_space (tree_sigma M) (-{Leaf}) \<rightarrow>\<^sub>M M"
proof (rule measurableI)
  show "t \<in> space (restrict_space (tree_sigma M) (- {Leaf})) \<Longrightarrow> value t \<in> space M" for t
    by (cases t) (auto simp: space_restrict_space space_tree_sigma)
  fix A assume A: "A \<in> sets M"
  from sets.sets_into_space[OF this]
  have "value -` A \<inter> space (restrict_space (tree_sigma M) (- {Leaf})) =
    {Node l a r | l a r. (a, l, r) \<in> A \<times> space (tree_sigma M) \<times> space (tree_sigma M)}"
    by (auto simp: space_tree_sigma space_restrict_space elim: trees.cases)
  also have "\<dots> \<in> sets (tree_sigma M)"
    using A by (intro sets.Un Node_in_tree_sigma pair_measureI) auto
  finally show "value -` A \<inter> space (restrict_space (tree_sigma M) (- {Leaf})) \<in>
      sets (restrict_space (tree_sigma M) (- {Leaf}))"
    by (auto simp: sets_restrict_space_iff space_restrict_space)
qed

lemma measurable_value[measurable (raw)]:
  assumes "f \<in> X \<rightarrow>\<^sub>M tree_sigma M"
    and "\<And>x. x \<in> space X \<Longrightarrow> f x \<noteq> Leaf"
  shows "(\<lambda>\<omega>. value (f \<omega>)) \<in> X \<rightarrow>\<^sub>M M"
proof -
  from assms have "f \<in> X \<rightarrow>\<^sub>M restrict_space (tree_sigma M) (- {Leaf})"
    by (intro measurable_restrict_space2) auto
  from this and measurable_value' show ?thesis by (rule measurable_compose)
qed

lemma measurable_Node [measurable]:
  "(\<lambda>(l,x,r). Node l x r) \<in> tree_sigma M \<Otimes>\<^sub>M M \<Otimes>\<^sub>M tree_sigma M \<rightarrow>\<^sub>M tree_sigma M"
proof (rule measurable_sigma_sets)
  show "sets (tree_sigma M) = sigma_sets (trees (space M)) (trees_cyl ` trees (sets M))"
    by (simp add: sets_tree_sigma_eq)
  show "trees_cyl ` trees (sets M) \<subseteq> Pow (trees (space M))"
    by (rule trees_cyl_sets_in_space)
  show "(\<lambda>(l, x, r). \<langle>l, x, r\<rangle>) \<in> space (tree_sigma M \<Otimes>\<^sub>M M \<Otimes>\<^sub>M tree_sigma M) \<rightarrow> trees (space M)"
    by (auto simp: space_pair_measure space_tree_sigma)
  fix A assume t: "A \<in> trees_cyl ` trees (sets M)"
  then obtain t where t: "t \<in> trees (sets M)" "A = trees_cyl t" by auto
  show "(\<lambda>(l, x, r). \<langle>l, x, r\<rangle>) -` A \<inter>
         space (tree_sigma M \<Otimes>\<^sub>M M \<Otimes>\<^sub>M tree_sigma M)
         \<in> sets (tree_sigma M \<Otimes>\<^sub>M M \<Otimes>\<^sub>M tree_sigma M)"
  proof (cases t)
    case Leaf
    have "(\<lambda>(l, x, r). \<langle>l, x, r\<rangle>) -` {Leaf :: 'a tree} = {}" by auto
    with Leaf show ?thesis using t by simp
  next
    case (Node l B r)
    hence "(\<lambda>(l, x, r). \<langle>l, x, r\<rangle>) -` A \<inter> space (tree_sigma M \<Otimes>\<^sub>M M \<Otimes>\<^sub>M tree_sigma M) =
             trees_cyl l \<times> B \<times> trees_cyl r"
      using t and Node and trees_cyl_sub_trees[of _ "sets M" "space M"]
      by (auto simp: space_pair_measure space_tree_sigma
               dest: sets.sets_into_space[of _ M])
    thus ?thesis using t and Node
      by (auto intro!: pair_measureI simp: sets_tree_sigma_eq)
  qed
qed

lemma measurable_Node' [measurable (raw)]:
  assumes [measurable]: "l \<in> B \<rightarrow>\<^sub>M tree_sigma A"
  assumes [measurable]: "x \<in> B \<rightarrow>\<^sub>M A"
  assumes [measurable]: "r \<in> B \<rightarrow>\<^sub>M tree_sigma A"
  shows   "(\<lambda>y. Node (l y) (x y) (r y)) \<in> B \<rightarrow>\<^sub>M tree_sigma A"
proof -
  have "(\<lambda>y. Node (l y) (x y) (r y)) = (\<lambda>(a,b,c). Node a b c) \<circ> (\<lambda>y. (l y, x y, r y))"
    by (simp add: o_def)
  also have "\<dots> \<in> B \<rightarrow>\<^sub>M tree_sigma A"
    by (intro measurable_comp[OF _ measurable_Node]) simp_all
  finally show ?thesis .
qed

lemma measurable_rec_tree[measurable (raw)]:
  assumes t: "t \<in> B \<rightarrow>\<^sub>M tree_sigma M"
  assumes l: "l \<in> B \<rightarrow>\<^sub>M A"
  assumes n: "(\<lambda>(x, l, v, r, al, ar). n x l v r al ar) \<in>
    (B \<Otimes>\<^sub>M tree_sigma M \<Otimes>\<^sub>M M \<Otimes>\<^sub>M tree_sigma M \<Otimes>\<^sub>M A \<Otimes>\<^sub>M A) \<rightarrow>\<^sub>M A" (is "?N \<in> ?M \<rightarrow>\<^sub>M A")
  shows "(\<lambda>x. rec_tree (l x) (n x) (t x)) \<in> B \<rightarrow>\<^sub>M A"
proof (rule measurable_piecewise_restrict)
  let ?C = "\<lambda>t. \<lambda>s::unit tree. t -` trees_cyl (map_tree (\<lambda>_. space M) s)"
  show "countable (range (?C t))" by (intro countable_image countableI_type)
  show "space B \<subseteq> (\<Union>s. ?C t s)"
  proof (safe; clarsimp)
    fix x assume x: "x \<in> space B" have "t x \<in> trees (space M)"
      using t[THEN measurable_space, OF x] by (simp add: space_tree_sigma)
    then show "\<exists>xa::unit tree. t x \<in> trees_cyl (map_tree (\<lambda>_. space M) xa)"
      by (intro exI[of _ "map_tree (\<lambda>_. ()) (t x)"])
         (simp add: tree.map_comp comp_def trees_cyl_map_treeI)
  qed
  fix \<Omega> assume "\<Omega> \<in> range (?C t)"
  then obtain s :: "unit tree" where \<Omega>: "\<Omega> = ?C t s" by auto
  then show "\<Omega> \<inter> space B \<in> sets B"
    by (safe intro!: measurable_sets[OF t] trees_cyl_map_in_sets)
  show "(\<lambda>x. rec_tree (l x) (n x) (t x)) \<in> restrict_space B \<Omega> \<rightarrow>\<^sub>M A"
    unfolding \<Omega> using t
  proof (induction s arbitrary: t)
    case Leaf
    show ?case
    proof (rule measurable_cong[THEN iffD2])
      fix \<omega> assume "\<omega> \<in> space (restrict_space B (?C t Leaf))"
      then show "rec_tree (l \<omega>) (n \<omega>) (t \<omega>) = l \<omega>"
        by (auto simp: space_restrict_space)
    next
      show "l \<in> restrict_space B (?C t Leaf) \<rightarrow>\<^sub>M A"
        using l by (rule measurable_restrict_space1)
    qed
  next
    case (Node ls u rs)
    let ?F = "\<lambda>\<omega>. ?N (\<omega>, left (t \<omega>), value (t \<omega>), right (t \<omega>),
        rec_tree (l \<omega>) (n \<omega>) (left (t \<omega>)), rec_tree (l \<omega>) (n \<omega>) (right (t \<omega>)))"
    show ?case
    proof (rule measurable_cong[THEN iffD2])
      fix \<omega> assume "\<omega> \<in> space (restrict_space B (?C t (Node ls u rs)))"
      then show "rec_tree (l \<omega>) (n \<omega>) (t \<omega>) = ?F \<omega>"
        by (auto simp: space_restrict_space)
    next
      show "?F \<in> (restrict_space B (?C t (Node ls u rs))) \<rightarrow>\<^sub>M A"
        apply (intro measurable_compose[OF _ n] measurable_Pair[rotated])
        subgoal
          apply (rule measurable_restrict_mono[OF Node(2)])
          apply (rule measurable_compose[OF Node(3) measurable_right])
          by auto
        subgoal
          apply (rule measurable_restrict_mono[OF Node(1)])
          apply (rule measurable_compose[OF Node(3) measurable_left])
          by auto
        subgoal
          by (rule measurable_restrict_space1)
             (rule measurable_compose[OF Node(3) measurable_right])
        subgoal
          apply (rule measurable_compose[OF _ measurable_value'])
          apply (rule measurable_restrict_space3[OF Node(3)])
          by auto
        subgoal
          by (rule measurable_restrict_space1)
             (rule measurable_compose[OF Node(3) measurable_left])
        by (rule measurable_restrict_space1) auto
    qed
  qed
qed

lemma measurable_case_tree [measurable (raw)]:
  assumes "t \<in> B \<rightarrow>\<^sub>M tree_sigma M"
  assumes "l \<in> B \<rightarrow>\<^sub>M A"
  assumes "(\<lambda>(x, l, v, r). n x l v r)
             \<in> B \<Otimes>\<^sub>M tree_sigma M \<Otimes>\<^sub>M M \<Otimes>\<^sub>M tree_sigma M \<rightarrow>\<^sub>M A"
  shows   "(\<lambda>x. case_tree (l x) (n x) (t x)) \<in> B \<rightarrow>\<^sub>M (A :: 'a measure)"
proof -
  define n' where "n' = (\<lambda>x l v r (_::'a) (_::'a). n x l v r)"
  have "(\<lambda>x. case_tree (l x) (n x) (t x)) = (\<lambda>x. rec_tree (l x) (n' x) (t x))"
    (is "_ = (\<lambda>x. rec_tree _ (?n' x) _)") by (rule ext) (auto split: tree.splits simp: n'_def)
  also have "\<dots> \<in> B \<rightarrow>\<^sub>M A"
  proof (rule measurable_rec_tree)
    have "(\<lambda>(x, l, v, r, al, ar). n' x l v r al ar) =
            (\<lambda>(x,l,v,r). n x l v r) \<circ> (\<lambda>(x,l,v,r,al,ar). (x,l,v,r))"
      by (simp add: n'_def o_def case_prod_unfold)
    also have "\<dots> \<in> B \<Otimes>\<^sub>M tree_sigma M \<Otimes>\<^sub>M M \<Otimes>\<^sub>M tree_sigma M \<Otimes>\<^sub>M A \<Otimes>\<^sub>M A \<rightarrow>\<^sub>M A"
      using assms(3) by measurable
    finally show "(\<lambda>(x, l, v, r, al, ar). n' x l v r al ar) \<in> \<dots>" .
  qed (insert assms, simp_all)
  finally show ?thesis .
qed

hide_const (open) left
hide_const (open) right

end