section \<open>Base system E\<close>
(*<*)
theory cubeoldrenamed
imports Main

begin
(*>*)

subsection \<open>Introduction\<close>

subsection \<open>Base System E\<close>

text \<open>We present an approach to meta-reasoning about dyadic deontic logics, and
apply it to verify the relative strengths of logics in the deontic cube. This one is still
under construction, and closer to a line at the moment. We introduce the
properties of the betterness relation, and their syntactical counterparts. We ask Isabelle/HOL to

(1) confirm known correspondance (established by pen and paper) under
different evaluation rules for the conditional obligation operator: max rule, opt rule, closure
maximality, and  Lewis rule.
(2) verify the asbsence of syntactical counterpart of some properties
(3) answer open problems regarding correspondance problems  (open in the sense of unsettled by
 pen and paper). \<close>

section \<open>Framework\<close>

text \<open>This is Aqvis's system E from the 2019 IfColog paper.\<close>

typedecl i (*Possible worlds.*)
type_synonym \<sigma> = "(i\<Rightarrow>bool)"
type_synonym \<alpha> = "i\<Rightarrow>\<sigma>" (*Type of betterness relation between worlds.*)
type_synonym \<tau> = "\<sigma>\<Rightarrow>\<sigma>"

consts aw::i (*Actual world.*)
abbreviation etrue  :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation efalse :: "\<sigma>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation enot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation eand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation eor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation eimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation eequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

abbreviation ebox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<box>") where "\<box> \<equiv> \<lambda>\<phi> w.  \<forall>v. \<phi>(v)"
definition ddediomond  :: "\<sigma>\<Rightarrow>\<sigma>" ("\<diamond>") where "\<diamond>\<phi> \<equiv> \<lambda>w. \<exists>v. \<phi>(v)"

abbreviation evalid :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  (*Global validity.*)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
abbreviation ecjactual :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) (*Local validity — in world aw.*)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

consts r :: "\<alpha>" (infixr "r" 70) (*Betterness relation*)

abbreviation esubset :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"

abbreviation eopt  :: "\<sigma>\<Rightarrow>\<sigma>" ("opt<_>")  (* opt rule*)
  where "opt<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x) \<longrightarrow> v r x) )) )"
abbreviation econdopt :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<odot><_|_>")
  where "\<odot><\<psi>|\<phi>> \<equiv>  \<lambda>w. opt<\<phi>> \<^bold>\<subseteq> \<psi>"
abbreviation eperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\
<_|_>")
  where "\
<\<psi>|\<phi>> \<equiv> \<^bold>\<not>\<odot><\<^bold>\<not>\<psi>|\<phi>>"

abbreviation emax  :: "\<sigma>\<Rightarrow>\<sigma>" ("max<_>")      (*Max rule *)
  where "max<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x) \<longrightarrow> (x r v \<longrightarrow>  v r x)) )) )"
abbreviation econd  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv>  \<lambda>w. max<\<phi>> \<^bold>\<subseteq> \<psi>"
abbreviation euncobl :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circle><_>")
  where "\<^bold>\<circle><\<phi>> \<equiv> \<circle><\<phi>|\<^bold>\<top>>"
abbreviation ddeperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("P<_|_>")
  where "P<\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<circle><\<^bold>\<not>\<psi>|\<phi>>"

lemma True nitpick[satisfy,user_axioms,expect=genuine] oops

lemma "\<odot><\<psi>|\<phi>> \<equiv> \<circle><\<psi>|\<phi>>" nitpick [show_all] (*countermodel found*) oops

(*David Lewis's evaluation rule for the conditional *)

abbreviation lewcond :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>"  ("\<circ><_|_>")
  where "\<circ><\<psi>|\<phi>> \<equiv> \<lambda>v. (\<not>(\<exists>x. (\<phi>)(x))\<or>
        (\<exists>x. ((\<phi>)(x)\<and>(\<psi>)(x) \<and> (\<forall>y. ((y r x) \<longrightarrow> (\<phi>)(y)\<longrightarrow>(\<psi>)(y))))))"
abbreviation lewperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<integral><_|_>")
  where "\<integral><\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<circ><\<^bold>\<not>\<psi>|\<phi>>"

lemma True nitpick [satisfy,user_axioms,expect=genuine]
  oops

(*The standard properties*)
abbreviation reflexivity  where "reflexivity  \<equiv> (\<forall>x. x r x)"
abbreviation transitivity
  where "transitivity \<equiv> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z)"
abbreviation totalness
  where "totalness \<equiv> (\<forall>x y. (x r y \<or> y r x))"

(*4 versions of Lewis's limit assumption*)
abbreviation mlimitedness
  where "mlimitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. max<\<phi>>x))"

abbreviation msmoothness
 where "msmoothness \<equiv> (\<forall>\<phi> x. ((\<phi>)x \<longrightarrow>
                     (max<\<phi>>x \<or> (\<exists>y. (y r x \<and> \<not>(x r y) \<and> max<\<phi>>y)))))"
abbreviation olimitedness
  where "olimitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x))"
abbreviation osmoothness  where
   "osmoothness \<equiv> (\<forall>\<phi> x. ((\<phi>)x \<longrightarrow>
                      (opt<\<phi>>x \<or> (\<exists>y. (y r x \<and> \<not>(x r y) \<and> opt<\<phi>>y)))))"
definition transitive :: "\<alpha>\<Rightarrow>bool" where "transitive R \<equiv> \<forall>x y z. R x y \<and>  R y z \<longrightarrow> R x z"
definition sub_rel :: "\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"
definition assfactor::"\<alpha>\<Rightarrow>\<alpha>" where "assfactor R \<equiv> \<lambda>u v. R u v \<and> \<not> R v u "
(*In HOL the transitive closure of a relation can be defined in a single line.*)
definition tc :: "\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"
(* this is a first form of a-cyclicity. Cycles with one non-strict betterness are ruled out*)
abbreviation Suzumura
  where "Suzumura R \<equiv> \<forall>x y. (tc R x y \<longrightarrow> ( R y x \<longrightarrow> R x y))"
(* this is a second form of a-cyclicity. Cycles of non-strict betterness are ruled out*)
abbreviation loopfree
  where "loopfree R \<equiv> \<forall>x y. (tc (assfactor R) x y \<longrightarrow> ( R y x \<longrightarrow> R x y))"

(*Interval order condition is totalness plus Ferrers*)
abbreviation Ferrers
  where "Ferrers \<equiv> (\<forall>x y z u. ((x r u) \<and> (y r z)) \<longrightarrow> (x r z) \<or> (y r u))"
lemma assumes Ferrers reflexivity  (*fact overlooked in the literature*)
  shows totalness
  sledgehammer  (*proof found*)
  oops

=======
section \<open>Max rule\<close>
subsection \<open>Correspondence\<close>
text \<open>We go through the known correspondences, and verify them \<close>

(*max-Limitedness corresponds to D*)
lemma "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>)\<rfloor>"
  nitpick [show_all]  (* counterexample found *)
  oops

lemma "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  nitpick [show_all] (* counterexample found *)
  oops

lemma "\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)>\<^bold>\<rightarrow>((\<circle><\<chi>|\<phi>>)\<^bold>\<or>(\<circle><\<chi>|\<psi>>))\<rfloor>"
  nitpick (* counterexample found *)
  oops

(*max-Limitedness corresponds to D*)

lemma assumes "mlimitedness"
  shows  "D*": "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>\<rfloor>"
  sledgehammer
  oops (*proof found*)

lemma assumes "D*": "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<^bold>\<not>\<psi>|\<phi>>)\<rfloor>"
  shows "mlimitedness"
  sledgehammer (*all timed out*)
  nitpick [show_all] (* counterexample found *)
  oops

lemma assumes "nmlimitedness"
  shows  "nD*": "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>\<rfloor>"
  sledgehammer oops
  nitpick

(*smoothness corresponds to cautious monotony *)
lemma assumes "msmoothness"
  shows  CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma assumes CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  shows  "msmoothness"
  sledgehammer (* timed out*)
  nitpick [show_all] (* counterexample found *)
  oops

(*interval order (reflexivity plus Ferrers) corresponds to disjunctive rationality*)

lemma assumes "reflexivity"
     (* assumes "Ferrers"*)
  shows  DR: "\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)>\<^bold>\<rightarrow>((\<circle><\<chi>|\<phi>>)\<^bold>\<or>(\<circle><\<chi>|\<psi>>))\<rfloor>"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

lemma assumes "reflexivity" "Ferrers"
  shows  DR: "\<forall>\<phi> \<psi> \<chi>.\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)>\<^bold>\<rightarrow>((\<circle><\<chi>|\<phi>>)\<^bold>\<or>(\<circle><\<chi>|\<psi>>))\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes DR: "\<lfloor>\<circle><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<circle><\<chi>|\<phi>>\<^bold>\<or>\<circle><\<chi>|\<psi>>)\<rfloor>"
  shows "reflexivity"
  sledgehammer (* timed out*)
  nitpick [show_all] (* counterexample found *)
  oops

lemma assumes DR: "\<lfloor>\<circle><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<circle><\<chi>|\<phi>>\<^bold>\<or>\<circle><\<chi>|\<psi>>)\<rfloor>"
  shows "Ferrers"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

text \<open>Transitivity and totalness corresponds to the Spohn axiom (Sp)\<close>

lemma assumes "transitivity"
  shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* timed out *)
  nitpick (* counterexample for card i=5*)
  oops

lemma assumes "totalness"
  shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* timed out*)
  nitpick (* counterexample for card i=4*)
  oops

lemma assumes "transitivity" "totalness"
  shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  shows "totalness"
  sledgehammer (* timed out*)
  nitpick (* counterexample found for card i=1*)
  oops

lemma assumes  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  shows "transitivity"
  sledgehammer (* timed out*)
  nitpick (* counterexample found for card =4*)
  oops

subsection \<open>Correspondance under the opt rule\<close>

text \<open>We move to the opt rule, and associate with it two news modal operators\<close>

text \<open>Here we redefine Lewis's limit assumption accordingly\<close>

text \<open>Correspondance\<close>

text \<open>opt-Limitedness corresponds to D\<close>

lemma assumes "olimitedness"
  shows  D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<odot><\<psi>|\<phi>> \<^bold>\<rightarrow> \
<\<psi>|\<phi>>\<rfloor>"
  sledgehammer (* proof found*)
  nitpick (* no counterexample found *)
  oops

lemma assumes D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<odot><\<psi>|\<phi>> \<^bold>\<rightarrow> \
<\<psi>|\<phi>>\<rfloor>"
  shows "olimitedness"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

text \<open>Smoothness corresponds to CM\<close>

lemma assumes "osmoothness"
  shows  CM: "\<lfloor>(\<odot><\<psi>|\<phi>>\<^bold>\<and>\<odot><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<odot><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  sledgehammer (* proof found*)
  nitpick (* run out of time *)
  oops

lemma assumes CM: "\<lfloor>(\<odot><\<psi>|\<phi>>\<^bold>\<and>\<odot><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<odot><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  shows  "osmoothness"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

(*transitivity*)

lemma assumes "transitivity"
  shows  Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes "transitivity"
  shows  Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<psi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<phi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick [show_all] (* no counterexample found *)
  oops

lemma assumes Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
      assumes Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<psi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<phi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
      shows "transitivity"
  sledgehammer (* timed out*)
  nitpick (* counterexample found for card i =3*)
  oops

lemma assumes "totalness"
     (* assumes "Ferrers"*)
  shows  DR: "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<odot><\<chi>|\<phi>>\<^bold>\<or>\<odot><\<chi>|\<psi>>)\<rfloor>"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

 lemma assumes DR: "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<odot><\<chi>|\<phi>>\<^bold>\<or>\<odot><\<chi>|\<psi>>)\<rfloor>"
   shows "totalness"
   sledgehammer (* timed out*)
   nitpick (* counterexample found *)
   oops

lemma assumes DR: "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<odot><\<chi>|\<phi>>\<^bold>\<or>\<odot><\<chi>|\<psi>>)\<rfloor>"
  shows "Ferrers"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

subsection \<open>Lewis rule\<close>
text \<open>Under the Lewis rule, totalness corresponds to D \<close>

<<<<<<>>>>>> d525449de509a66502343688bd83123161185f5a:Deontic-Logics/cube-ddl/old/cube.thy
(*deontic explosion-max rule*)
lemma DEX: "\<lfloor>(\<diamond>\<phi>\<^bold>\<and>\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<^bold>\<not>\<psi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

(*no-deontic explosion-lewis rule*)
lemma DEX: "\<lfloor>(\<diamond>\<phi>\<^bold>\<and>\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<^bold>\<not>\<psi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>>\<rfloor>"
  sledgehammer (*timed out*)
  nitpick (*counter-model found for card i = 3*)
  oops

lemma assumes "mlimitedness"
  assumes "transitivity"
  assumes "totalness"
  shows "\<lfloor>\<circ><\<psi>|\<phi>>\<^bold>\<leftrightarrow>\<odot><\<psi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma assumes "mlimitedness"
  assumes "transitivity"
  assumes "totalness"
 shows "\<lfloor>\<circ><\<psi>|\<phi>>\<^bold>\<leftrightarrow>\<circle><\<psi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

(*axioms of E holding if r transitive and totale*)

lemma D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circ><\<psi>|\<phi>> \<^bold>\<rightarrow> \<integral><\<psi>|\<phi>>)\<rfloor>"
  nitpick (*countermodel*)
  oops

lemma
 assumes "totalness"
 shows D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circ><\<psi>|\<phi>> \<^bold>\<rightarrow> \<integral><\<psi>|\<phi>>)\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma  Sp: "\<lfloor>( \<integral><\<psi>|\<phi>> \<^bold>\<and> \<circ><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circ><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  nitpick (*countermodel*)
  oops

lemma
 assumes "transitivity"
 shows Sp: "\<lfloor>( \<integral><\<psi>|\<phi>> \<^bold>\<and> \<circ><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circ><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma
  COK:"\<lfloor>\<circ><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circ><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circ><\<psi>\<^sub>2|\<phi>>)\<rfloor>"
  nitpick (*countermodel*)
  oops

lemma
  assumes "transitivity"
  shows COK:"\<lfloor>\<circ><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circ><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circ><\<psi>\<^sub>2|\<phi>>)\<rfloor>"
  nitpick (*countermodel*)
  oops

  lemma
  assumes "totalness"
  shows COK:"\<lfloor>\<circ><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circ><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circ><\<psi>\<^sub>2|\<phi>>)\<rfloor>"
  nitpick (*countermodel*)
  oops

lemma
  assumes "transitivity"
  assumes "totalness"
  shows COK:"\<lfloor>\<circ><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circ><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circ><\<psi>\<^sub>2|\<phi>>)\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma CM: "\<lfloor>(\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  nitpick (*countermodel*)
  oops

lemma
  assumes "transitivity"
  shows CM: "\<lfloor>(\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  nitpick (*countermodel*)
  oops

lemma
  assumes "totalness"
  shows CM: "\<lfloor>(\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  nitpick (*countermodel*)
  oops

lemma
  assumes "transitivity"
  assumes "totalness"
  shows CM: "\<lfloor>(\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

(*axioms of E holding irrespective of the properties of r*)

lemma Abs:"\<lfloor>\<circ><\<psi>|\<phi>> \<^bold>\<rightarrow> \<box>\<circ><\<psi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma Nec:"\<lfloor>\<box>\<psi> \<^bold>\<rightarrow> \<circ><\<psi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma Ext:"\<lfloor>\<box>(\<phi>\<^sub>1\<^bold>\<leftrightarrow>\<phi>\<^sub>2) \<^bold>\<rightarrow> (\<circ><\<psi>|\<phi>\<^sub>1> \<^bold>\<leftrightarrow> \<circ><\<psi>|\<phi>\<^sub>2>)\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma Id:"\<lfloor>\<circ><\<phi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma Sh:"\<lfloor>\<circ><\<psi>|\<phi>\<^sub>1\<^bold>\<and>\<phi>\<^sub>2> \<^bold>\<rightarrow> \<circ><(\<phi>\<^sub>2\<^bold>\<rightarrow>\<psi>)|\<phi>\<^sub>1>\<rfloor>"
  sledgehammer (*proof found*)
  oops

  section \<open>Negative results\<close>

text \<open>Under the max and opt rules there is no formula corresponding to reflexivity\<close>

(*ToDO not sure how to do it--something like there is no A such that "reflexivity <\<Rightarrow> A"*)

text \<open>Under the max and opt rules there is no formula corresponding to totalness\<close>

(*ToDO*)

text \<open>Under the max rule there is no formula corresponding to transitivity\<close>

(*ToDO*)

text \<open>Under the max rule there is no formula corresponding to a-cyclicity\<close>

(*ToDO*)

text \<open>Under the max rule there is no formula corresponding to Suzumura consistency\<close>

(*ToDO*)

text \<open>Under the Lewis rule there is no formula corresponding to limitedness/smoothness\<close>

section \<open>Some open problems\<close>

text \<open>Under the opt rule transitivity alone is equivalent to Sp and Trans\<close>

lemma assumes "transitivity"
  shows  Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes "transitivity"
  shows  Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma assumes Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
      assumes Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
      shows "transitivity"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

  text \<open>Under the opt rule quasi-transitivity, a-cyclicity and Suzumura consistent do not correspond to
any formula\<close>

(*to do*)

text \<open>Under the opt rule transitivity alone is equivalent to Sp and Trans\<close>


section \<open>Tracking SPMFs\label{sec:tracking_spmfs}\<close>

text \<open>This section introduces tracking SPMFs --- this is a resource monad on top of SPMFs, we also
introduce the Scott-continous monad morphism @{term "tspmf_of_ra"}, with which it is possible to
reason about the joint-distribution of a randomized algorithm's result and used coin-flips.

An example application of the results in this theory can be found in Section~\ref{sec:dice_roll}.\<close>

theory Tracking_SPMF
  imports Tracking_Randomized_Algorithm
begin

type_synonym 'a tspmf = "('a \<times> nat) spmf"

definition return_tspmf :: "'a \<Rightarrow> 'a tspmf" where
  "return_tspmf x = return_spmf (x,0)"

definition coin_tspmf :: "bool tspmf" where
  "coin_tspmf = pair_spmf coin_spmf (return_spmf 1)"

definition bind_tspmf :: "'a tspmf \<Rightarrow> ('a \<Rightarrow> 'b tspmf) \<Rightarrow> 'b tspmf" where
  "bind_tspmf f g = bind_spmf f (\<lambda>(r,c). map_spmf (apsnd ((+) c)) (g r))"

adhoc_overloading Monad_Syntax.bind bind_tspmf

text \<open>Monad laws:\<close>

lemma return_bind_tspmf:
  "bind_tspmf (return_tspmf x) g = g x"
  unfolding bind_tspmf_def return_tspmf_def map_spmf_conv_bind_spmf
  by (simp add:apsnd_def map_prod_def)

lemma bind_tspmf_assoc:
  "bind_tspmf (bind_tspmf f g) h = bind_tspmf f (\<lambda>x. bind_tspmf (g x) h)"
  unfolding bind_tspmf_def
  by (simp add: case_prod_beta' algebra_simps map_spmf_conv_bind_spmf apsnd_def map_prod_def)

lemma bind_return_tspmf:
  "bind_tspmf m return_tspmf = m"
  unfolding bind_tspmf_def return_tspmf_def map_spmf_conv_bind_spmf apsnd_def
  by (simp add:case_prod_beta')

lemma bind_mono_tspmf_aux:
  assumes "ord_spmf (=) f1 f2" "\<And>y. ord_spmf (=) (g1 y) (g2 y)"
  shows "ord_spmf (=) (bind_tspmf f1 g1) (bind_tspmf f2 g2)"
  using assms unfolding bind_tspmf_def map_spmf_conv_bind_spmf
  by (auto intro!: bind_spmf_mono' simp add:case_prod_beta')

lemma bind_mono_tspmf [partial_function_mono]:
  assumes "mono_spmf B" and "\<And>y. mono_spmf (C y)"
  shows "mono_spmf (\<lambda>f. bind_tspmf (B f) (\<lambda>y. C y f))"
  using assms by (intro monotoneI bind_mono_tspmf_aux) (auto simp:monotone_def)

definition ord_tspmf :: "'a tspmf \<Rightarrow> 'a tspmf \<Rightarrow> bool" where
  "ord_tspmf = ord_spmf (\<lambda>x y. fst x = fst y \<and> snd x \<ge> snd y)"

bundle ord_tspmf_notation
begin
  notation ord_tspmf  ("(_/ \<le>\<^sub>R _)"  [51, 51] 50)
end

bundle no_ord_tspmf_notation
begin
  no_notation ord_tspmf  ("(_/ \<le>\<^sub>R _)"  [51, 51] 50)
end

unbundle ord_tspmf_notation

definition coin_usage_of_tspmf :: "'a tspmf \<Rightarrow> enat pmf"
  where "coin_usage_of_tspmf = map_pmf (\<lambda>x. case x of None \<Rightarrow> \<infinity> | Some y \<Rightarrow> enat (snd y))"

definition expected_coin_usage_of_tspmf :: "'a tspmf \<Rightarrow> ennreal"
  where
    "expected_coin_usage_of_tspmf p = (\<integral>\<^sup>+x. x \<partial>(map_pmf ennreal_of_enat (coin_usage_of_tspmf p)))"

definition expected_coin_usage_of_ra where
  "expected_coin_usage_of_ra p = \<integral>\<^sup>+x. x \<partial>(map_pmf ennreal_of_enat (coin_usage_of_ra p))"

definition result :: "'a tspmf \<Rightarrow> 'a spmf"
  where "result = map_spmf fst"

lemma coin_usage_of_tspmf_alt_def:
  "coin_usage_of_tspmf p = map_pmf (\<lambda>x. case x of None \<Rightarrow> \<infinity> | Some y \<Rightarrow> enat y) (map_spmf snd p)"
  unfolding coin_usage_of_tspmf_def map_pmf_comp map_option_case
  by (metis enat_def infinity_enat_def option.case_eq_if option.sel)

lemma coin_usage_of_tspmf_bind_return:
  "coin_usage_of_tspmf (bind_tspmf f (\<lambda>x. return_tspmf (g x))) = (coin_usage_of_tspmf f)"
  unfolding bind_tspmf_def return_tspmf_def coin_usage_of_tspmf_alt_def map_spmf_bind_spmf
  by (simp add:comp_def case_prod_beta map_spmf_conv_bind_spmf)

lemma coin_usage_of_tspmf_mono:
  assumes "ord_tspmf p q"
  shows "measure (coin_usage_of_tspmf p) {..k} \<le> measure (coin_usage_of_tspmf q) {..k}"
proof -
  define p' where "p' = map_spmf snd p"
  define q' where "q' = map_spmf snd q"
  have 0:"ord_spmf (\<ge>) p' q'"
    using assms(1) ord_spmf_mono unfolding p'_def q'_def ord_tspmf_def ord_spmf_map_spmf12 by fastforce

  have cp:"coin_usage_of_tspmf p = map_pmf (case_option \<infinity> enat) p'"
    unfolding coin_usage_of_tspmf_alt_def p'_def by simp
  have cq:"coin_usage_of_tspmf q = map_pmf (case_option \<infinity> enat) q'"
    unfolding coin_usage_of_tspmf_alt_def q'_def by simp

  have 0:"rel_pmf (\<ge>) (coin_usage_of_tspmf p) (coin_usage_of_tspmf q)"
    unfolding cp cq map_pmf_def by (intro rel_pmf_bindI[OF 0]) (auto split:option.split)
  show ?thesis
    unfolding atMost_def by (intro measure_Ici[OF 0] transp_ge) (simp add:reflp_def)
qed

lemma coin_usage_of_tspmf_mono_rev:
  assumes "ord_tspmf p q"
  shows "measure (coin_usage_of_tspmf q) {x. x > k} \<le> measure (coin_usage_of_tspmf p) {x. x > k}"
    (is "?L \<le> ?R")
proof -
  have 0:"UNIV - {x. x > k} = {..k}"
    by (auto simp add:set_diff_eq set_eq_iff)
  have "1 - ?R \<le> 1 - ?L"
    using coin_usage_of_tspmf_mono[OF assms]
    by (subst (1 2) measure_pmf.prob_compl[symmetric]) (auto simp:0)
  thus ?thesis
    by simp
qed

lemma expected_coin_usage_of_tspmf:
  "expected_coin_usage_of_tspmf p = (\<Sum>k. ennreal (measure (coin_usage_of_tspmf p) {x. x > enat k}))" (is "?L = ?R")
proof -
  have "?L = integral\<^sup>N (measure_pmf (coin_usage_of_tspmf p)) ennreal_of_enat"
    unfolding expected_coin_usage_of_tspmf_def by simp
  also have "... = (\<Sum>k. emeasure (measure_pmf (coin_usage_of_tspmf p)) {x. enat k < x})"
    by (subst nn_integral_enat_function) auto
  also have "... = ?R"
    by (subst measure_pmf.emeasure_eq_measure) simp
  finally show ?thesis
    by simp
qed

lemma ord_tspmf_min: "ord_tspmf (return_pmf None) p"
  unfolding ord_tspmf_def by (simp add: ord_spmf_reflI)

lemma ord_tspmf_refl: "ord_tspmf p p"
  unfolding ord_tspmf_def by (simp add: ord_spmf_reflI)

lemma ord_tspmf_trans[trans]:
  assumes "ord_tspmf p q" "ord_tspmf q r"
  shows "ord_tspmf p r"
proof -
  have 0:"transp (ord_tspmf)"
    unfolding ord_tspmf_def
    by (intro transp_rel_pmf transp_ord_option) (auto simp:transp_def)
  thus ?thesis
    using assms transpD[OF 0] by auto
qed

lemma ord_tspmf_map_spmf:
  assumes "\<And>x. x \<le> f x"
  shows "ord_tspmf (map_spmf (apsnd f) p) p"
  using assms unfolding ord_tspmf_def ord_spmf_map_spmf1
  by (intro ord_spmf_reflI) auto

lemma ord_tspmf_bind_pmf:
  assumes "\<And>x. ord_tspmf (f x) (g x)"
  shows "ord_tspmf (bind_pmf p f) (bind_pmf p g)"
  using assms unfolding ord_tspmf_def
  by (intro rel_pmf_bindI[where R="(=)"]) (auto simp add: pmf.rel_refl)

lemma ord_tspmf_bind_tspmf:
  assumes "\<And>x. ord_tspmf (f x) (g x)"
  shows "ord_tspmf (bind_tspmf p f) (bind_tspmf p g)"
  using assms unfolding bind_tspmf_def ord_tspmf_def
  by (intro ord_spmf_bind_reflI) (simp add:case_prod_beta ord_spmf_map_spmf12)

definition use_coins :: "nat \<Rightarrow> 'a tspmf \<Rightarrow> 'a tspmf"
  where "use_coins k = map_spmf (apsnd ((+) k))"

lemma use_coins_add:
  "use_coins k (use_coins s f) = use_coins (k+s) f"
  unfolding use_coins_def spmf.map_comp
  by (simp add:comp_def apsnd_def map_prod_def case_prod_beta' algebra_simps)

lemma coin_tspmf_split:
  fixes f :: "bool \<Rightarrow> 'b tspmf"
  shows "(coin_tspmf \<bind> f) = use_coins 1 (coin_spmf \<bind> f)"
  unfolding coin_tspmf_def use_coins_def map_spmf_conv_bind_spmf pair_spmf_alt_def bind_tspmf_def
  by (simp)

lemma ord_tspmf_use_coins:
  "ord_tspmf (use_coins k p) p"
  unfolding use_coins_def by (intro ord_tspmf_map_spmf) auto

lemma ord_tspmf_use_coins_2:
  assumes "ord_tspmf p q"
  shows  "ord_tspmf (use_coins k p) (use_coins k q)"
  using assms unfolding use_coins_def ord_tspmf_def ord_spmf_map_spmf12 by auto

lemma result_mono:
  assumes "ord_tspmf p q"
  shows "ord_spmf (=) (result p) (result q)"
  using assms ord_spmf_mono unfolding result_def ord_tspmf_def ord_spmf_map_spmf12 by force

lemma result_bind:
  "result (bind_tspmf f g) = result f \<bind> (\<lambda>x. result (g x))"
  unfolding bind_tspmf_def result_def map_spmf_conv_bind_spmf by (simp add:case_prod_beta')

lemma result_return:
  "result (return_tspmf x) = return_spmf x"
  unfolding return_tspmf_def result_def map_spmf_conv_bind_spmf by (simp add:case_prod_beta')

lemma result_coin:
  "result (coin_tspmf) = coin_spmf"
  unfolding coin_tspmf_def result_def pair_spmf_alt_def map_spmf_conv_bind_spmf by (simp add:case_prod_beta')

definition tspmf_of_ra :: "'a random_alg \<Rightarrow> 'a tspmf" where
  "tspmf_of_ra = spmf_of_ra \<circ> track_coin_use"

lemma tspmf_of_ra_coin: "tspmf_of_ra coin_ra = coin_tspmf"
  unfolding tspmf_of_ra_def comp_def track_coin_use_coin coin_tra_def coin_tspmf_def
    spmf_of_ra_bind spmf_of_ra_coin spmf_of_ra_return pair_spmf_alt_def
  by simp

lemma tspmf_of_ra_return: "tspmf_of_ra (return_ra x) = return_tspmf x"
  unfolding tspmf_of_ra_def comp_def track_coin_use_return return_tra_def return_tspmf_def
     spmf_of_ra_return by simp

lemma tspmf_of_ra_bind:
  "tspmf_of_ra (bind_ra m f) = bind_tspmf (tspmf_of_ra m) (\<lambda>x. tspmf_of_ra (f x))"
  unfolding tspmf_of_ra_def comp_def track_coin_use_bind bind_tra_def bind_tspmf_def
    map_spmf_conv_bind_spmf
  by (simp add:case_prod_beta' spmf_of_ra_bind spmf_of_ra_return apsnd_def map_prod_def)

lemmas tspmf_of_ra_simps = tspmf_of_ra_bind tspmf_of_ra_return tspmf_of_ra_coin

lemma tspmf_of_ra_mono:
  assumes "ord_ra f g"
  shows "ord_spmf (=) (tspmf_of_ra f) (tspmf_of_ra g)"
  unfolding tspmf_of_ra_def comp_def
  by (intro spmf_of_ra_mono track_coin_use_mono assms)

lemma tspmf_of_ra_lub:
  assumes "Complete_Partial_Order.chain ord_ra A"
  shows "tspmf_of_ra (lub_ra A) = lub_spmf (tspmf_of_ra ` A)" (is "?L = ?R")
proof -
  have 0:"Complete_Partial_Order.chain ord_ra (track_coin_use ` A)"
    by (intro chain_imageI[OF assms] track_coin_use_mono)

  have "?L = spmf_of_ra (lub_ra (track_coin_use ` A))"
    unfolding tspmf_of_ra_def comp_def
    by (intro arg_cong[where f="spmf_of_ra"] track_coin_use_lub assms)
  also have "... = lub_spmf (spmf_of_ra ` track_coin_use ` A)"
    by (intro spmf_of_ra_lub_ra 0)
  also have "... = ?R"
    unfolding image_image tspmf_of_ra_def by simp
  finally show "?thesis" by simp
qed

definition rel_tspmf_of_ra :: "'a tspmf \<Rightarrow> 'a random_alg \<Rightarrow> bool" where
  "rel_tspmf_of_ra q p \<longleftrightarrow> q = tspmf_of_ra p"

lemma admissible_rel_tspmf_of_ra:
  "ccpo.admissible (prod_lub lub_spmf lub_ra) (rel_prod (ord_spmf (=)) ord_ra) (case_prod rel_tspmf_of_ra)"
  (is "ccpo.admissible ?lub ?ord ?P")
proof (rule ccpo.admissibleI)
  fix Y
  assume chain: "Complete_Partial_Order.chain ?ord Y"
    and Y: "Y \<noteq> {}"
    and R: "\<forall>(p, q) \<in> Y. rel_tspmf_of_ra p q"
  from R have R: "\<And>p q. (p, q) \<in> Y \<Longrightarrow> rel_tspmf_of_ra p q" by auto
  have chain1: "Complete_Partial_Order.chain (ord_spmf (=)) (fst ` Y)"
    and chain2: "Complete_Partial_Order.chain ord_ra (snd ` Y)"
    using chain by(rule chain_imageI; clarsimp)+
  from Y have Y1: "fst ` Y \<noteq> {}" and Y2: "snd ` Y \<noteq> {}" by auto

  have "lub_spmf (fst ` Y) = lub_spmf (tspmf_of_ra ` snd ` Y)"
    unfolding image_image using R
    by (intro arg_cong[of _ _ lub_spmf] image_cong) (auto simp: rel_tspmf_of_ra_def)
  also have "\<dots> = tspmf_of_ra (lub_ra (snd ` Y))"
    by (intro tspmf_of_ra_lub[symmetric] chain2)
  finally have "rel_tspmf_of_ra (lub_spmf (fst ` Y)) (lub_ra (snd ` Y))"
    unfolding rel_tspmf_of_ra_def .
  then show "?P (?lub Y)"
    by (simp add: prod_lub_def)
qed

lemma admissible_rel_tspmf_of_ra_cont [cont_intro]:
  fixes ord
  shows "\<lbrakk> mcont lub ord lub_spmf (ord_spmf (=)) f; mcont lub ord lub_ra ord_ra g \<rbrakk>
  \<Longrightarrow> ccpo.admissible lub ord (\<lambda>x. rel_tspmf_of_ra (f x) (g x))"
  by (rule admissible_subst[OF admissible_rel_tspmf_of_ra, where f="\<lambda>x. (f x, g x)", simplified])
     (rule mcont_Pair)

lemma mcont_tspmf_of_ra:
  "mcont lub_ra ord_ra lub_spmf (ord_spmf (=)) tspmf_of_ra"
  unfolding mcont_def monotone_def cont_def
  by (auto simp: tspmf_of_ra_mono tspmf_of_ra_lub)

lemmas mcont2mcont_tspmf_of_ra = mcont_tspmf_of_ra[THEN spmf.mcont2mcont]

context includes lifting_syntax
begin

lemma fixp_rel_tspmf_of_ra_parametric[transfer_rule]:
  assumes f: "\<And>x. mono_spmf (\<lambda>f. F f x)"
  and g: "\<And>x. mono_ra (\<lambda>f. G f x)"
  and param: "((A ===> rel_tspmf_of_ra) ===> A ===> rel_tspmf_of_ra) F G"
  shows "(A ===> rel_tspmf_of_ra) (spmf.fixp_fun F) (random_alg_pf.fixp_fun G)"
  using f g
proof(rule parallel_fixp_induct_1_1[OF
      partial_function_definitions_spmf random_alg_pfd _ _ reflexive reflexive,
        where P="(A ===> rel_tspmf_of_ra)"])
  show "ccpo.admissible (prod_lub (fun_lub lub_spmf) (fun_lub lub_ra))
        (rel_prod (fun_ord (ord_spmf (=))) (fun_ord ord_ra))
        (\<lambda>x. (A ===> rel_tspmf_of_ra) (fst x) (snd x))"
    unfolding rel_fun_def
    by(rule admissible_all admissible_imp cont_intro)+
  have 0:"tspmf_of_ra (lub_ra {}) = return_pmf None"
    using tspmf_of_ra_lub[where A="{}"]
    by (simp add:Complete_Partial_Order.chain_def)
  show "(A ===> rel_tspmf_of_ra) (\<lambda>_. lub_spmf {}) (\<lambda>_. lub_ra {})"
    by (auto simp: rel_fun_def rel_tspmf_of_ra_def 0)
  show "(A ===> rel_tspmf_of_ra) (F f) (G g)" if "(A ===> rel_tspmf_of_ra) f g" for f g
    using that by(rule rel_funD[OF param])
qed

lemma return_ra_tranfer[transfer_rule]: "((=) ===> rel_tspmf_of_ra) return_tspmf return_ra"
  unfolding rel_fun_def rel_tspmf_of_ra_def tspmf_of_ra_return by simp

lemma bind_ra_tranfer[transfer_rule]:
  "(rel_tspmf_of_ra ===> ((=) ===> rel_tspmf_of_ra) ===> rel_tspmf_of_ra) bind_tspmf bind_ra"
  unfolding rel_fun_def rel_tspmf_of_ra_def tspmf_of_ra_bind by simp presburger

lemma coin_ra_tranfer[transfer_rule]:
  "rel_tspmf_of_ra coin_tspmf coin_ra"
  unfolding rel_fun_def rel_tspmf_of_ra_def tspmf_of_ra_coin by simp

end

lemma spmf_of_tspmf:
  "result (tspmf_of_ra f) = spmf_of_ra f"
  unfolding tspmf_of_ra_def result_def
  by (simp add: untrack_coin_use spmf_of_ra_map[symmetric])

lemma coin_usage_of_tspmf_correct:
  "coin_usage_of_tspmf (tspmf_of_ra p) = coin_usage_of_ra p" (is "?L = ?R")
proof -
  let ?p = "Rep_random_alg p"

  have "measure_pmf (map_spmf snd (tspmf_of_ra p)) =
    distr (distr_rai (track_random_bits ?p)) \<D> (map_option snd)"
    unfolding tspmf_of_ra_def map_pmf_rep_eq spmf_of_ra.rep_eq comp_def track_coin_use.rep_eq
    by simp
  also have "... = distr \<B> \<D> (map_option snd \<circ> (map_option fst \<circ> track_random_bits ?p))"
    unfolding distr_rai_def
    by (intro distr_distr distr_rai_measurable wf_track_random_bits wf_rep_rand_alg) simp
  also have "... = distr \<B> \<D> (\<lambda>x. ?p x \<bind> (\<lambda>xa. consumed_bits ?p x))"
    unfolding track_random_bits_def by (simp add:comp_def map_option_bind case_prod_beta)
  also have "... = distr \<B> \<D> (\<lambda>x. consumed_bits ?p x)"
    by (intro arg_cong[where f="distr \<B> \<D>"] ext)
     (auto simp:consumed_bits_inf_iff[OF wf_rep_rand_alg] split:bind_split)
  also have "... = measure_pmf (coin_usage_of_ra_aux p)"
    unfolding coin_usage_of_ra_aux.rep_eq used_bits_distr_def by simp
  finally have "measure_pmf (map_spmf snd (tspmf_of_ra p)) = measure_pmf (coin_usage_of_ra_aux p)"
    by simp
  hence 0:"map_spmf snd (tspmf_of_ra p) = coin_usage_of_ra_aux p"
    using measure_pmf_inject by auto
  show ?thesis
    unfolding coin_usage_of_tspmf_def 0[symmetric] coin_usage_of_ra_def map_pmf_comp
    by (intro map_pmf_cong) (auto split:option.split)
qed

lemma expected_coin_usage_of_tspmf_correct:
  "expected_coin_usage_of_tspmf (tspmf_of_ra p) = expected_coin_usage_of_ra p"
  unfolding expected_coin_usage_of_tspmf_def coin_usage_of_tspmf_correct
    expected_coin_usage_of_ra_def by simp

end


(*  Title:      ZF/Constructible/Datatype_absolute.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Absoluteness Properties for Recursive Datatypes\<close>

theory Eclose_Absolute imports "ZF-Constructible.Formula" "ZF-Constructible.WF_absolute" begin

subsection\<open>The lfp of a continuous function can be expressed as a union\<close>

definition
  directed :: "i=>o" where
   "directed(A) == A\<noteq>0 & (\<forall>x\<in>A. \<forall>y\<in>A. x \<union> y \<in> A)"

definition
  contin :: "(i=>i) => o" where
   "contin(h) == (\<forall>A. directed(A) \<longrightarrow> h(\<Union>A) = (\<Union>X\<in>A. h(X)))"

lemma bnd_mono_iterates_subset: "[|bnd_mono(D, h); n \<in> nat|] ==> h^n (0) \<subseteq> D"
apply (induct_tac n)
 apply (simp_all add: bnd_mono_def, blast)
done

lemma bnd_mono_increasing [rule_format]:
     "[|i \<in> nat; j \<in> nat; bnd_mono(D,h)|] ==> i \<le> j \<longrightarrow> h^i(0) \<subseteq> h^j(0)"
apply (rule_tac m=i and n=j in diff_induct, simp_all)
apply (blast del: subsetI
             intro: bnd_mono_iterates_subset bnd_monoD2 [of concl: h])
done

lemma directed_iterates: "bnd_mono(D,h) ==> directed({h^n (0). n\<in>nat})"
apply (simp add: directed_def, clarify)
apply (rename_tac i j)
apply (rule_tac x="i \<union> j" in bexI)
apply (rule_tac i = i and j = j in Ord_linear_le)
apply (simp_all add: subset_Un_iff [THEN iffD1] le_imp_subset
                     subset_Un_iff2 [THEN iffD1])
apply (simp_all add: subset_Un_iff [THEN iff_sym] bnd_mono_increasing
                     subset_Un_iff2 [THEN iff_sym])
done

lemma contin_iterates_eq:
    "[|bnd_mono(D, h); contin(h)|]
     ==> h(\<Union>n\<in>nat. h^n (0)) = (\<Union>n\<in>nat. h^n (0))"
apply (simp add: contin_def directed_iterates)
apply (rule trans)
apply (rule equalityI)
 apply (simp_all add: UN_subset_iff)
 apply safe
 apply (erule_tac [2] natE)
  apply (rule_tac a="succ(x)" in UN_I)
   apply simp_all
apply blast
done

lemma lfp_subset_Union:
     "[|bnd_mono(D, h); contin(h)|] ==> lfp(D,h) \<subseteq> (\<Union>n\<in>nat. h^n(0))"
apply (rule lfp_lowerbound)
 apply (simp add: contin_iterates_eq)
apply (simp add: contin_def bnd_mono_iterates_subset UN_subset_iff)
done

lemma Union_subset_lfp:
     "bnd_mono(D,h) ==> (\<Union>n\<in>nat. h^n(0)) \<subseteq> lfp(D,h)"
apply (simp add: UN_subset_iff)
apply (rule ballI)
apply (induct_tac n, simp_all)
apply (rule subset_trans [of _ "h(lfp(D,h))"])
 apply (blast dest: bnd_monoD2 [OF _ _ lfp_subset])
apply (erule lfp_lemma2)
done

lemma lfp_eq_Union:
     "[|bnd_mono(D, h); contin(h)|] ==> lfp(D,h) = (\<Union>n\<in>nat. h^n(0))"
by (blast del: subsetI
          intro: lfp_subset_Union Union_subset_lfp)

subsubsection\<open>Some Standard Datatype Constructions Preserve Continuity\<close>

lemma contin_imp_mono: "[|X\<subseteq>Y; contin(F)|] ==> F(X) \<subseteq> F(Y)"
apply (simp add: contin_def)
apply (drule_tac x="{X,Y}" in spec)
apply (simp add: directed_def subset_Un_iff2 Un_commute)
done

lemma sum_contin: "[|contin(F); contin(G)|] ==> contin(\<lambda>X. F(X) + G(X))"
by (simp add: contin_def, blast)

lemma prod_contin: "[|contin(F); contin(G)|] ==> contin(\<lambda>X. F(X) * G(X))"
apply (subgoal_tac "\<forall>B C. F(B) \<subseteq> F(B \<union> C)")
 prefer 2 apply (simp add: Un_upper1 contin_imp_mono)
apply (subgoal_tac "\<forall>B C. G(C) \<subseteq> G(B \<union> C)")
 prefer 2 apply (simp add: Un_upper2 contin_imp_mono)
apply (simp add: contin_def, clarify)
apply (rule equalityI)
 prefer 2 apply blast
apply clarify
apply (rename_tac B C)
apply (rule_tac a="B \<union> C" in UN_I)
 apply (simp add: directed_def, blast)
done

lemma const_contin: "contin(\<lambda>X. A)"
by (simp add: contin_def directed_def)

lemma id_contin: "contin(\<lambda>X. X)"
by (simp add: contin_def)

subsection \<open>Absoluteness for "Iterates"\<close>

definition
  iterates_MH :: "[i=>o, [i,i]=>o, i, i, i, i] => o" where
   "iterates_MH(M,isF,v,n,g,z) ==
        is_nat_case(M, v, \<lambda>m u. \<exists>gm[M]. fun_apply(M,g,m,gm) & isF(gm,u),
                    n, z)"

definition
  is_iterates :: "[i=>o, [i,i]=>o, i, i, i] => o" where
    "is_iterates(M,isF,v,n,Z) ==
      \<exists>sn[M]. \<exists>msn[M]. successor(M,n,sn) & membership(M,sn,msn) &
                       is_wfrec(M, iterates_MH(M,isF,v), msn, n, Z)"

definition
  iterates_replacement :: "[i=>o, [i,i]=>o, i] => o" where
   "iterates_replacement(M,isF,v) ==
      \<forall>n[M]. n\<in>nat \<longrightarrow>
         wfrec_replacement(M, iterates_MH(M,isF,v), Memrel(succ(n)))"

lemma (in M_basic) iterates_MH_abs:
  "[| relation1(M,isF,F); M(n); M(g); M(z) |]
   ==> iterates_MH(M,isF,v,n,g,z) \<longleftrightarrow> z = nat_case(v, \<lambda>m. F(g`m), n)"
by (simp add: nat_case_abs [of _ "\<lambda>m. F(g ` m)"]
              relation1_def iterates_MH_def)

lemma (in M_trancl) iterates_imp_wfrec_replacement:
  "[|relation1(M,isF,F); n \<in> nat; iterates_replacement(M,isF,v)|]
   ==> wfrec_replacement(M, \<lambda>n f z. z = nat_case(v, \<lambda>m. F(f`m), n),
                       Memrel(succ(n)))"
by (simp add: iterates_replacement_def iterates_MH_abs)

theorem (in M_trancl) iterates_abs:
  "[| iterates_replacement(M,isF,v); relation1(M,isF,F);
      n \<in> nat; M(v); M(z); \<forall>x[M]. M(F(x)) |]
   ==> is_iterates(M,isF,v,n,z) \<longleftrightarrow> z = iterates(F,n,v)"
apply (frule iterates_imp_wfrec_replacement, assumption+)
apply (simp add: wf_Memrel trans_Memrel relation_Memrel
                 is_iterates_def relation2_def iterates_MH_abs
                 iterates_nat_def recursor_def transrec_def
                 eclose_sing_Ord_eq nat_into_M
         trans_wfrec_abs [of _ _ _ _ "\<lambda>n g. nat_case(v, \<lambda>m. F(g`m), n)"])
done

lemma (in M_trancl) iterates_closed [intro,simp]:
  "[| iterates_replacement(M,isF,v); relation1(M,isF,F);
      n \<in> nat; M(v); \<forall>x[M]. M(F(x)) |]
   ==> M(iterates(F,n,v))"
apply (frule iterates_imp_wfrec_replacement, assumption+)
apply (simp add: wf_Memrel trans_Memrel relation_Memrel
                 relation2_def iterates_MH_abs
                 iterates_nat_def recursor_def transrec_def
                 eclose_sing_Ord_eq nat_into_M
         trans_wfrec_closed [of _ _ _ "\<lambda>n g. nat_case(v, \<lambda>m. F(g`m), n)"])
done

subsection \<open>lists without univ\<close>

lemmas datatype_univs = Inl_in_univ Inr_in_univ
                        Pair_in_univ nat_into_univ A_into_univ

lemma list_fun_bnd_mono: "bnd_mono(univ(A), \<lambda>X. {0} + A*X)"
apply (rule bnd_monoI)
 apply (intro subset_refl zero_subset_univ A_subset_univ
              sum_subset_univ Sigma_subset_univ)
apply (rule subset_refl sum_mono Sigma_mono | assumption)+
done

lemma list_fun_contin: "contin(\<lambda>X. {0} + A*X)"
by (intro sum_contin prod_contin id_contin const_contin)

text\<open>Re-expresses lists using sum and product\<close>
lemma list_eq_lfp2: "list(A) = lfp(univ(A), \<lambda>X. {0} + A*X)"
apply (simp add: list_def)
apply (rule equalityI)
 apply (rule lfp_lowerbound)
  prefer 2 apply (rule lfp_subset)
 apply (clarify, subst lfp_unfold [OF list_fun_bnd_mono])
 apply (simp add: Nil_def Cons_def)
 apply blast
txt\<open>Opposite inclusion\<close>
apply (rule lfp_lowerbound)
 prefer 2 apply (rule lfp_subset)
apply (clarify, subst lfp_unfold [OF list.bnd_mono])
apply (simp add: Nil_def Cons_def)
apply (blast intro: datatype_univs
             dest: lfp_subset [THEN subsetD])
done

text\<open>Re-expresses lists using "iterates", no univ.\<close>
lemma list_eq_Union:
     "list(A) = (\<Union>n\<in>nat. (\<lambda>X. {0} + A*X) ^ n (0))"
by (simp add: list_eq_lfp2 lfp_eq_Union list_fun_bnd_mono list_fun_contin)

definition
  is_list_functor :: "[i=>o,i,i,i] => o" where
    "is_list_functor(M,A,X,Z) ==
        \<exists>n1[M]. \<exists>AX[M].
         number1(M,n1) & cartprod(M,A,X,AX) & is_sum(M,n1,AX,Z)"

lemma (in M_basic) list_functor_abs [simp]:
     "[| M(A); M(X); M(Z) |] ==> is_list_functor(M,A,X,Z) \<longleftrightarrow> (Z = {0} + A*X)"
by (simp add: is_list_functor_def singleton_0 nat_into_M)

subsection \<open>formulas without univ\<close>

lemma formula_fun_bnd_mono:
     "bnd_mono(univ(0), \<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X))"
apply (rule bnd_monoI)
 apply (intro subset_refl zero_subset_univ A_subset_univ
              sum_subset_univ Sigma_subset_univ nat_subset_univ)
apply (rule subset_refl sum_mono Sigma_mono | assumption)+
done

lemma formula_fun_contin:
     "contin(\<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X))"
by (intro sum_contin prod_contin id_contin const_contin)

text\<open>Re-expresses formulas using sum and product\<close>
lemma formula_eq_lfp2:
    "formula = lfp(univ(0), \<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X))"
apply (simp add: formula_def)
apply (rule equalityI)
 apply (rule lfp_lowerbound)
  prefer 2 apply (rule lfp_subset)
 apply (clarify, subst lfp_unfold [OF formula_fun_bnd_mono])
 apply (simp add: Member_def Equal_def Nand_def Forall_def)
 apply blast
txt\<open>Opposite inclusion\<close>
apply (rule lfp_lowerbound)
 prefer 2 apply (rule lfp_subset, clarify)
apply (subst lfp_unfold [OF formula.bnd_mono, simplified])
apply (simp add: Member_def Equal_def Nand_def Forall_def)
apply (elim sumE SigmaE, simp_all)
apply (blast intro: datatype_univs dest: lfp_subset [THEN subsetD])+
done

text\<open>Re-expresses formulas using "iterates", no univ.\<close>
lemma formula_eq_Union:
     "formula =
      (\<Union>n\<in>nat. (\<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X)) ^ n (0))"
by (simp add: formula_eq_lfp2 lfp_eq_Union formula_fun_bnd_mono
              formula_fun_contin)

definition
  is_formula_functor :: "[i=>o,i,i] => o" where
    "is_formula_functor(M,X,Z) ==
        \<exists>nat'[M]. \<exists>natnat[M]. \<exists>natnatsum[M]. \<exists>XX[M]. \<exists>X3[M].
          omega(M,nat') & cartprod(M,nat',nat',natnat) &
          is_sum(M,natnat,natnat,natnatsum) &
          cartprod(M,X,X,XX) & is_sum(M,XX,X,X3) &
          is_sum(M,natnatsum,X3,Z)"

lemma (in M_trancl) formula_functor_abs [simp]:
     "[| M(X); M(Z) |]
      ==> is_formula_functor(M,X,Z) \<longleftrightarrow>
          Z = ((nat*nat) + (nat*nat)) + (X*X + X)"
by (simp add: is_formula_functor_def)

subsection\<open>\<^term>\<open>M\<close> Contains the List and Formula Datatypes\<close>

definition
  list_N :: "[i,i] => i" where
    "list_N(A,n) == (\<lambda>X. {0} + A * X)^n (0)"

lemma Nil_in_list_N [simp]: "[] \<in> list_N(A,succ(n))"
by (simp add: list_N_def Nil_def)

lemma Cons_in_list_N [simp]:
     "Cons(a,l) \<in> list_N(A,succ(n)) \<longleftrightarrow> a\<in>A & l \<in> list_N(A,n)"
by (simp add: list_N_def Cons_def)

text\<open>These two aren't simprules because they reveal the underlying
list representation.\<close>
lemma list_N_0: "list_N(A,0) = 0"
by (simp add: list_N_def)

lemma list_N_succ: "list_N(A,succ(n)) = {0} + A * (list_N(A,n))"
by (simp add: list_N_def)

lemma list_N_imp_list:
  "[| l \<in> list_N(A,n); n \<in> nat |] ==> l \<in> list(A)"
by (force simp add: list_eq_Union list_N_def)

lemma list_N_imp_length_lt [rule_format]:
     "n \<in> nat ==> \<forall>l \<in> list_N(A,n). length(l) < n"
apply (induct_tac n)
apply (auto simp add: list_N_0 list_N_succ
                      Nil_def [symmetric] Cons_def [symmetric])
done

lemma list_imp_list_N [rule_format]:
     "l \<in> list(A) ==> \<forall>n\<in>nat. length(l) < n \<longrightarrow> l \<in> list_N(A, n)"
apply (induct_tac l)
apply (force elim: natE)+
done

lemma list_N_imp_eq_length:
      "[|n \<in> nat; l \<notin> list_N(A, n); l \<in> list_N(A, succ(n))|]
       ==> n = length(l)"
apply (rule le_anti_sym)
 prefer 2 apply (simp add: list_N_imp_length_lt)
apply (frule list_N_imp_list, simp)
apply (simp add: not_lt_iff_le [symmetric])
apply (blast intro: list_imp_list_N)
done

text\<open>Express \<^term>\<open>list_rec\<close> without using \<^term>\<open>rank\<close> or \<^term>\<open>Vset\<close>,
neither of which is absolute.\<close>
lemma (in M_trivial) list_rec_eq:
  "l \<in> list(A) ==>
   list_rec(a,g,l) =
   transrec (succ(length(l)),
      \<lambda>x h. Lambda (list(A),
                    list_case' (a,
                           \<lambda>a l. g(a, l, h ` succ(length(l)) ` l)))) ` l"
apply (induct_tac l)
apply (subst transrec, simp)
apply (subst transrec)
apply (simp add: list_imp_list_N)
done

definition
  is_list_N :: "[i=>o,i,i,i] => o" where
    "is_list_N(M,A,n,Z) ==
      \<exists>zero[M]. empty(M,zero) &
                is_iterates(M, is_list_functor(M,A), zero, n, Z)"

definition
  mem_list :: "[i=>o,i,i] => o" where
    "mem_list(M,A,l) ==
      \<exists>n[M]. \<exists>listn[M].
       finite_ordinal(M,n) & is_list_N(M,A,n,listn) & l \<in> listn"

definition
  is_list :: "[i=>o,i,i] => o" where
    "is_list(M,A,Z) == \<forall>l[M]. l \<in> Z \<longleftrightarrow> mem_list(M,A,l)"

subsubsection\<open>Towards Absoluteness of \<^term>\<open>formula_rec\<close>\<close>

consts   depth :: "i=>i"
primrec
  "depth(Member(x,y)) = 0"
  "depth(Equal(x,y))  = 0"
  "depth(Nand(p,q)) = succ(depth(p) \<union> depth(q))"
  "depth(Forall(p)) = succ(depth(p))"

lemma depth_type [TC]: "p \<in> formula ==> depth(p) \<in> nat"
by (induct_tac p, simp_all)

definition
  formula_N :: "i => i" where
    "formula_N(n) == (\<lambda>X. ((nat*nat) + (nat*nat)) + (X*X + X)) ^ n (0)"

lemma Member_in_formula_N [simp]:
     "Member(x,y) \<in> formula_N(succ(n)) \<longleftrightarrow> x \<in> nat & y \<in> nat"
by (simp add: formula_N_def Member_def)

lemma Equal_in_formula_N [simp]:
     "Equal(x,y) \<in> formula_N(succ(n)) \<longleftrightarrow> x \<in> nat & y \<in> nat"
by (simp add: formula_N_def Equal_def)

lemma Nand_in_formula_N [simp]:
     "Nand(x,y) \<in> formula_N(succ(n)) \<longleftrightarrow> x \<in> formula_N(n) & y \<in> formula_N(n)"
by (simp add: formula_N_def Nand_def)

lemma Forall_in_formula_N [simp]:
     "Forall(x) \<in> formula_N(succ(n)) \<longleftrightarrow> x \<in> formula_N(n)"
by (simp add: formula_N_def Forall_def)

text\<open>These two aren't simprules because they reveal the underlying
formula representation.\<close>
lemma formula_N_0: "formula_N(0) = 0"
by (simp add: formula_N_def)

lemma formula_N_succ:
     "formula_N(succ(n)) =
      ((nat*nat) + (nat*nat)) + (formula_N(n) * formula_N(n) + formula_N(n))"
by (simp add: formula_N_def)

lemma formula_N_imp_formula:
  "[| p \<in> formula_N(n); n \<in> nat |] ==> p \<in> formula"
by (force simp add: formula_eq_Union formula_N_def)

lemma formula_N_imp_depth_lt [rule_format]:
     "n \<in> nat ==> \<forall>p \<in> formula_N(n). depth(p) < n"
apply (induct_tac n)
apply (auto simp add: formula_N_0 formula_N_succ
                      depth_type formula_N_imp_formula Un_least_lt_iff
                      Member_def [symmetric] Equal_def [symmetric]
                      Nand_def [symmetric] Forall_def [symmetric])
done

lemma formula_imp_formula_N [rule_format]:
     "p \<in> formula ==> \<forall>n\<in>nat. depth(p) < n \<longrightarrow> p \<in> formula_N(n)"
apply (induct_tac p)
apply (simp_all add: succ_Un_distrib Un_least_lt_iff)
apply (force elim: natE)+
done

lemma formula_N_imp_eq_depth:
      "[|n \<in> nat; p \<notin> formula_N(n); p \<in> formula_N(succ(n))|]
       ==> n = depth(p)"
apply (rule le_anti_sym)
 prefer 2 apply (simp add: formula_N_imp_depth_lt)
apply (frule formula_N_imp_formula, simp)
apply (simp add: not_lt_iff_le [symmetric])
apply (blast intro: formula_imp_formula_N)
done

text\<open>This result and the next are unused.\<close>
lemma formula_N_mono [rule_format]:
  "[| m \<in> nat; n \<in> nat |] ==> m\<le>n \<longrightarrow> formula_N(m) \<subseteq> formula_N(n)"
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all add: formula_N_0 formula_N_succ, blast)
done

lemma formula_N_distrib:
  "[| m \<in> nat; n \<in> nat |] ==> formula_N(m \<union> n) = formula_N(m) \<union> formula_N(n)"
apply (rule_tac i = m and j = n in Ord_linear_le, auto)
apply (simp_all add: subset_Un_iff [THEN iffD1] subset_Un_iff2 [THEN iffD1]
                     le_imp_subset formula_N_mono)
done

definition
  is_formula_N :: "[i=>o,i,i] => o" where
    "is_formula_N(M,n,Z) ==
      \<exists>zero[M]. empty(M,zero) &
                is_iterates(M, is_formula_functor(M), zero, n, Z)"

definition
  mem_formula :: "[i=>o,i] => o" where
    "mem_formula(M,p) ==
      \<exists>n[M]. \<exists>formn[M].
       finite_ordinal(M,n) & is_formula_N(M,n,formn) & p \<in> formn"

definition
  is_formula :: "[i=>o,i] => o" where
    "is_formula(M,Z) == \<forall>p[M]. p \<in> Z \<longleftrightarrow> mem_formula(M,p)"

subsubsection\<open>Absoluteness of the List Construction\<close>

subsubsection\<open>Absoluteness of Formulas\<close>

subsection\<open>Absoluteness for \<open>\<epsilon>\<close>-Closure: the \<^term>\<open>eclose\<close> Operator\<close>

text\<open>Re-expresses eclose using "iterates"\<close>
lemma eclose_eq_Union:
     "eclose(A) = (\<Union>n\<in>nat. Union^n (A))"
apply (simp add: eclose_def)
apply (rule UN_cong)
apply (rule refl)
apply (induct_tac n)
apply (simp add: nat_rec_0)
apply (simp add: nat_rec_succ)
done

definition
  is_eclose_n :: "[i=>o,i,i,i] => o" where
    "is_eclose_n(M,A,n,Z) == is_iterates(M, big_union(M), A, n, Z)"

definition
  mem_eclose :: "[i=>o,i,i] => o" where
    "mem_eclose(M,A,l) ==
      \<exists>n[M]. \<exists>eclosen[M].
       finite_ordinal(M,n) & is_eclose_n(M,A,n,eclosen) & l \<in> eclosen"

definition
  is_eclose :: "[i=>o,i,i] => o" where
    "is_eclose(M,A,Z) == \<forall>u[M]. u \<in> Z \<longleftrightarrow> mem_eclose(M,A,u)"

locale M_eclose = M_trancl +
 assumes eclose_replacement1:
   "M(A) ==> iterates_replacement(M, big_union(M), A)"
  and eclose_replacement2:
   "M(A) ==> strong_replacement(M,
         \<lambda>n y. n\<in>nat & is_iterates(M, big_union(M), A, n, y))"

lemma (in M_eclose) eclose_replacement2':
  "M(A) ==> strong_replacement(M, \<lambda>n y. n\<in>nat & y = Union^n (A))"
apply (insert eclose_replacement2 [of A])
apply (rule strong_replacement_cong [THEN iffD1])
apply (rule conj_cong [OF iff_refl iterates_abs [of "big_union(M)"]])
apply (simp_all add: eclose_replacement1 relation1_def)
done

lemma (in M_eclose) eclose_closed [intro,simp]:
     "M(A) ==> M(eclose(A))"
apply (insert eclose_replacement1)
by  (simp add: RepFun_closed2 eclose_eq_Union
               eclose_replacement2' relation1_def
               iterates_closed [of "big_union(M)"])

lemma (in M_eclose) is_eclose_n_abs [simp]:
     "[|M(A); n\<in>nat; M(Z)|] ==> is_eclose_n(M,A,n,Z) \<longleftrightarrow> Z = Union^n (A)"
apply (insert eclose_replacement1)
apply (simp add: is_eclose_n_def relation1_def nat_into_M
                 iterates_abs [of "big_union(M)" _ "Union"])
done

lemma (in M_eclose) mem_eclose_abs [simp]:
     "M(A) ==> mem_eclose(M,A,l) \<longleftrightarrow> l \<in> eclose(A)"
apply (insert eclose_replacement1)
apply (simp add: mem_eclose_def relation1_def eclose_eq_Union
                 iterates_closed [of "big_union(M)"])
done

lemma (in M_eclose) eclose_abs [simp]:
     "[|M(A); M(Z)|] ==> is_eclose(M,A,Z) \<longleftrightarrow> Z = eclose(A)"
apply (simp add: is_eclose_def, safe)
apply (rule M_equalityI, simp_all)
done

subsection \<open>Absoluteness for \<^term>\<open>transrec\<close>\<close>

text\<open>\<^prop>\<open>transrec(a,H) \<equiv> wfrec(Memrel(eclose({a})), a, H)\<close>\<close>

definition
  is_transrec :: "[i=>o, [i,i,i]=>o, i, i] => o" where
   "is_transrec(M,MH,a,z) ==
      \<exists>sa[M]. \<exists>esa[M]. \<exists>mesa[M].
       upair(M,a,a,sa) & is_eclose(M,sa,esa) & membership(M,esa,mesa) &
       is_wfrec(M,MH,mesa,a,z)"

definition
  transrec_replacement :: "[i=>o, [i,i,i]=>o, i] => o" where
   "transrec_replacement(M,MH,a) ==
      \<exists>sa[M]. \<exists>esa[M]. \<exists>mesa[M].
       upair(M,a,a,sa) & is_eclose(M,sa,esa) & membership(M,esa,mesa) &
       wfrec_replacement(M,MH,mesa)"

text\<open>The condition \<^term>\<open>Ord(i)\<close> lets us use the simpler
  \<open>trans_wfrec_abs\<close> rather than \<open>trans_wfrec_abs\<close>,
  which I haven't even proved yet.\<close>
theorem (in M_eclose) transrec_abs:
  "[|transrec_replacement(M,MH,i);  relation2(M,MH,H);
     Ord(i);  M(i);  M(z);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> is_transrec(M,MH,i,z) \<longleftrightarrow> z = transrec(i,H)"
by (simp add: trans_wfrec_abs transrec_replacement_def is_transrec_def
       transrec_def eclose_sing_Ord_eq wf_Memrel trans_Memrel relation_Memrel)

theorem (in M_eclose) transrec_closed:
     "[|transrec_replacement(M,MH,i);  relation2(M,MH,H);
        Ord(i);  M(i);
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
      ==> M(transrec(i,H))"
by (simp add: trans_wfrec_closed transrec_replacement_def is_transrec_def
        transrec_def eclose_sing_Ord_eq wf_Memrel trans_Memrel relation_Memrel)

text\<open>Helps to prove instances of \<^term>\<open>transrec_replacement\<close>\<close>
lemma (in M_eclose) transrec_replacementI:
   "[|M(a);
      strong_replacement (M,
                  \<lambda>x z. \<exists>y[M]. pair(M, x, y, z) &
                               is_wfrec(M,MH,Memrel(eclose({a})),x,y))|]
    ==> transrec_replacement(M,MH,a)"
by (simp add: transrec_replacement_def wfrec_replacement_def)

subsection\<open>Absoluteness for the List Operator \<^term>\<open>length\<close>\<close>
text\<open>But it is never used.\<close>

definition
  is_length :: "[i=>o,i,i,i] => o" where
    "is_length(M,A,l,n) ==
       \<exists>sn[M]. \<exists>list_n[M]. \<exists>list_sn[M].
        is_list_N(M,A,n,list_n) & l \<notin> list_n &
        successor(M,n,sn) & is_list_N(M,A,sn,list_sn) & l \<in> list_sn"

text\<open>Proof is trivial since \<^term>\<open>length\<close> returns natural numbers.\<close>
lemma (in M_trivial) length_closed [intro,simp]:
     "l \<in> list(A) ==> M(length(l))"
by (simp add: nat_into_M)

subsection \<open>Absoluteness for the List Operator \<^term>\<open>nth\<close>\<close>

lemma nth_eq_hd_iterates_tl [rule_format]:
     "xs \<in> list(A) ==> \<forall>n \<in> nat. nth(n,xs) = hd' (tl'^n (xs))"
apply (induct_tac xs)
apply (simp add: iterates_tl_Nil hd'_Nil, clarify)
apply (erule natE)
apply (simp add: hd'_Cons)
apply (simp add: tl'_Cons iterates_commute)
done

lemma (in M_basic) iterates_tl'_closed:
     "[|n \<in> nat; M(x)|] ==> M(tl'^n (x))"
apply (induct_tac n, simp)
apply (simp add: tl'_Cons tl'_closed)
done

text\<open>Immediate by type-checking\<close>
lemma (in M_trancl) nth_closed [intro,simp]:
     "[|xs \<in> list(A); n \<in> nat; M(A)|] ==> M(nth(n,xs))"
apply (case_tac "n < length(xs)")
 apply (blast intro: nth_type transM)
apply (simp add: not_lt_iff_le nth_eq_0)
done

subsection\<open>Relativization and Absoluteness for the \<^term>\<open>formula\<close> Constructors\<close>

definition
  is_Member :: "[i=>o,i,i,i] => o" where
     \<comment> \<open>because \<^term>\<open>Member(x,y) \<equiv> Inl(Inl(\<langle>x,y\<rangle>))\<close>\<close>
    "is_Member(M,x,y,Z) ==
        \<exists>p[M]. \<exists>u[M]. pair(M,x,y,p) & is_Inl(M,p,u) & is_Inl(M,u,Z)"

lemma (in M_trivial) Member_abs [simp]:
     "[|M(x); M(y); M(Z)|] ==> is_Member(M,x,y,Z) \<longleftrightarrow> (Z = Member(x,y))"
by (simp add: is_Member_def Member_def)

lemma (in M_trivial) Member_in_M_iff [iff]:
     "M(Member(x,y)) \<longleftrightarrow> M(x) & M(y)"
by (simp add: Member_def)

definition
  is_Equal :: "[i=>o,i,i,i] => o" where
     \<comment> \<open>because \<^term>\<open>Equal(x,y) \<equiv> Inl(Inr(\<langle>x,y\<rangle>))\<close>\<close>
    "is_Equal(M,x,y,Z) ==
        \<exists>p[M]. \<exists>u[M]. pair(M,x,y,p) & is_Inr(M,p,u) & is_Inl(M,u,Z)"

lemma (in M_trivial) Equal_abs [simp]:
     "[|M(x); M(y); M(Z)|] ==> is_Equal(M,x,y,Z) \<longleftrightarrow> (Z = Equal(x,y))"
by (simp add: is_Equal_def Equal_def)

lemma (in M_trivial) Equal_in_M_iff [iff]: "M(Equal(x,y)) \<longleftrightarrow> M(x) & M(y)"
by (simp add: Equal_def)

definition
  is_Nand :: "[i=>o,i,i,i] => o" where
     \<comment> \<open>because \<^term>\<open>Nand(x,y) \<equiv> Inr(Inl(\<langle>x,y\<rangle>))\<close>\<close>
    "is_Nand(M,x,y,Z) ==
        \<exists>p[M]. \<exists>u[M]. pair(M,x,y,p) & is_Inl(M,p,u) & is_Inr(M,u,Z)"

lemma (in M_trivial) Nand_abs [simp]:
     "[|M(x); M(y); M(Z)|] ==> is_Nand(M,x,y,Z) \<longleftrightarrow> (Z = Nand(x,y))"
by (simp add: is_Nand_def Nand_def)

lemma (in M_trivial) Nand_in_M_iff [iff]: "M(Nand(x,y)) \<longleftrightarrow> M(x) & M(y)"
by (simp add: Nand_def)

definition
  is_Forall :: "[i=>o,i,i] => o" where
     \<comment> \<open>because \<^term>\<open>Forall(x) \<equiv> Inr(Inr(p))\<close>\<close>
    "is_Forall(M,p,Z) == \<exists>u[M]. is_Inr(M,p,u) & is_Inr(M,u,Z)"

lemma (in M_trivial) Forall_abs [simp]:
     "[|M(x); M(Z)|] ==> is_Forall(M,x,Z) \<longleftrightarrow> (Z = Forall(x))"
by (simp add: is_Forall_def Forall_def)

lemma (in M_trivial) Forall_in_M_iff [iff]: "M(Forall(x)) \<longleftrightarrow> M(x)"
by (simp add: Forall_def)

subsection \<open>Absoluteness for \<^term>\<open>formula_rec\<close>\<close>

definition
  formula_rec_case :: "[[i,i]=>i, [i,i]=>i, [i,i,i,i]=>i, [i,i]=>i, i, i] => i" where
    \<comment> \<open>the instance of \<^term>\<open>formula_case\<close> in \<^term>\<open>formula_rec\<close>\<close>
   "formula_rec_case(a,b,c,d,h) ==
        formula_case (a, b,
                \<lambda>u v. c(u, v, h ` succ(depth(u)) ` u,
                              h ` succ(depth(v)) ` v),
                \<lambda>u. d(u, h ` succ(depth(u)) ` u))"

text\<open>Unfold \<^term>\<open>formula_rec\<close> to \<^term>\<open>formula_rec_case\<close>.
     Express \<^term>\<open>formula_rec\<close> without using \<^term>\<open>rank\<close> or \<^term>\<open>Vset\<close>,
neither of which is absolute.\<close>
lemma (in M_trivial) formula_rec_eq:
  "p \<in> formula ==>
   formula_rec(a,b,c,d,p) =
   transrec (succ(depth(p)),
             \<lambda>x h. Lambda (formula, formula_rec_case(a,b,c,d,h))) ` p"
apply (simp add: formula_rec_case_def)
apply (induct_tac p)
   txt\<open>Base case for \<^term>\<open>Member\<close>\<close>
   apply (subst transrec, simp add: formula.intros)
  txt\<open>Base case for \<^term>\<open>Equal\<close>\<close>
  apply (subst transrec, simp add: formula.intros)
 txt\<open>Inductive step for \<^term>\<open>Nand\<close>\<close>
 apply (subst transrec)
 apply (simp add: succ_Un_distrib formula.intros)
txt\<open>Inductive step for \<^term>\<open>Forall\<close>\<close>
apply (subst transrec)
apply (simp add: formula_imp_formula_N formula.intros)
done

subsubsection\<open>Absoluteness for the Formula Operator \<^term>\<open>depth\<close>\<close>

definition
  is_depth :: "[i=>o,i,i] => o" where
    "is_depth(M,p,n) ==
       \<exists>sn[M]. \<exists>formula_n[M]. \<exists>formula_sn[M].
        is_formula_N(M,n,formula_n) & p \<notin> formula_n &
        successor(M,n,sn) & is_formula_N(M,sn,formula_sn) & p \<in> formula_sn"

text\<open>Proof is trivial since \<^term>\<open>depth\<close> returns natural numbers.\<close>
lemma (in M_trivial) depth_closed [intro,simp]:
     "p \<in> formula ==> M(depth(p))"
by (simp add: nat_into_M)

end