(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

section "Reasoning about PreFormulas"

theory PreFormulas
imports Semantics
begin

text\<open>
  Semantic separation of formulas and pre-formulas requires a deep embedding.
  We introduce a syntactically distinct notion of validity, written \<open>|~ A\<close>,
  for pre-formulas. Although it is semantically identical to \<open>\<turnstile> A\<close>, it
  helps users distinguish pre-formulas from formulas in \tlastar{} proofs.
\<close>

definition PreValid :: "('w::world) form \<Rightarrow> bool"
where "PreValid A \<equiv> \<forall> w. w \<Turnstile> A"

syntax
  "_PreValid"      :: "lift \<Rightarrow> bool"     ("(|~ _)" 5)

translations
  "_PreValid"  \<rightleftharpoons> "CONST PreValid"

lemma prefI[intro!]: "(\<And> w. w \<Turnstile> A) \<Longrightarrow> |~ A"
  by (simp add: PreValid_def)

method_setup pref_unlift = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD'
    (resolve_tac ctxt @{thms prefI} THEN' rewrite_goal_tac ctxt @{thms intensional_rews}))
\<close> "int_unlift for PreFormulas"

lemma prefeq_reflection: assumes P1: "|~ x=y" shows  "(x \<equiv> y)"
using P1 by (intro eq_reflection) force

lemma pref_True[simp]: "|~ #True"
  by auto

lemma pref_eq: "|~ X = Y \<Longrightarrow> X = Y"
  by (auto simp: prefeq_reflection)

lemma pref_iffI:
  assumes "|~ F \<longrightarrow> G" and "|~ G \<longrightarrow> F"
  shows "|~ F = G"
  using assms by force

lemma pref_iffD1: assumes "|~ F = G" shows "|~ F \<longrightarrow> G"
  using assms by auto

lemma pref_iffD2: assumes "|~ F = G" shows "|~ G \<longrightarrow> F"
  using assms by auto

lemma unl_pref_imp:
  assumes "|~ F \<longrightarrow> G" shows "\<And> w. w \<Turnstile> F \<Longrightarrow> w \<Turnstile> G"
  using assms by auto

lemma pref_imp_trans:
  assumes "|~ F \<longrightarrow> G" and "|~ G \<longrightarrow> H"
  shows "|~ F \<longrightarrow> H"
  using assms by force

subsection "Lemmas about \<open>Unchanged\<close>"

text \<open>
  Many of the \tlastar{} axioms only require a state function witness
  which leaves the state space unchanged. An obvious witness is the
  @{term id} function. The lemmas require that the given formula is
  invariant under stuttering.
\<close>

lemma pre_id_unch: assumes h: "stutinv F"
  shows "|~ F \<and> Unchanged id \<longrightarrow> \<circle>F"
proof (pref_unlift, clarify)
  fix s
  assume a1: "s \<Turnstile> F" and  a2: "s \<Turnstile> Unchanged id"
  from a2 have "(id (second s) = id (first s))" by (simp add: unch_defs)
  hence "s \<approx> (tail s)" by (simp add: addfirststut)
  with h a1 have "(tail s) \<Turnstile> F" by (simp add: stutinv_def)
  thus "s \<Turnstile> \<circle>F" by (unfold nexts_def)
qed

lemma pre_ex_unch:
  assumes h: "stutinv F"
  shows "\<exists>(v::'a::world \<Rightarrow> 'a). ( |~ F \<and> Unchanged v \<longrightarrow> \<circle>F)"
using pre_id_unch[OF h] by blast

lemma unch_pair: "|~ Unchanged (x,y) = (Unchanged x \<and> Unchanged y)"
  by (auto simp: unch_def before_def after_def nexts_def)

lemmas unch_eq1 = unch_pair[THEN pref_eq]
lemmas unch_eq2 = unch_pair[THEN prefeq_reflection]

lemma angle_actrans_sem: "|~ \<langle>F\<rangle>_v = (F \<and> v$ \<noteq> $v)"
  by (auto simp: angle_actrans_def actrans_def unch_def)

lemmas angle_actrans_sem_eq = angle_actrans_sem[THEN pref_eq]

subsection "Lemmas about \<open>after\<close>"

lemma after_const: "|~ (#c)` = #c"
  by (auto simp: nexts_def before_def after_def)

lemma after_fun1: "|~ f<x>` = f<x`>"
  by (auto simp: nexts_def before_def after_def)

lemma after_fun2: "|~ f<x,y>` = f <x`,y`>"
  by (auto simp: nexts_def before_def after_def)

lemma after_fun3: "|~ f<x,y,z>` = f <x`,y`,z`>"
  by (auto simp: nexts_def before_def after_def)

lemma after_fun4: "|~ f<x,y,z,zz>` = f <x`,y`,z`,zz`>"
  by (auto simp: nexts_def before_def after_def)

lemma after_forall: "|~ (\<forall> x. P x)` = (\<forall> x. (P x)`)"
  by (auto simp: nexts_def before_def after_def)

lemma after_exists: "|~ (\<exists> x. P x)` = (\<exists> x. (P x)`)"
  by (auto simp: nexts_def before_def after_def)

lemma after_exists1: "|~ (\<exists>! x. P x)` = (\<exists>! x. (P x)`)"
  by (auto simp: nexts_def before_def after_def)

lemmas all_after = after_const after_fun1 after_fun2 after_fun3 after_fun4
  after_forall after_exists after_exists1

lemmas all_after_unl = all_after[THEN prefD]
lemmas all_after_eq = all_after[THEN prefeq_reflection]

subsection "Lemmas about \<open>before\<close>"

lemma before_const: "\<turnstile> $(#c) = #c"
  by (auto simp: before_def)

lemma before_fun1: "\<turnstile> $(f<x>) = f <$x>"
  by (auto simp: before_def)

lemma before_fun2: "\<turnstile> $(f<x,y>) = f <$x,$y>"
  by (auto simp: before_def)

lemma before_fun3: "\<turnstile> $(f<x,y,z>) = f <$x,$y,$z>"
  by (auto simp: before_def)

lemma before_fun4: "\<turnstile> $(f<x,y,z,zz>) = f <$x,$y,$z,$zz>"
  by (auto simp: before_def)

lemma before_forall: "\<turnstile> $(\<forall> x. P x) = (\<forall> x. $(P x))"
  by (auto simp: before_def)

lemma before_exists: "\<turnstile> $(\<exists> x. P x) = (\<exists> x. $(P x))"
  by (auto simp: before_def)

lemma before_exists1: "\<turnstile> $(\<exists>! x. P x) = (\<exists>! x. $(P x))"
  by (auto simp: before_def)

lemmas all_before = before_const before_fun1 before_fun2 before_fun3 before_fun4
  before_forall before_exists before_exists1

lemmas all_before_unl = all_before[THEN intD]
lemmas all_before_eq = all_before[THEN inteq_reflection]

subsection "Some general properties"

lemma angle_actrans_conj: "|~ (\<langle>F \<and> G\<rangle>_v) = (\<langle>F\<rangle>_v \<and> \<langle>G\<rangle>_v)"
  by (auto simp: angle_actrans_def actrans_def unch_def)

lemma angle_actrans_disj: "|~ (\<langle>F \<or> G\<rangle>_v) = (\<langle>F\<rangle>_v \<or> \<langle>G\<rangle>_v)"
  by (auto simp: angle_actrans_def actrans_def unch_def)

lemma int_eq_true: "\<turnstile> P \<Longrightarrow> \<turnstile> P = #True"
  by auto

lemma pref_eq_true: "|~ P \<Longrightarrow> |~ P = #True"
  by auto

subsection "Unlifting attributes and methods"

text \<open>Attribute which unlifts an intensional formula or preformula\<close>
ML \<open>
fun unl_rewr ctxt thm =
    let
       val unl = (thm RS @{thm intD}) handle THM _ => (thm RS @{thm prefD})
                                      handle THM _ => thm
       val rewr = rewrite_rule ctxt @{thms intensional_rews}
     in
       unl |> rewr
     end;
\<close>
attribute_setup unlifted = \<open>
  Scan.succeed (Thm.rule_attribute [] (unl_rewr o Context.proof_of))
\<close> "unlift intensional formulas"

attribute_setup unlift_rule = \<open>
  Scan.succeed
    (Thm.rule_attribute []
      (Context.proof_of #> (fn ctxt => Object_Logic.rulify ctxt o unl_rewr ctxt)))
\<close> "unlift and rulify intensional formulas"

text \<open>
  Attribute which turns an intensional formula or preformula into a rewrite rule.
  Formulas \<open>F\<close> that are not equalities are turned into \<open>F \<equiv> #True\<close>.
\<close>
ML \<open>
fun int_rewr thm =
   (thm RS @{thm inteq_reflection})
     handle THM _ => (thm RS @{thm prefeq_reflection})
     handle THM _ => ((thm RS @{thm int_eq_true}) RS @{thm inteq_reflection})
     handle THM _ => ((thm RS @{thm pref_eq_true}) RS @{thm prefeq_reflection});
\<close>

attribute_setup simp_unl = \<open>
    Attrib.add_del
      (Thm.declaration_attribute
        (fn th => Simplifier.map_ss (Simplifier.add_simp (int_rewr th))))
      (K (NONE, NONE))  (* note only adding -- removing is ignored *)
\<close> "add thm unlifted from rewrites from intensional formulas or preformulas"

attribute_setup int_rewrite = \<open>Scan.succeed (Thm.rule_attribute [] (fn _ => int_rewr))\<close>
  "produce rewrites from intensional formulas or preformulas"

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_escape_NoSpecial
  imports "../../Test_Base"
begin

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

datatype Token = A | B | C | D | ESC | P | Q | R

fun isSpecial :: "Token => bool" where
  "isSpecial x =
   (case x of
      ESC => True
      | P => True
      | Q => True
      | R => True
      | other => False)"

fun ok :: "Token => bool" where
  "ok x =
   ((~ (isSpecial x)) |
      (case x of
        ESC => True
        | other => False))"

fun formula :: "Token list => bool" where
  "formula (nil2) = True"
| "formula (cons2 y xs) = ((ok y) & (formula xs))"

fun code :: "Token => Token" where
  "code x =
   (case x of
      ESC => ESC
      | P => A
      | Q => B
      | R => C
      | other => x)"

fun escape :: "Token list => Token list" where
  "escape (nil2) = nil2"
| "escape (cons2 y xs) =
     (if isSpecial y then cons2 ESC (cons2 (code y) (escape xs)) else
        cons2 y (escape xs))"

theorem property0 :
  "formula (escape xs)"
  oops

end


section \<open>Chain-Complete Partial Orders\<close>

theory CCPO_Extensions
imports
  "HOL-Library.Complete_Partial_Order2"
  ENat_Extensions
  Set_Extensions
begin

  lemma chain_split[dest]:
    assumes "Complete_Partial_Order.chain ord C" "x \<in> C"
    shows "C = {y \<in> C. ord x y} \<union> {y \<in> C. ord y x}"
  proof -
    have 1: "\<And> y. y \<in> C \<Longrightarrow> ord x y \<or> ord y x" using chainD assms by this
    show ?thesis using 1 by blast
  qed

  lemma infinite_chain_below[dest]:
    assumes "Complete_Partial_Order.chain ord C" "infinite C" "x \<in> C"
    assumes "finite {y \<in> C. ord x y}"
    shows "infinite {y \<in> C. ord y x}"
  proof -
    have 1: "C = {y \<in> C. ord x y} \<union> {y \<in> C. ord y x}" using assms(1, 3) by rule
    show ?thesis using finite_Un assms(2, 4) 1 by (metis (poly_guards_query))
  qed
  lemma infinite_chain_above[dest]:
    assumes "Complete_Partial_Order.chain ord C" "infinite C" "x \<in> C"
    assumes "finite {y \<in> C. ord y x}"
    shows "infinite {y \<in> C. ord x y}"
  proof -
    have 1: "C = {y \<in> C. ord x y} \<union> {y \<in> C. ord y x}" using assms(1, 3) by rule
    show ?thesis using finite_Un assms(2, 4) 1 by (metis (poly_guards_query))
  qed

  lemma (in ccpo) ccpo_Sup_upper_inv:
    assumes "Complete_Partial_Order.chain less_eq C" "x > \<Squnion> C"
    shows "x \<notin> C"
    using assms ccpo_Sup_upper by fastforce
  lemma (in ccpo) ccpo_Sup_least_inv:
    assumes "Complete_Partial_Order.chain less_eq C" "\<Squnion> C > x"
    obtains y
    where "y \<in> C" "\<not> y \<le> x"
    using assms ccpo_Sup_least that by fastforce

  lemma ccpo_Sup_least_inv':
    fixes C :: "'a :: {ccpo, linorder} set"
    assumes "Complete_Partial_Order.chain less_eq C" "\<Squnion> C > x"
    obtains y
    where "y \<in> C" "y > x"
  proof -
    obtain y where 1: "y \<in> C" "\<not> y \<le> x" using ccpo_Sup_least_inv assms by this
    show ?thesis using that 1 by simp
  qed

  lemma mcont2mcont_lessThan[THEN lfp.mcont2mcont, simp, cont_intro]:
    shows mcont_lessThan: "mcont Sup less_eq Sup less_eq
      (lessThan :: 'a :: {ccpo, linorder} \<Rightarrow> 'a set)"
  proof
    show "monotone less_eq less_eq (lessThan :: 'a \<Rightarrow> 'a set)" by (rule, auto)
    show "cont Sup less_eq Sup less_eq (lessThan :: 'a \<Rightarrow> 'a set)"
    proof
      fix C :: "'a set"
      assume 1: "Complete_Partial_Order.chain less_eq C"
      show "{..< \<Squnion> C} = \<Union> (lessThan ` C)"
      proof (intro equalityI subsetI)
        fix A
        assume 2: "A \<in> {..< \<Squnion> C}"
        obtain B where 3: "B \<in> C" "B > A" using ccpo_Sup_least_inv' 1 2 by blast
        show "A \<in> \<Union> (lessThan ` C)" using 3 by auto
      next
        fix A
        assume 2: "A \<in> \<Union> (lessThan ` C)"
        show "A \<in> {..< \<Squnion> C}" using ccpo_Sup_upper 2 by force
      qed
    qed
  qed

  class esize =
    fixes esize :: "'a \<Rightarrow> enat"

  class esize_order = esize + order +
    assumes esize_finite[dest]: "esize x \<noteq> \<infinity> \<Longrightarrow> finite {y. y \<le> x}"
    assumes esize_mono[intro]: "x \<le> y \<Longrightarrow> esize x \<le> esize y"
    assumes esize_strict_mono[intro]: "esize x \<noteq> \<infinity> \<Longrightarrow> x < y \<Longrightarrow> esize x < esize y"
  begin

    lemma infinite_chain_eSuc_esize[dest]:
      assumes "Complete_Partial_Order.chain less_eq C" "infinite C" "x \<in> C"
      obtains y
      where "y \<in> C" "esize y \<ge> eSuc (esize x)"
    proof (cases "esize x")
      case (enat k)
      have 1: "finite {y \<in> C. y \<le> x}" using esize_finite enat by simp
      have 2: "infinite {y \<in> C. y \<ge> x}" using assms 1 by rule
      have 3: "{y \<in> C. y > x} = {y \<in> C. y \<ge> x} - {x}" by auto
      have 4: "infinite {y \<in> C. y > x}" using 2 unfolding 3 by simp
      obtain y where 5: "y \<in> C" "y > x" using 4 by auto
      have 6: "esize y > esize x" using esize_strict_mono enat 5(2) by blast
      show ?thesis using that 5(1) 6 ileI1 by simp
    next
      case (infinity)
      show ?thesis using that infinity assms(3) by simp
    qed

    lemma infinite_chain_arbitrary_esize[dest]:
      assumes "Complete_Partial_Order.chain less_eq C" "infinite C"
      obtains x
      where "x \<in> C" "esize x \<ge> enat n"
    proof (induct n arbitrary: thesis)
      case 0
      show ?case using assms(2) 0 by force
    next
      case (Suc n)
      obtain x where 1: "x \<in> C" "esize x \<ge> enat n" using Suc(1) by blast
      obtain y where 2: "y \<in> C" "esize y \<ge> eSuc (esize x)" using assms 1(1) by rule
      show ?case using gfp.leq_trans Suc(2) 1(2) 2 by fastforce
    qed

  end

  class esize_ccpo = esize_order + ccpo
  begin

    lemma esize_cont[dest]:
      assumes "Complete_Partial_Order.chain less_eq C" "C \<noteq> {}"
      shows "esize (\<Squnion> C) = \<Squnion> (esize ` C)"
    proof (cases "finite C")
      case False
      have 1: "esize (\<Squnion> C) = \<infinity>"
      proof
        fix n
        obtain A where 1: "A \<in> C" "esize A \<ge> enat n" using assms(1) False by rule
        have 2: "A \<le> \<Squnion> C" using ccpo_Sup_upper assms(1) 1(1) by this
        have "enat n \<le> esize A" using 1(2) by this
        also have "\<dots> \<le> esize (\<Squnion> C)" using 2 by rule
        finally show "enat n \<le> esize (\<Squnion> C)" by this
      qed
      have 2: "(\<Squnion> A \<in> C. esize A) = \<infinity>"
      proof
        fix n
        obtain A where 1: "A \<in> C" "esize A \<ge> enat n" using assms(1) False by rule
        show "enat n \<le> (\<Squnion> A \<in> C. esize A)" using SUP_upper2 1 by this
      qed
      show ?thesis using 1 2 by simp
    next
      case True
      have 1: "esize (\<Squnion> C) = (\<Squnion> x \<in> C. esize x)"
      proof (intro order_class.antisym SUP_upper SUP_least esize_mono)
        show "\<Squnion> C \<in> C" using in_chain_finite assms(1) True assms(2) by this
        show "\<And> x. x \<in> C \<Longrightarrow> x \<le> \<Squnion> C" using ccpo_Sup_upper assms(1) by this
      qed
      show ?thesis using 1 by simp
    qed

    lemma esize_mcont: "mcont Sup less_eq Sup less_eq esize"
      by (blast intro: mcontI monotoneI contI)

    lemmas mcont2mcont_esize = esize_mcont[THEN lfp.mcont2mcont, simp, cont_intro]

  end

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_08
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

theorem property0 :
  "((drop x (drop y z)) = (drop y (drop x z)))"
  oops

end


theory KPair
  imports UPair SetRel
begin

context GZF begin

subsection \<open>Kuratowski ordered pairs\<close>

definition kpair :: "['a,'a] \<Rightarrow> 'a" where
  "kpair a b \<equiv> {{a,b},{a,a}}"

definition is_kpair :: \<open>'a \<Rightarrow> bool\<close>
  where "is_kpair p \<equiv> p : SetOf Set \<and> (\<exists>a b. p = kpair a b)"

lemma kpair_typ_setof : "kpair : SetMem \<rightarrow> SetMem \<rightarrow> SetOf Set" unfolding kpair_def
  by (rule funI, rule funI, rule upair_setof[OF upair_set upair_set])

lemmas kpair_setof [typ_intro] = funE[OF funE[OF kpair_typ_setof]]

lemma is_kpairI :
  assumes "b : SetMem" "c : SetMem"
  shows "kpair b c : is_kpair"
  using kpair_setof assms
  unfolding is_kpair_def has_ty_def by auto

lemma is_kpairE :
  assumes "p : is_kpair"
  obtains b c where
    "b : SetMem" "c : SetMem" "p = kpair b c"
proof -
  from assms obtain b c where
    "p : SetOf Set" and p_eq:"p = kpair b c"
    unfolding is_kpair_def has_ty_def by blast
  hence bb:"{b,b} : SetMem" and bc:"{b,c} : SetMem"
    using upair_set_setmem[OF setof_set] unfolding kpair_def by auto
  hence "{b,c} : Set"
    using setof_mem[OF \<open>p : SetOf Set\<close>]
          upairI1[OF bc bb]
    unfolding \<open>p = kpair b c\<close> kpair_def by auto
  hence "b : SetMem" "c : SetMem" "p = kpair b c"
    using upair_set_setmem p_eq by auto
  thus ?thesis ..
qed

lemma kpair_iff :
  assumes "a : SetMem" "b : SetMem" "c : SetMem" "d : SetMem"
  shows "kpair a b = kpair c d \<longleftrightarrow> a = c \<and> b = d"
proof -
  have "upair a b : SetMem" "upair a a : SetMem" "upair c d : SetMem" "upair c c : SetMem"
    using set_setmem[OF upair_set] assms by auto
  thus ?thesis unfolding kpair_def using upair_eq_iff assms by fastforce
qed

lemma is_kpairD :
  assumes "kpair b c : is_kpair"
  shows "b : SetMem \<and> c : SetMem"
proof
  from assms have
    kp:"kpair b c : SetOf Set"
    unfolding is_kpair_def has_ty_def by blast
  hence bb:"{b,b} : SetMem" and bc:"{b,c} : SetMem"
    using upair_set_setmem[OF setof_set] unfolding kpair_def by auto
  hence "{b,c} : Set" using setof_mem[OF kp] upairI1[OF bc bb]
    unfolding kpair_def by auto
  thus "b : SetMem" "c : SetMem"
    using upair_set_setmem by auto
qed

theorem GZF_OPair :
  "class.OPair is_kpair kpair SetMem"
proof
  show "kpair : SetMem \<rightarrow> SetMem \<rightarrow> is_kpair \<triangle> SetMem"
  by (rule funI, rule funI, rule intI, rule is_kpairI, auto,
      rule set_setmem[OF setof_set[OF kpair_setof]], auto)

  show "\<forall>a : SetMem. \<forall>b : SetMem. \<forall>c : SetMem. \<forall>d : SetMem.
          (kpair a b = kpair c d) = (a = c \<and> b = d)"
    unfolding tall_def
    using kpair_iff by auto

  show "\<forall>p : is_kpair. \<exists>a b. p = kpair a b"
    unfolding tall_def
    using is_kpairE by meson

  show "\<forall>b. SetMem b \<longleftrightarrow> (\<exists>p : is_kpair. \<exists>c. p = kpair b c \<or> p = kpair c b)"
  proof (auto)
    fix b assume "SetMem b"
    hence "kpair b b : is_kpair"
      using is_kpairI unfolding has_ty_def by auto
    thus "\<exists>p : is_kpair. \<exists>c. p = kpair b c \<or> p = kpair c b"
      by auto
  next
    fix b c assume "kpair b c : is_kpair"
    thus "SetMem b"
      using is_kpairD unfolding has_ty_def by auto
  next
    fix b c assume "kpair b c : is_kpair"
    thus "SetMem c"
      using is_kpairD unfolding has_ty_def by auto
  qed
qed

sublocale OPair is_kpair kpair SetMem GZF_default
  by (intro_locales, rule GZF_OPair)

section \<open>Cartesian Products of Kuratowski Pairs\<close>
(*Interpret Cartesian Product locale, using GZF for sets, and kpair for ordered pairs. *)

lemma kpair_typ_iskpair : "kpair : SetMem \<rightarrow> SetMem \<rightarrow> is_kpair"
  by (rule funI, rule funI, rule is_kpairI)

lemma kpair_typ_setmem : "kpair : SetMem \<rightarrow> SetMem \<rightarrow> SetMem"
  by (rule funI, rule funI, rule set_setmem[OF setof_set[OF kpair_setof]])

theorem GZF_CartProd :
  "class.CartProd_axioms SetMem is_kpair kpair SetMem"
  by (unfold_locales, rule kpair_typ_iskpair, rule kpair_typ_setmem)

end
end


(*  Title:       Calculi of the Saturation Framework
 *   Author:      Sophie Tourret <stourret at mpi-inf.mpg.de>, 2018-2020 *)

section \<open>Calculi\<close>

text \<open>In this section, the section 2.2 to 2.4 of the report are covered. This
  includes results on calculi equipped with a redundancy criterion or with a
  family of redundancy criteria, as well as a proof that various notions of
  redundancy are equivalent\<close>

theory Calculi
  imports
    Consequence_Relations_and_Inference_Systems
    Ordered_Resolution_Prover.Lazy_List_Liminf
    Ordered_Resolution_Prover.Lazy_List_Chain
begin

subsection \<open>Calculi with a Redundancy Criterion\<close>

locale calculus_with_red_crit = inference_system Inf + consequence_relation Bot entails
  for
    Bot :: "'f set" and
    Inf :: \<open>'f inference set\<close> and
    entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>" 50)
  + fixes
    Red_Inf :: "'f set \<Rightarrow> 'f inference set" and
    Red_F :: "'f set \<Rightarrow> 'f set"
  assumes
    Red_Inf_to_Inf: "Red_Inf N \<subseteq> Inf" and
    Red_F_Bot: "B \<in> Bot \<Longrightarrow> N \<Turnstile> {B} \<Longrightarrow> N - Red_F N \<Turnstile> {B}" and
    Red_F_of_subset: "N \<subseteq> N' \<Longrightarrow> Red_F N \<subseteq> Red_F N'" and
    Red_Inf_of_subset: "N \<subseteq> N' \<Longrightarrow> Red_Inf N \<subseteq> Red_Inf N'" and
    Red_F_of_Red_F_subset: "N' \<subseteq> Red_F N \<Longrightarrow> Red_F N \<subseteq> Red_F (N - N')" and
    Red_Inf_of_Red_F_subset: "N' \<subseteq> Red_F N \<Longrightarrow> Red_Inf N \<subseteq> Red_Inf (N - N')" and
    Red_Inf_of_Inf_to_N: "\<iota> \<in> Inf \<Longrightarrow> concl_of \<iota> \<in> N \<Longrightarrow> \<iota> \<in> Red_Inf N"
begin

lemma Red_Inf_of_Inf_to_N_subset: "{\<iota> \<in> Inf. (concl_of \<iota> \<in> N)} \<subseteq> Red_Inf N"
  using Red_Inf_of_Inf_to_N by blast

(* lem:red-concl-implies-red-inf *)
lemma red_concl_to_red_inf:
  assumes
    i_in: "\<iota> \<in> Inf" and
    concl: "concl_of \<iota> \<in> Red_F N"
  shows "\<iota> \<in> Red_Inf N"
proof -
  have "\<iota> \<in> Red_Inf (Red_F N)" by (simp add: Red_Inf_of_Inf_to_N i_in concl)
  then have i_in_Red: "\<iota> \<in> Red_Inf (N \<union> Red_F N)" by (simp add: Red_Inf_of_Inf_to_N concl i_in)
  have red_n_subs: "Red_F N \<subseteq> Red_F (N \<union> Red_F N)" by (simp add: Red_F_of_subset)
  then have "\<iota> \<in> Red_Inf ((N \<union> Red_F N) - (Red_F N - N))" using Red_Inf_of_Red_F_subset i_in_Red
    by (meson Diff_subset subsetCE subset_trans)
  then show ?thesis by (metis Diff_cancel Diff_subset Un_Diff Un_Diff_cancel contra_subsetD
    calculus_with_red_crit.Red_Inf_of_subset calculus_with_red_crit_axioms sup_bot.right_neutral)
qed

definition saturated :: "'f set \<Rightarrow> bool" where
  "saturated N \<equiv> Inf_from N \<subseteq> Red_Inf N"

definition reduc_saturated :: "'f set \<Rightarrow> bool" where
"reduc_saturated N \<equiv> Inf_from (N - Red_F N) \<subseteq> Red_Inf N"

lemma Red_Inf_without_red_F:
  "Red_Inf (N - Red_F N) = Red_Inf N"
  using Red_Inf_of_subset [of "N - Red_F N" N]
    and Red_Inf_of_Red_F_subset [of "Red_F N" N] by blast

lemma saturated_without_red_F:
  assumes saturated: "saturated N"
  shows "saturated (N - Red_F N)"
proof -
  have "Inf_from (N - Red_F N) \<subseteq> Inf_from N" unfolding Inf_from_def by auto
  also have "Inf_from N \<subseteq> Red_Inf N" using saturated unfolding saturated_def by auto
  also have "Red_Inf N \<subseteq> Red_Inf (N - Red_F N)" using Red_Inf_of_Red_F_subset by auto
  finally have "Inf_from (N - Red_F N) \<subseteq> Red_Inf (N - Red_F N)" by auto
  then show ?thesis unfolding saturated_def by auto
qed

definition Sup_Red_Inf_llist :: "'f set llist \<Rightarrow> 'f inference set" where
  "Sup_Red_Inf_llist D = (\<Union>i \<in> {i. enat i < llength D}. Red_Inf (lnth D i))"

lemma Sup_Red_Inf_unit: "Sup_Red_Inf_llist (LCons X LNil) = Red_Inf X"
  using Sup_Red_Inf_llist_def enat_0_iff(1) by simp

definition fair :: "'f set llist \<Rightarrow> bool" where
  "fair D \<equiv> Inf_from (Liminf_llist D) \<subseteq> Sup_Red_Inf_llist D"

inductive "derive" :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<rhd>Red" 50) where
  derive: "M - N \<subseteq> Red_F N \<Longrightarrow> M \<rhd>Red N"

text \<open>TODO: replace in \<^theory>\<open>Ordered_Resolution_Prover.Lazy_List_Liminf\<close>.\<close>
lemma (in-) elem_Sup_llist_imp_Sup_upto_llist':
  "x \<in> Sup_llist Xs \<Longrightarrow> \<exists>j < llength Xs. x \<in> Sup_upto_llist Xs j"
  unfolding Sup_llist_def Sup_upto_llist_def by blast

lemma gt_Max_notin: \<open>finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> x > Max A \<Longrightarrow> x \<notin> A\<close> by auto

lemma equiv_Sup_Liminf:
  assumes
    in_Sup: "C \<in> Sup_llist D" and
    not_in_Liminf: "C \<notin> Liminf_llist D"
  shows
    "\<exists> i \<in> {i. enat (Suc i) < llength D}. C \<in> lnth D i - lnth D (Suc i)"
proof -
  obtain i where C_D_i: "C \<in> Sup_upto_llist D i" and "i < llength D"
    using elem_Sup_llist_imp_Sup_upto_llist' in_Sup by fast
  then obtain j where j: "j \<ge> i \<and> enat j < llength D \<and> C \<notin> lnth D j" using not_in_Liminf
    unfolding Sup_llist_def chain_def Liminf_llist_def by auto
  obtain k where k: "C \<in> lnth D k" "enat k < llength D" "k \<le> i" using C_D_i
    unfolding Sup_upto_llist_def by auto
  let ?S = "{i. i < j \<and> i \<ge> k \<and> C \<in> lnth D i}"
  define l where "l \<equiv> Max ?S"
  have \<open>k \<in> {i. i < j \<and> k \<le> i \<and> C \<in> lnth D i}\<close> using k j by (auto simp: order.order_iff_strict)
  then have nempty: "{i. i < j \<and> k \<le> i \<and> C \<in> lnth D i} \<noteq> {}" by auto
  then have l_prop: "l < j \<and> l \<ge> k \<and> C \<in> (lnth D l)" using Max_in[of ?S, OF _ nempty] unfolding l_def by auto
  then have "C \<in> lnth D l - lnth D (Suc l)" using j gt_Max_notin[OF _ nempty, of "Suc l"]
    unfolding l_def[symmetric] by (auto intro: Suc_lessI)
  then show ?thesis
  proof (rule bexI[of _ l])
    show "l \<in> {i. enat (Suc i) < llength D}"
      using l_prop j by (clarify, metis Suc_leI dual_order.order_iff_strict enat_ord_simps(2) less_trans)
  qed
qed

(* lem:nonpersistent-is-redundant *)
lemma Red_in_Sup:
  assumes deriv: "chain (\<rhd>Red) D"
  shows "Sup_llist D - Liminf_llist D \<subseteq> Red_F (Sup_llist D)"
proof
  fix C
  assume C_in_subset: "C \<in> Sup_llist D - Liminf_llist D"
  {
    fix C i
    assume
      in_ith_elem: "C \<in> lnth D i - lnth D (Suc i)" and
      i: "enat (Suc i) < llength D"
    have "lnth D i \<rhd>Red lnth D (Suc i)" using i deriv in_ith_elem chain_lnth_rel by auto
    then have "C \<in> Red_F (lnth D (Suc i))" using in_ith_elem derive.cases by blast
    then have "C \<in> Red_F (Sup_llist D)" using Red_F_of_subset
      by (meson contra_subsetD i lnth_subset_Sup_llist)
  }
  then show "C \<in> Red_F (Sup_llist D)" using equiv_Sup_Liminf[of C] C_in_subset by fast
qed

(* lem:redundant-remains-redundant-during-run 1/2 *)
lemma Red_Inf_subset_Liminf:
  assumes deriv: \<open>chain (\<rhd>Red) D\<close> and
    i: \<open>enat i < llength D\<close>
  shows \<open>Red_Inf (lnth D i) \<subseteq> Red_Inf (Liminf_llist D)\<close>
proof -
  have Sup_in_diff: \<open>Red_Inf (Sup_llist D) \<subseteq> Red_Inf (Sup_llist D - (Sup_llist D - Liminf_llist D))\<close>
    using Red_Inf_of_Red_F_subset[OF Red_in_Sup] deriv by auto
  also have \<open>Sup_llist D - (Sup_llist D - Liminf_llist D) = Liminf_llist D\<close>
    by (simp add: Liminf_llist_subset_Sup_llist double_diff)
  then have Red_Inf_Sup_in_Liminf: \<open>Red_Inf (Sup_llist D) \<subseteq> Red_Inf (Liminf_llist D)\<close> using Sup_in_diff by auto
  have \<open>lnth D i \<subseteq> Sup_llist D\<close> unfolding Sup_llist_def using i by blast
  then have "Red_Inf (lnth D i) \<subseteq> Red_Inf (Sup_llist D)" using Red_Inf_of_subset
    unfolding Sup_llist_def by auto
  then show ?thesis using Red_Inf_Sup_in_Liminf by auto
qed

(* lem:redundant-remains-redundant-during-run 2/2 *)
lemma Red_F_subset_Liminf:
 assumes deriv: \<open>chain (\<rhd>Red) D\<close> and
    i: \<open>enat i < llength D\<close>
  shows \<open>Red_F (lnth D i) \<subseteq> Red_F (Liminf_llist D)\<close>
proof -
  have Sup_in_diff: \<open>Red_F (Sup_llist D) \<subseteq> Red_F (Sup_llist D - (Sup_llist D - Liminf_llist D))\<close>
    using Red_F_of_Red_F_subset[OF Red_in_Sup] deriv by auto
  also have \<open>Sup_llist D - (Sup_llist D - Liminf_llist D) = Liminf_llist D\<close>
    by (simp add: Liminf_llist_subset_Sup_llist double_diff)
  then have Red_F_Sup_in_Liminf: \<open>Red_F (Sup_llist D) \<subseteq> Red_F (Liminf_llist D)\<close>
    using Sup_in_diff by auto
  have \<open>lnth D i \<subseteq> Sup_llist D\<close> unfolding Sup_llist_def using i by blast
  then have "Red_F (lnth D i) \<subseteq> Red_F (Sup_llist D)" using Red_F_of_subset
    unfolding Sup_llist_def by auto
  then show ?thesis using Red_F_Sup_in_Liminf by auto
qed

(* lem:N-i-is-persistent-or-redundant *)
lemma i_in_Liminf_or_Red_F:
  assumes
    deriv: \<open>chain (\<rhd>Red) D\<close> and
    i: \<open>enat i < llength D\<close>
  shows \<open>lnth D i \<subseteq> Red_F (Liminf_llist D) \<union> Liminf_llist D\<close>
proof (rule,rule)
  fix C
  assume C: \<open>C \<in> lnth D i\<close>
  and C_not_Liminf: \<open>C \<notin> Liminf_llist D\<close>
  have \<open>C \<in> Sup_llist D\<close> unfolding Sup_llist_def using C i by auto
  then obtain j where j: \<open>C \<in> lnth D j - lnth D (Suc j)\<close> \<open>enat (Suc j) < llength D\<close>
    using equiv_Sup_Liminf[of C D] C_not_Liminf by auto
  then have \<open>C \<in> Red_F (lnth D (Suc j))\<close>
    using deriv by (meson chain_lnth_rel contra_subsetD derive.cases)
  then show \<open>C \<in> Red_F (Liminf_llist D)\<close> using Red_F_subset_Liminf[of D "Suc j"] deriv j(2) by blast
qed

(* lem:fairness-implies-saturation *)
lemma fair_implies_Liminf_saturated:
  assumes
    deriv: \<open>chain (\<rhd>Red) D\<close> and
    fair: \<open>fair D\<close>
  shows \<open>saturated (Liminf_llist D)\<close>
  unfolding saturated_def
proof
  fix \<iota>
  assume \<iota>: \<open>\<iota> \<in> Inf_from (Liminf_llist D)\<close>
  have \<open>\<iota> \<in> Sup_Red_Inf_llist D\<close> using fair \<iota> unfolding fair_def by auto
  then obtain i where i: \<open>enat i < llength D\<close> \<open>\<iota> \<in> Red_Inf (lnth D i)\<close>
    unfolding Sup_Red_Inf_llist_def by auto
  then show \<open>\<iota> \<in> Red_Inf (Liminf_llist D)\<close>
    using deriv i_in_Liminf_or_Red_F[of D i] Red_Inf_subset_Liminf by blast
qed

end

locale static_refutational_complete_calculus = calculus_with_red_crit +
  assumes static_refutational_complete: "B \<in> Bot \<Longrightarrow> saturated N \<Longrightarrow> N \<Turnstile> {B} \<Longrightarrow> \<exists>B'\<in>Bot. B' \<in> N"

locale dynamic_refutational_complete_calculus = calculus_with_red_crit +
  assumes
    dynamic_refutational_complete: "B \<in> Bot \<Longrightarrow> chain (\<rhd>Red) D \<Longrightarrow> fair D
      \<Longrightarrow> lnth D 0 \<Turnstile> {B} \<Longrightarrow> \<exists>i \<in> {i. enat i < llength D}. \<exists>B'\<in>Bot. B' \<in> lnth D i"
begin

(* lem:dynamic-ref-compl-implies-static *)
sublocale static_refutational_complete_calculus
proof
  fix B N
  assume
    bot_elem: \<open>B \<in> Bot\<close> and
    saturated_N: "saturated N" and
    refut_N: "N \<Turnstile> {B}"
  define D where "D = LCons N LNil"
  have[simp]: \<open>\<not> lnull D\<close> by (auto simp: D_def)
  have deriv_D: \<open>chain (\<rhd>Red) D\<close> by (simp add: chain.chain_singleton D_def)
  have liminf_is_N: "Liminf_llist D = N" by (simp add: D_def Liminf_llist_LCons)
  have head_D: "N = lnth D 0" by (simp add: D_def)
  have "Sup_Red_Inf_llist D = Red_Inf N" by (simp add: D_def Sup_Red_Inf_unit)
  then have fair_D: "fair D" using saturated_N by (simp add: fair_def saturated_def liminf_is_N)
  obtain i B' where B'_is_bot: \<open>B' \<in> Bot\<close> and B'_in: "B' \<in> (lnth D i)" and \<open>i < llength D\<close>
    using dynamic_refutational_complete[of B D] bot_elem fair_D head_D saturated_N deriv_D refut_N
    by auto
  then have "i = 0"
    by (auto simp: D_def enat_0_iff)
  show \<open>\<exists>B'\<in>Bot. B' \<in> N\<close>
    using B'_is_bot B'_in unfolding \<open>i = 0\<close> head_D[symmetric] by auto
qed

end

(* lem:static-ref-compl-implies-dynamic *)
sublocale static_refutational_complete_calculus \<subseteq> dynamic_refutational_complete_calculus
proof
  fix B D
  assume
    bot_elem: \<open>B \<in> Bot\<close> and
    deriv: \<open>chain (\<rhd>Red) D\<close> and
    fair: \<open>fair D\<close> and
    unsat: \<open>(lnth D 0) \<Turnstile> {B}\<close>
    have non_empty: \<open>\<not> lnull D\<close> using chain_not_lnull[OF deriv] .
    have subs: \<open>(lnth D 0) \<subseteq> Sup_llist D\<close>
      using lhd_subset_Sup_llist[of D] non_empty by (simp add: lhd_conv_lnth)
    have \<open>Sup_llist D \<Turnstile> {B}\<close>
      using unsat subset_entailed[OF subs] entails_trans[of "Sup_llist D" "lnth D 0"] by auto
    then have Sup_no_Red: \<open>Sup_llist D - Red_F (Sup_llist D) \<Turnstile> {B}\<close>
      using bot_elem Red_F_Bot by auto
    have Sup_no_Red_in_Liminf: \<open>Sup_llist D - Red_F (Sup_llist D) \<subseteq> Liminf_llist D\<close>
      using deriv Red_in_Sup by auto
    have Liminf_entails_Bot: \<open>Liminf_llist D \<Turnstile> {B}\<close>
      using Sup_no_Red subset_entailed[OF Sup_no_Red_in_Liminf] entails_trans by blast
    have \<open>saturated (Liminf_llist D)\<close>
      using deriv fair fair_implies_Liminf_saturated unfolding saturated_def by auto

   then have \<open>\<exists>B'\<in>Bot. B' \<in> (Liminf_llist D)\<close>
     using bot_elem static_refutational_complete Liminf_entails_Bot by auto
   then show \<open>\<exists>i\<in>{i. enat i < llength D}. \<exists>B'\<in>Bot. B' \<in> lnth D i\<close>
     unfolding Liminf_llist_def by auto
qed

subsection \<open>Calculi with a Family of Redundancy Criteria\<close>

locale calculus_with_red_crit_family = inference_system Inf + consequence_relation_family Bot Q entails_q
  for
    Bot :: "'f set" and
    Inf :: \<open>'f inference set\<close> and
    Q :: "'q itself" and
    entails_q :: "'q \<Rightarrow> ('f set \<Rightarrow> 'f set \<Rightarrow> bool)"
  + fixes
    Red_Inf_q :: "'q \<Rightarrow> ('f set \<Rightarrow> 'f inference set)" and
    Red_F_q :: "'q \<Rightarrow> ('f set \<Rightarrow> 'f set)"
  assumes
    all_red_crit: "calculus_with_red_crit Bot Inf (entails_q q) (Red_Inf_q q) (Red_F_q q)"
begin

definition Red_Inf_Q :: "'f set \<Rightarrow> 'f inference set" where
  "Red_Inf_Q N = \<Inter> {X N |X. X \<in> (Red_Inf_q ` UNIV)}"

definition Red_F_Q :: "'f set \<Rightarrow> 'f set" where
  "Red_F_Q N = \<Inter> {X N |X. X \<in> (Red_F_q ` UNIV)}"

(* lem:intersection-of-red-crit *)
lemma inter_red_crit: "calculus_with_red_crit Bot Inf entails_Q Red_Inf_Q Red_F_Q"
  unfolding calculus_with_red_crit_def calculus_with_red_crit_axioms_def
proof (intro conjI)
  show "consequence_relation Bot entails_Q"
  using intersect_cons_rel_family .
next
  show "\<forall>N. Red_Inf_Q N \<subseteq> Inf"
    unfolding Red_Inf_Q_def
  proof
    fix N
    show "\<Inter> {X N |X. X \<in> Red_Inf_q ` UNIV} \<subseteq> Inf"
    proof (intro Inter_subset)
      fix Red_Infs
      assume one_red_inf: "Red_Infs \<in> {X N |X. X \<in> Red_Inf_q ` UNIV}"
      show "Red_Infs \<subseteq> Inf" using one_red_inf
      proof
        assume "\<exists>Red_Inf_qi. Red_Infs = Red_Inf_qi N \<and> Red_Inf_qi \<in> Red_Inf_q ` UNIV"
        then obtain Red_Inf_qi where
          red_infs_def: "Red_Infs = Red_Inf_qi N" and red_inf_qi_in: "Red_Inf_qi \<in> Red_Inf_q ` UNIV"
          by blast
        obtain qi where red_inf_qi_def: "Red_Inf_qi = Red_Inf_q qi" and qi_in: "qi \<in> UNIV"
          using red_inf_qi_in by blast
        show "Red_Infs \<subseteq> Inf"
          using all_red_crit calculus_with_red_crit.Red_Inf_to_Inf red_inf_qi_def
          red_infs_def by blast
      qed
    next
      show "{X N |X. X \<in> Red_Inf_q ` UNIV} \<noteq> {}" by blast
    qed
  qed
next
  show "\<forall>B N. B \<in> Bot \<longrightarrow> N \<Turnstile>Q {B} \<longrightarrow> N - Red_F_Q N \<Turnstile>Q {B}"
  proof (intro allI impI)
    fix B N
    assume
      B_in: "B \<in> Bot" and
      N_unsat: "N \<Turnstile>Q {B}"
    show "N - Red_F_Q N \<Turnstile>Q {B}" unfolding entails_Q_def Red_F_Q_def
    proof
      fix qi
      define entails_qi (infix "\<Turnstile>qi" 50) where "entails_qi = entails_q qi"
      have cons_rel_qi: "consequence_relation Bot entails_qi"
        unfolding entails_qi_def using all_red_crit calculus_with_red_crit.axioms(1) by blast
      define Red_F_qi where "Red_F_qi = Red_F_q qi"
      have red_qi_in_Q: "Red_F_Q N \<subseteq> Red_F_qi N"
        unfolding Red_F_Q_def Red_F_qi_def using image_iff by blast
      then have "N - (Red_F_qi N) \<subseteq> N - (Red_F_Q N)" by blast
      then have entails_1: "(N - Red_F_Q N) \<Turnstile>qi (N - Red_F_qi N)"
        using all_red_crit
        unfolding calculus_with_red_crit_def consequence_relation_def entails_qi_def by metis
      have N_unsat_qi: "N \<Turnstile>qi {B}" using N_unsat unfolding entails_qi_def entails_Q_def by simp
      then have N_unsat_qi: "(N - Red_F_qi N) \<Turnstile>qi {B}"
        using all_red_crit Red_F_qi_def calculus_with_red_crit.Red_F_Bot[OF _ B_in] entails_qi_def
        by fastforce
      show "(N - \<Inter> {X N |X. X \<in> Red_F_q ` UNIV}) \<Turnstile>qi {B}"
        using consequence_relation.entails_trans[OF cons_rel_qi entails_1 N_unsat_qi]
        unfolding Red_F_Q_def .
    qed
  qed
next
  show "\<forall>N1 N2. N1 \<subseteq> N2 \<longrightarrow> Red_F_Q N1 \<subseteq> Red_F_Q N2"
  proof (intro allI impI)
    fix N1 :: "'f set"
    and N2 :: "'f set"
    assume
      N1_in_N2: "N1 \<subseteq> N2"
    show "Red_F_Q N1 \<subseteq> Red_F_Q N2"
    proof
      fix x
      assume x_in: "x \<in> Red_F_Q N1"
      then have "\<forall>qi. x \<in> Red_F_q qi N1" unfolding Red_F_Q_def by blast
      then have "\<forall>qi. x \<in> Red_F_q qi N2"
        using N1_in_N2 all_red_crit calculus_with_red_crit.axioms(2) calculus_with_red_crit.Red_F_of_subset by blast
      then show "x \<in> Red_F_Q N2" unfolding Red_F_Q_def by blast
    qed
  qed
next
  show "\<forall>N1 N2. N1 \<subseteq> N2 \<longrightarrow> Red_Inf_Q N1 \<subseteq> Red_Inf_Q N2"
  proof (intro allI impI)
    fix N1 :: "'f set"
    and N2 :: "'f set"
    assume
      N1_in_N2: "N1 \<subseteq> N2"
    show "Red_Inf_Q N1 \<subseteq> Red_Inf_Q N2"
    proof
      fix x
      assume x_in: "x \<in> Red_Inf_Q N1"
      then have "\<forall>qi. x \<in> Red_Inf_q qi N1" unfolding Red_Inf_Q_def by blast
      then have "\<forall>qi. x \<in> Red_Inf_q qi N2"
        using N1_in_N2 all_red_crit calculus_with_red_crit.axioms(2) calculus_with_red_crit.Red_Inf_of_subset by blast
      then show "x \<in> Red_Inf_Q N2" unfolding Red_Inf_Q_def by blast
    qed
  qed
next
  show "\<forall>N2 N1. N2 \<subseteq> Red_F_Q N1 \<longrightarrow> Red_F_Q N1 \<subseteq> Red_F_Q (N1 - N2)"
  proof (intro allI impI)
    fix N2 N1
    assume N2_in_Red_N1: "N2 \<subseteq> Red_F_Q N1"
    show "Red_F_Q N1 \<subseteq> Red_F_Q (N1 - N2)"
    proof
      fix x
      assume x_in: "x \<in> Red_F_Q N1"
      then have "\<forall>qi. x \<in> Red_F_q qi N1" unfolding Red_F_Q_def by blast
      moreover have "\<forall>qi. N2 \<subseteq> Red_F_q qi N1" using N2_in_Red_N1 unfolding Red_F_Q_def by blast
      ultimately have "\<forall>qi. x \<in> Red_F_q qi (N1 - N2)"
        using all_red_crit calculus_with_red_crit.axioms(2) calculus_with_red_crit.Red_F_of_Red_F_subset by blast
      then show "x \<in> Red_F_Q (N1 - N2)" unfolding Red_F_Q_def by blast
    qed
  qed
next
  show "\<forall>N2 N1. N2 \<subseteq> Red_F_Q N1 \<longrightarrow> Red_Inf_Q N1 \<subseteq> Red_Inf_Q (N1 - N2)"
  proof (intro allI impI)
    fix N2 N1
    assume N2_in_Red_N1: "N2 \<subseteq> Red_F_Q N1"
    show "Red_Inf_Q N1 \<subseteq> Red_Inf_Q (N1 - N2)"
    proof
      fix x
      assume x_in: "x \<in> Red_Inf_Q N1"
      then have "\<forall>qi. x \<in> Red_Inf_q qi N1" unfolding Red_Inf_Q_def by blast
      moreover have "\<forall>qi. N2 \<subseteq> Red_F_q qi N1" using N2_in_Red_N1 unfolding Red_F_Q_def by blast
      ultimately have "\<forall>qi. x \<in> Red_Inf_q qi (N1 - N2)"
        using all_red_crit calculus_with_red_crit.axioms(2) calculus_with_red_crit.Red_Inf_of_Red_F_subset by blast
      then show "x \<in> Red_Inf_Q (N1 - N2)" unfolding Red_Inf_Q_def by blast
    qed
  qed
next
  show "\<forall>\<iota> N. \<iota> \<in> Inf \<longrightarrow> concl_of \<iota> \<in> N \<longrightarrow> \<iota> \<in> Red_Inf_Q N"
  proof (intro allI impI)
    fix \<iota> N
    assume
      i_in: "\<iota> \<in> Inf" and
      concl_in: "concl_of \<iota> \<in> N"
    then have "\<forall>qi. \<iota> \<in> Red_Inf_q qi N"
      using all_red_crit calculus_with_red_crit.axioms(2) calculus_with_red_crit.Red_Inf_of_Inf_to_N by blast
    then show "\<iota> \<in> Red_Inf_Q N" unfolding Red_Inf_Q_def by blast
  qed
qed

sublocale inter_red_crit_calculus: calculus_with_red_crit
  where Bot=Bot
  and Inf=Inf
  and entails=entails_Q
  and Red_Inf=Red_Inf_Q
  and Red_F=Red_F_Q
  using inter_red_crit .

(* lem:satur-wrt-intersection-of-red *)
lemma sat_int_to_sat_q: "calculus_with_red_crit.saturated Inf Red_Inf_Q N \<longleftrightarrow>
  (\<forall>qi. calculus_with_red_crit.saturated Inf (Red_Inf_q qi) N)" for N
proof
  fix N
  assume inter_sat: "calculus_with_red_crit.saturated Inf Red_Inf_Q N"
  show "\<forall>qi. calculus_with_red_crit.saturated Inf (Red_Inf_q qi) N"
  proof
    fix qi
    interpret one: calculus_with_red_crit Bot Inf "entails_q qi" "Red_Inf_q qi" "Red_F_q qi"
      by (rule all_red_crit)
    show "one.saturated N"
      using inter_sat unfolding one.saturated_def inter_red_crit_calculus.saturated_def Red_Inf_Q_def
      by blast
  qed
next
  fix N
  assume all_sat: "\<forall>qi. calculus_with_red_crit.saturated Inf (Red_Inf_q qi) N"
  show "inter_red_crit_calculus.saturated N" unfolding inter_red_crit_calculus.saturated_def Red_Inf_Q_def
  proof
    fix x
    assume x_in: "x \<in> Inf_from N"
    have "\<forall>Red_Inf_qi \<in> Red_Inf_q ` UNIV. x \<in> Red_Inf_qi N"
    proof
      fix Red_Inf_qi
      assume red_inf_in: "Red_Inf_qi \<in> Red_Inf_q ` UNIV"
      then obtain qi where red_inf_qi_def: "Red_Inf_qi = Red_Inf_q qi" by blast
      interpret one: calculus_with_red_crit Bot Inf "entails_q qi" "Red_Inf_q qi" "Red_F_q qi"
        by (rule all_red_crit)
      have "one.saturated N" using all_sat red_inf_qi_def by blast
      then show "x \<in> Red_Inf_qi N" unfolding one.saturated_def using x_in red_inf_qi_def by blast
    qed
    then show "x \<in> \<Inter> {X N |X. X \<in> Red_Inf_q ` UNIV}" by blast
  qed
qed

(* lem:checking-static-ref-compl-for-intersections *)
lemma stat_ref_comp_from_bot_in_sat:
  "\<forall>N. (calculus_with_red_crit.saturated Inf Red_Inf_Q N \<and> (\<forall>B \<in> Bot. B \<notin> N)) \<longrightarrow>
    (\<exists>B \<in> Bot. \<exists>qi. \<not> entails_q qi N {B})
    \<Longrightarrow> static_refutational_complete_calculus Bot Inf entails_Q Red_Inf_Q Red_F_Q"
proof (rule ccontr)
  assume
    N_saturated: "\<forall>N. (calculus_with_red_crit.saturated Inf Red_Inf_Q N \<and> (\<forall>B \<in> Bot. B \<notin> N)) \<longrightarrow>
      (\<exists>B \<in> Bot. \<exists>qi. \<not> entails_q qi N {B})" and
    no_stat_ref_comp: "\<not> static_refutational_complete_calculus Bot Inf (\<Turnstile>Q) Red_Inf_Q Red_F_Q"
  obtain N1 B1 where B1_in:
    "B1 \<in> Bot" and N1_saturated: "calculus_with_red_crit.saturated Inf Red_Inf_Q N1" and
    N1_unsat: "N1 \<Turnstile>Q {B1}" and no_B_in_N1: "\<forall>B \<in> Bot. B \<notin> N1"
    using no_stat_ref_comp by (metis inter_red_crit static_refutational_complete_calculus.intro
      static_refutational_complete_calculus_axioms.intro)
  obtain B2 qi where no_qi:"\<not> entails_q qi N1 {B2}" using N_saturated N1_saturated no_B_in_N1 by blast
  have "N1 \<Turnstile>Q {B2}" using N1_unsat B1_in intersect_cons_rel_family
    unfolding consequence_relation_def by metis
  then have "entails_q qi N1 {B2}" unfolding entails_Q_def by blast
  then show "False" using no_qi by simp
qed

end

subsection \<open>Variations on a Theme\<close>

locale calculus_with_reduced_red_crit = calculus_with_red_crit Bot Inf entails Red_Inf Red_F
  for
    Bot :: "'f set" and
    Inf :: \<open>'f inference set\<close> and
    entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>" 50) and
    Red_Inf :: "'f set \<Rightarrow> 'f inference set" and
    Red_F :: "'f set \<Rightarrow> 'f set"
 + assumes
   inf_in_red_inf: "Inf_from2 UNIV (Red_F N) \<subseteq> Red_Inf N"
begin

(* lem:reduced-rc-implies-sat-equiv-reduced-sat *)
lemma sat_eq_reduc_sat: "saturated N \<longleftrightarrow> reduc_saturated N"
proof
  fix N
  assume "saturated N"
  then show "reduc_saturated N"
    using Red_Inf_without_red_F saturated_without_red_F
    unfolding saturated_def reduc_saturated_def
    by blast
next
  fix N
  assume red_sat_n: "reduc_saturated N"
  show "saturated N" unfolding saturated_def
  proof
    fix \<iota>
    assume i_in: "\<iota> \<in> Inf_from N"
    show "\<iota> \<in> Red_Inf N"
      using i_in red_sat_n inf_in_red_inf unfolding reduc_saturated_def Inf_from_def Inf_from2_def by blast
  qed
qed

end

locale  reduc_static_refutational_complete_calculus = calculus_with_red_crit +
  assumes reduc_static_refutational_complete: "B \<in> Bot \<Longrightarrow> reduc_saturated N \<Longrightarrow> N \<Turnstile> {B} \<Longrightarrow> \<exists>B'\<in>Bot. B' \<in> N"

locale reduc_static_refutational_complete_reduc_calculus = calculus_with_reduced_red_crit +
  assumes reduc_static_refutational_complete: "B \<in> Bot \<Longrightarrow> reduc_saturated N \<Longrightarrow> N \<Turnstile> {B} \<Longrightarrow> \<exists>B'\<in>Bot. B' \<in> N"
begin

sublocale reduc_static_refutational_complete_calculus
  by (simp add: calculus_with_red_crit_axioms reduc_static_refutational_complete
    reduc_static_refutational_complete_calculus_axioms.intro reduc_static_refutational_complete_calculus_def)

(* cor:reduced-rc-implies-st-ref-comp-equiv-reduced-st-ref-comp 1/2 *)
sublocale static_refutational_complete_calculus
proof
  fix B N
  assume
    bot_elem: \<open>B \<in> Bot\<close> and
    saturated_N: "saturated N" and
    refut_N: "N \<Turnstile> {B}"
  have reduc_saturated_N: "reduc_saturated N" using saturated_N sat_eq_reduc_sat by blast
  show "\<exists>B'\<in>Bot. B' \<in> N" using reduc_static_refutational_complete[OF bot_elem reduc_saturated_N refut_N] .
qed
end

context calculus_with_reduced_red_crit
begin

(* cor:reduced-rc-implies-st-ref-comp-equiv-reduced-st-ref-comp 2/2 *)
lemma stat_ref_comp_imp_red_stat_ref_comp: "static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F \<Longrightarrow>
  reduc_static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
proof
  fix B N
  assume
    stat_ref_comp: "static_refutational_complete_calculus Bot Inf (\<Turnstile>) Red_Inf Red_F" and
    bot_elem: \<open>B \<in> Bot\<close> and
    saturated_N: "reduc_saturated N" and
    refut_N: "N \<Turnstile> {B}"
  have reduc_saturated_N: "saturated N" using saturated_N sat_eq_reduc_sat by blast
  show "\<exists>B'\<in>Bot. B' \<in> N"
    using Calculi.static_refutational_complete_calculus.static_refutational_complete[OF stat_ref_comp
      bot_elem reduc_saturated_N refut_N] .
qed
end

context calculus_with_red_crit
begin

definition Red_Red_Inf :: "'f set \<Rightarrow> 'f inference set" where
  "Red_Red_Inf N = Red_Inf N \<union> Inf_from2 UNIV (Red_F N)"

lemma reduced_calc_is_calc: "calculus_with_red_crit Bot Inf entails Red_Red_Inf Red_F"
proof
  fix N
  show "Red_Red_Inf N \<subseteq> Inf"
    unfolding Red_Red_Inf_def Inf_from2_def Inf_from_def using Red_Inf_to_Inf by auto
next
  fix B N
  assume
    b_in: "B \<in> Bot" and
    n_entails: "N \<Turnstile> {B}"
  show "N - Red_F N \<Turnstile> {B}"
    by (simp add: Red_F_Bot b_in n_entails)
next
  fix N N' :: "'f set"
  assume "N \<subseteq> N'"
  then show "Red_F N \<subseteq> Red_F N'" by (simp add: Red_F_of_subset)
next
  fix N N' :: "'f set"
  assume n_in: "N \<subseteq> N'"
  then have "Inf_from (UNIV - (Red_F N')) \<subseteq> Inf_from (UNIV - (Red_F N))"
    using Red_F_of_subset[OF n_in] unfolding Inf_from_def by auto
  then have "Inf_from2 UNIV (Red_F N) \<subseteq> Inf_from2 UNIV (Red_F N')"
    unfolding Inf_from2_def by auto
  then show "Red_Red_Inf N \<subseteq> Red_Red_Inf N'"
    unfolding Red_Red_Inf_def using Red_Inf_of_subset[OF n_in] by blast
next
  fix N N' :: "'f set"
  assume "N' \<subseteq> Red_F N"
  then show "Red_F N \<subseteq> Red_F (N - N')" by (simp add: Red_F_of_Red_F_subset)
next
  fix N N' :: "'f set"
  assume np_subs: "N' \<subseteq> Red_F N"
  have "Red_F N \<subseteq> Red_F (N - N')" by (simp add: Red_F_of_Red_F_subset np_subs)
  then have "Inf_from (UNIV - (Red_F (N - N'))) \<subseteq> Inf_from (UNIV - (Red_F N))"
    by (metis Diff_subset Red_F_of_subset eq_iff)
  then have "Inf_from2 UNIV (Red_F N) \<subseteq> Inf_from2 UNIV (Red_F (N - N'))"
    unfolding Inf_from2_def by auto
  then show "Red_Red_Inf N \<subseteq> Red_Red_Inf (N - N')"
    unfolding Red_Red_Inf_def using Red_Inf_of_Red_F_subset[OF np_subs] by blast
next
  fix \<iota> N
  assume "\<iota> \<in> Inf"
    "concl_of \<iota> \<in> N"
  then show "\<iota> \<in> Red_Red_Inf N"
    by (simp add: Red_Inf_of_Inf_to_N Red_Red_Inf_def)
qed

lemma inf_subs_reduced_red_inf: "Inf_from2 UNIV (Red_F N) \<subseteq> Red_Red_Inf N"
  unfolding Red_Red_Inf_def by simp

(* lem:red'-is-reduced-redcrit *)
text \<open>The following is a lemma and not a sublocale as was previously used in similar cases.
  Here, a sublocale cannot be used because it would create an infinitely descending
  chain of sublocales. \<close>
lemma reduc_calc: "calculus_with_reduced_red_crit Bot Inf entails Red_Red_Inf Red_F"
  using inf_subs_reduced_red_inf reduced_calc_is_calc
  by (simp add: calculus_with_reduced_red_crit.intro calculus_with_reduced_red_crit_axioms_def)

interpretation reduc_calc : calculus_with_reduced_red_crit Bot Inf entails Red_Red_Inf Red_F
  using reduc_calc by simp

(* lem:saturation-red-vs-red'-1 *)
lemma sat_imp_red_calc_sat: "saturated N \<Longrightarrow> reduc_calc.saturated N"
  unfolding saturated_def reduc_calc.saturated_def Red_Red_Inf_def by blast

(* lem:saturation-red-vs-red'-2 1/2 (i) \<longleftrightarrow> (ii) *)
lemma red_sat_eq_red_calc_sat: "reduc_saturated N \<longleftrightarrow> reduc_calc.saturated N"
proof
  assume red_sat_n: "reduc_saturated N"
  show "reduc_calc.saturated N"
    unfolding reduc_calc.saturated_def
  proof
    fix \<iota>
    assume i_in: "\<iota> \<in> Inf_from N"
    show "\<iota> \<in> Red_Red_Inf N"
      using i_in red_sat_n unfolding reduc_saturated_def Inf_from2_def Inf_from_def Red_Red_Inf_def by blast
  qed
next
  assume red_sat_n: "reduc_calc.saturated N"
  show "reduc_saturated N"
    unfolding reduc_saturated_def
  proof
    fix \<iota>
    assume i_in: "\<iota> \<in> Inf_from (N - Red_F N)"
    show "\<iota> \<in> Red_Inf N"
      using i_in red_sat_n unfolding Inf_from_def reduc_calc.saturated_def Red_Red_Inf_def Inf_from2_def by blast
  qed
qed

(* lem:saturation-red-vs-red'-2 2/2 (i) \<longleftrightarrow> (iii) *)
lemma red_sat_eq_sat: "reduc_saturated N \<longleftrightarrow> saturated (N - Red_F N)"
  unfolding reduc_saturated_def saturated_def by (simp add: Red_Inf_without_red_F)

(* thm:reduced-stat-ref-compl 1/3 (i) \<longleftrightarrow> (iii) *)
theorem stat_is_stat_red: "static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F \<longleftrightarrow>
  static_refutational_complete_calculus Bot Inf entails Red_Red_Inf Red_F"
proof
  assume
    stat_ref1: "static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
  show "static_refutational_complete_calculus Bot Inf entails Red_Red_Inf Red_F"
    using reduc_calc.calculus_with_red_crit_axioms
    unfolding static_refutational_complete_calculus_def static_refutational_complete_calculus_axioms_def
  proof
    show "\<forall>B N. B \<in> Bot \<longrightarrow> reduc_calc.saturated N \<longrightarrow> N \<Turnstile> {B} \<longrightarrow> (\<exists>B'\<in>Bot. B' \<in> N)"
    proof (clarify)
      fix B N
      assume
        b_in: "B \<in> Bot" and
        n_sat: "reduc_calc.saturated N" and
        n_imp_b: "N \<Turnstile> {B}"
      have "saturated (N - Red_F N)" using red_sat_eq_red_calc_sat[of N] red_sat_eq_sat[of N] n_sat by blast
      moreover have "(N - Red_F N) \<Turnstile> {B}" using n_imp_b b_in by (simp add: reduc_calc.Red_F_Bot)
      ultimately show "\<exists>B'\<in>Bot. B'\<in> N"
        using stat_ref1 by (meson DiffD1 b_in static_refutational_complete_calculus.static_refutational_complete)
    qed
  qed
next
  assume
    stat_ref3: "static_refutational_complete_calculus Bot Inf entails Red_Red_Inf Red_F"
  show "static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
    unfolding static_refutational_complete_calculus_def static_refutational_complete_calculus_axioms_def
    using calculus_with_red_crit_axioms
  proof
    show "\<forall>B N. B \<in> Bot \<longrightarrow> saturated N \<longrightarrow> N \<Turnstile> {B} \<longrightarrow> (\<exists>B'\<in>Bot. B' \<in> N)"
    proof clarify
      fix B N
      assume
        b_in: "B \<in> Bot" and
        n_sat: "saturated N" and
        n_imp_b: "N \<Turnstile> {B}"
      then show "\<exists>B'\<in> Bot. B' \<in> N"
        using stat_ref3 sat_imp_red_calc_sat[OF n_sat]
        by (meson static_refutational_complete_calculus.static_refutational_complete)
    qed
  qed
qed

(* thm:reduced-stat-ref-compl 2/3 (iv) \<longleftrightarrow> (iii) *)
theorem red_stat_red_is_stat_red: "reduc_static_refutational_complete_calculus Bot Inf entails Red_Red_Inf Red_F \<longleftrightarrow>
  static_refutational_complete_calculus Bot Inf entails Red_Red_Inf Red_F"
  using reduc_calc.stat_ref_comp_imp_red_stat_ref_comp
  by (metis reduc_calc.sat_eq_reduc_sat reduc_static_refutational_complete_calculus.axioms(2)
    reduc_static_refutational_complete_calculus_axioms_def reduced_calc_is_calc
    static_refutational_complete_calculus.intro static_refutational_complete_calculus_axioms.intro)

(* thm:reduced-stat-ref-compl 3/3 (ii) \<longleftrightarrow> (iii) *)
theorem red_stat_is_stat_red: "reduc_static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F \<longleftrightarrow>
  static_refutational_complete_calculus Bot Inf entails Red_Red_Inf Red_F"
  using reduc_calc.calculus_with_red_crit_axioms calculus_with_red_crit_axioms red_sat_eq_red_calc_sat
  unfolding static_refutational_complete_calculus_def static_refutational_complete_calculus_axioms_def
    reduc_static_refutational_complete_calculus_def reduc_static_refutational_complete_calculus_axioms_def
  by blast

definition Sup_Red_F_llist :: "'f set llist \<Rightarrow> 'f set" where
"Sup_Red_F_llist D = (\<Union>i \<in> {i. enat i < llength D}. Red_F (lnth D i))"

lemma Sup_Red_F_unit: "Sup_Red_F_llist (LCons X LNil) = Red_F X"
using Sup_Red_F_llist_def enat_0_iff(1) by simp

lemma sup_red_f_in_red_liminf: "chain derive D \<Longrightarrow> Sup_Red_F_llist D \<subseteq> Red_F (Liminf_llist D)"
proof
  fix N
  assume
    deriv: "chain derive D" and
    n_in_sup: "N \<in> Sup_Red_F_llist D"
  obtain i0 where i_smaller: "enat i0 < llength D" and n_in: "N \<in> Red_F (lnth D i0)"
    using n_in_sup unfolding Sup_Red_F_llist_def by blast
  have "Red_F (lnth D i0) \<subseteq> Red_F (Liminf_llist D)"
    using i_smaller by (simp add: deriv Red_F_subset_Liminf)
  then show "N \<in> Red_F (Liminf_llist D)"
    using n_in by fast
qed

lemma sup_red_inf_in_red_liminf: "chain derive D \<Longrightarrow> Sup_Red_Inf_llist D \<subseteq> Red_Inf (Liminf_llist D)"
proof
  fix \<iota>
  assume
    deriv: "chain derive D" and
    i_in_sup: "\<iota> \<in> Sup_Red_Inf_llist D"
  obtain i0 where i_smaller: "enat i0 < llength D" and n_in: "\<iota> \<in> Red_Inf (lnth D i0)"
    using i_in_sup unfolding Sup_Red_Inf_llist_def by blast
  have "Red_Inf (lnth D i0) \<subseteq> Red_Inf (Liminf_llist D)"
    using i_smaller by (simp add: deriv Red_Inf_subset_Liminf)
  then show "\<iota> \<in> Red_Inf (Liminf_llist D)"
    using n_in by fast
qed

definition reduc_fair :: "'f set llist \<Rightarrow> bool" where
"reduc_fair D \<equiv> Inf_from (Liminf_llist D - (Sup_Red_F_llist D)) \<subseteq> Sup_Red_Inf_llist D"

(* lem:red-fairness-implies-red-saturation *)
lemma reduc_fair_imp_Liminf_reduc_sat: "chain derive D \<Longrightarrow> reduc_fair D \<Longrightarrow> reduc_saturated (Liminf_llist D)"
  unfolding reduc_saturated_def
proof -
  fix D
  assume
    deriv: "chain derive D" and
    red_fair: "reduc_fair D"
  have "Inf_from (Liminf_llist D - Red_F (Liminf_llist D)) \<subseteq> Inf_from (Liminf_llist D - Sup_Red_F_llist D)"
    using sup_red_f_in_red_liminf[OF deriv] unfolding Inf_from_def by blast
  then have "Inf_from (Liminf_llist D - Red_F (Liminf_llist D)) \<subseteq> Sup_Red_Inf_llist D"
    using red_fair unfolding reduc_fair_def by simp
  then show "Inf_from (Liminf_llist D - Red_F (Liminf_llist D)) \<subseteq> Red_Inf (Liminf_llist D)"
    using sup_red_inf_in_red_liminf[OF deriv] by fast
qed

end

locale reduc_dynamic_refutational_complete_calculus = calculus_with_red_crit +
  assumes
    reduc_dynamic_refutational_complete: "B \<in> Bot \<Longrightarrow> chain derive D \<Longrightarrow> reduc_fair D
      \<Longrightarrow> lnth D 0 \<Turnstile> {B} \<Longrightarrow> \<exists>i \<in> {i. enat i < llength D}. \<exists> B'\<in>Bot. B' \<in> lnth D i"
begin

sublocale reduc_static_refutational_complete_calculus
proof
  fix B N
  assume
    bot_elem: \<open>B \<in> Bot\<close> and
    saturated_N: "reduc_saturated N" and
    refut_N: "N \<Turnstile> {B}"
  define D where "D = LCons N LNil"
  have[simp]: \<open>\<not> lnull D\<close> by (auto simp: D_def)
  have deriv_D: \<open>chain (\<rhd>Red) D\<close> by (simp add: chain.chain_singleton D_def)
  have liminf_is_N: "Liminf_llist D = N" by (simp add: D_def Liminf_llist_LCons)
  have head_D: "N = lnth D 0" by (simp add: D_def)
  have "Sup_Red_F_llist D = Red_F N" by (simp add: D_def Sup_Red_F_unit)
  moreover have "Sup_Red_Inf_llist D = Red_Inf N" by (simp add: D_def Sup_Red_Inf_unit)
  ultimately have fair_D: "reduc_fair D"
    using saturated_N liminf_is_N unfolding reduc_fair_def reduc_saturated_def
    by (simp add: reduc_fair_def reduc_saturated_def liminf_is_N)
  obtain i B' where B'_is_bot: \<open>B' \<in> Bot\<close> and B'_in: "B' \<in> (lnth D i)" and \<open>i < llength D\<close>
    using reduc_dynamic_refutational_complete[of B D] bot_elem fair_D head_D saturated_N deriv_D refut_N
    by auto
  then have "i = 0"
    by (auto simp: D_def enat_0_iff)
  show \<open>\<exists>B'\<in>Bot. B' \<in> N\<close>
    using B'_is_bot B'_in unfolding \<open>i = 0\<close> head_D[symmetric] by auto
qed

end

sublocale reduc_static_refutational_complete_calculus \<subseteq> reduc_dynamic_refutational_complete_calculus
proof
  fix B D
  assume
    bot_elem: \<open>B \<in> Bot\<close> and
    deriv: \<open>chain (\<rhd>Red) D\<close> and
    fair: \<open>reduc_fair D\<close> and
    unsat: \<open>(lnth D 0) \<Turnstile> {B}\<close>
    have non_empty: \<open>\<not> lnull D\<close> using chain_not_lnull[OF deriv] .
    have subs: \<open>(lnth D 0) \<subseteq> Sup_llist D\<close>
      using lhd_subset_Sup_llist[of D] non_empty by (simp add: lhd_conv_lnth)
    have \<open>Sup_llist D \<Turnstile> {B}\<close>
      using unsat subset_entailed[OF subs] entails_trans[of "Sup_llist D" "lnth D 0"] by auto
    then have Sup_no_Red: \<open>Sup_llist D - Red_F (Sup_llist D) \<Turnstile> {B}\<close>
      using bot_elem Red_F_Bot by auto
    have Sup_no_Red_in_Liminf: \<open>Sup_llist D - Red_F (Sup_llist D) \<subseteq> Liminf_llist D\<close>
      using deriv Red_in_Sup by auto
    have Liminf_entails_Bot: \<open>Liminf_llist D \<Turnstile> {B}\<close>
      using Sup_no_Red subset_entailed[OF Sup_no_Red_in_Liminf] entails_trans by blast
    have \<open>reduc_saturated (Liminf_llist D)\<close>
    using deriv fair reduc_fair_imp_Liminf_reduc_sat unfolding reduc_saturated_def
      by auto
   then have \<open>\<exists>B'\<in>Bot. B' \<in> (Liminf_llist D)\<close>
     using bot_elem reduc_static_refutational_complete Liminf_entails_Bot
     by auto
   then show \<open>\<exists>i\<in>{i. enat i < llength D}. \<exists>B'\<in>Bot. B' \<in> lnth D i\<close>
     unfolding Liminf_llist_def by auto
qed

context calculus_with_red_crit
begin

lemma dyn_equiv_stat: "dynamic_refutational_complete_calculus Bot Inf entails Red_Inf Red_F =
  static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
proof
  assume "dynamic_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
  then interpret dynamic_refutational_complete_calculus Bot Inf entails Red_Inf Red_F
    by simp
  show "static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
    by (simp add: static_refutational_complete_calculus_axioms)
next
  assume "static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
  then interpret static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F
    by simp
  show "dynamic_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
    by (simp add: dynamic_refutational_complete_calculus_axioms)
qed

lemma red_dyn_equiv_red_stat: "reduc_dynamic_refutational_complete_calculus Bot Inf entails Red_Inf Red_F =
  reduc_static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
proof
  assume "reduc_dynamic_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
  then interpret reduc_dynamic_refutational_complete_calculus Bot Inf entails Red_Inf Red_F
    by simp
  show "reduc_static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
    by (simp add: reduc_static_refutational_complete_calculus_axioms)
next
  assume "reduc_static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
  then interpret reduc_static_refutational_complete_calculus Bot Inf entails Red_Inf Red_F
    by simp
  show "reduc_dynamic_refutational_complete_calculus Bot Inf entails Red_Inf Red_F"
    by (simp add: reduc_dynamic_refutational_complete_calculus_axioms)
qed

interpretation reduc_calc : calculus_with_reduced_red_crit Bot Inf entails Red_Red_Inf Red_F
using reduc_calc by simp

(* thm:reduced-dyn-ref-compl 1/3 (v) \<longleftrightarrow> (vii) *)
theorem dyn_ref_eq_dyn_ref_red: "dynamic_refutational_complete_calculus Bot Inf entails Red_Inf Red_F \<longleftrightarrow>
  dynamic_refutational_complete_calculus Bot Inf entails Red_Red_Inf Red_F"
  using dyn_equiv_stat stat_is_stat_red reduc_calc.dyn_equiv_stat by meson

(* thm:reduced-dyn-ref-compl 2/3 (viii) \<longleftrightarrow> (vii) *)
theorem red_dyn_ref_red_eq_dyn_ref_red: "reduc_dynamic_refutational_complete_calculus Bot Inf
  entails Red_Red_Inf Red_F \<longleftrightarrow>
  dynamic_refutational_complete_calculus Bot Inf entails Red_Red_Inf Red_F"
  using red_dyn_equiv_red_stat dyn_equiv_stat red_stat_red_is_stat_red
  by (simp add: reduc_calc.dyn_equiv_stat reduc_calc.red_dyn_equiv_red_stat)

(* thm:reduced-dyn-ref-compl 3/3 (vi) \<longleftrightarrow> (vii) *)
theorem red_dyn_ref_eq_dyn_ref_red: "reduc_dynamic_refutational_complete_calculus Bot Inf entails Red_Inf Red_F \<longleftrightarrow>
  dynamic_refutational_complete_calculus Bot Inf entails Red_Red_Inf Red_F"
  using red_dyn_equiv_red_stat dyn_equiv_stat red_stat_is_stat_red
    reduc_calc.dyn_equiv_stat reduc_calc.red_dyn_equiv_red_stat
  by blast

end

end


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

subsection \<open> Measure as QBS Measure\<close>
theory Measure_as_QuasiBorel_Measure
  imports "Pair_QuasiBorel_Measure"

begin

lemma distr_id':
  assumes "sets N = sets M"
          "f \<in> N \<rightarrow>\<^sub>M N"
      and "\<And>x. x \<in> space N \<Longrightarrow> f x = x"
    shows "distr N M f = N"
proof(rule measure_eqI)
  fix A
  assume 0:"A \<in> sets (distr N M f)"
  then have 1:"A \<subseteq> space N"
    by (auto simp: assms(1) sets.sets_into_space)

  have 2:"A \<in> sets M"
    using 0 by simp
  have 3:"f \<in> N \<rightarrow>\<^sub>M M"
    using assms(2) by(simp add: measurable_cong_sets[OF _ assms(1)])
  have "f -` A \<inter> space N = A"
  proof -
    have "f -` A = A \<union> {x. x \<notin> space N \<and> f x \<in> A}"
    proof(standard;standard)
      fix x
      assume h:"x \<in> f -` A"
      consider "x \<in> A" | "x \<notin> A"
        by auto
      thus "x \<in> A \<union> {x. x \<notin> space N \<and> f x \<in> A}"
      proof cases
        case 1
        then show ?thesis
          by simp
      next
        case 2
        have "x \<notin> space N"
        proof(rule ccontr)
          assume "\<not> x \<notin> space N"
          then have "x \<in> space N"
            by simp
          hence "f x = x"
            by(simp add: assms(3))
          hence "f x \<notin> A"
            by(simp add: 2)
          thus False
            using h by simp
        qed
        thus ?thesis
          using h by simp
      qed
    next
      fix x
      show "x \<in> A \<union> {x. x \<notin> space N \<and> f x \<in> A} \<Longrightarrow> x \<in> f -` A"
        using 1 assms by auto
    qed
    thus ?thesis
      using "1" by blast
  qed
  thus "emeasure (distr N M f) A = emeasure N A"
    by(simp add: emeasure_distr[OF 3 2])
qed (simp add: assms(1))

text \<open> Every probability measure on a standard Borel space can be represented as a measure on
       a quasi-Borel space~\<^cite>\<open>"Heunen_2017"\<close>, Proposition 23.\<close>
locale standard_borel_prob_space = standard_borel P + p:prob_space P
  for P :: "'a measure"
begin

sublocale qbs_prob "measure_to_qbs P" g "distr P real_borel f"
  by(auto intro!: qbs_probI p.prob_space_distr)

lift_definition as_qbs_measure :: "'a qbs_prob_space" is
"(measure_to_qbs P, g, distr P real_borel f)"
  by simp

lemma as_qbs_measure_retract:
  assumes [measurable]:"a \<in> P \<rightarrow>\<^sub>M real_borel"
      and [measurable]:"b \<in> real_borel \<rightarrow>\<^sub>M P"
      and [simp]:"\<And>x. x \<in> space P \<Longrightarrow> (b \<circ> a) x = x"
    shows "qbs_prob (measure_to_qbs P) b (distr P real_borel a)"
          "as_qbs_measure = qbs_prob_space (measure_to_qbs P, b, distr P real_borel a)"
proof -
  interpret pqp: pair_qbs_prob "measure_to_qbs P" g "distr P real_borel f" "measure_to_qbs P" b "distr P real_borel a"
    by(auto intro!: qbs_probI p.prob_space_distr simp: pair_qbs_prob_def)
  show "qbs_prob (measure_to_qbs P) b (distr P real_borel a)"
       "as_qbs_measure = qbs_prob_space (measure_to_qbs P, b, distr P real_borel a)"
    by(auto intro!: pqp.qbs_prob_space_eq
          simp: distr_distr distr_id'[OF standard_borel_lr_sets_ident[symmetric]] distr_id'[OF standard_borel_lr_sets_ident[symmetric] _ assms(3)] pqp.qp2.qbs_prob_axioms as_qbs_measure.abs_eq)
qed

lemma measure_as_qbs_measure_qbs:
 "qbs_prob_space_qbs as_qbs_measure = measure_to_qbs P"
  by transfer auto

lemma measure_as_qbs_measure_image:
 "as_qbs_measure \<in> monadP_qbs_Px (measure_to_qbs P)"
  by(auto simp: measure_as_qbs_measure_qbs monadP_qbs_Px_def)

lemma as_qbs_measure_as_measure[simp]:
 "distr (distr P real_borel f) (qbs_to_measure (measure_to_qbs P)) g = P"
  by(auto intro!: distr_id'[OF standard_borel_lr_sets_ident[symmetric]] simp : qbs_prob_t_measure_def distr_distr )

lemma measure_as_qbs_measure_recover:
 "qbs_prob_measure as_qbs_measure = P"
  by transfer (simp add: qbs_prob_t_measure_def)

end

lemma(in standard_borel) qbs_prob_measure_recover:
  assumes "q \<in> monadP_qbs_Px (measure_to_qbs M)"
  shows "standard_borel_prob_space.as_qbs_measure (qbs_prob_measure q) = q"
proof -
  obtain \<alpha> \<mu> where hq:
  "q = qbs_prob_space (measure_to_qbs M, \<alpha>, \<mu>)" "qbs_prob (measure_to_qbs M) \<alpha> \<mu>"
    using rep_monadP_qbs_Px[OF assms] by auto
  then interpret qp: qbs_prob "measure_to_qbs M" \<alpha> \<mu> by simp
  interpret sp: standard_borel_prob_space "distr \<mu> (qbs_to_measure (measure_to_qbs M)) \<alpha>"
    using qp.in_Mx
    by(auto intro!: prob_space.prob_space_distr
           simp: standard_borel_prob_space_def standard_borel_sets[OF sets_distr[of \<mu> "qbs_to_measure (measure_to_qbs M)" \<alpha>,simplified standard_borel_lr_sets_ident,symmetric]])
  interpret st: standard_borel "distr \<mu> M \<alpha>"
    by(auto intro!: standard_borel_sets)
  have [measurable]:"st.g \<in> real_borel \<rightarrow>\<^sub>M M"
    using measurable_distr_eq2 st.g_meas by blast
  show ?thesis
    by(auto intro!: pair_qbs_prob.qbs_prob_space_eq
          simp add: hq(1) sp.as_qbs_measure.abs_eq pair_qbs_prob_def qp.qbs_prob_axioms sp.qbs_prob_axioms)
     (simp_all add: measure_to_qbs_cong_sets[OF sets_distr[of \<mu> "qbs_to_measure (measure_to_qbs M)" \<alpha>,simplified standard_borel_lr_sets_ident]])
qed

lemma(in standard_borel_prob_space) ennintegral_as_qbs_ennintegral:
  assumes "k \<in> borel_measurable P"
  shows "(\<integral>\<^sup>+\<^sub>Q x. k x \<partial>as_qbs_measure) = (\<integral>\<^sup>+ x. k x \<partial>P)"
proof -
  have 1:"k \<in> measure_to_qbs P \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    using assms by auto
  thus ?thesis
    by(simp add: as_qbs_measure.abs_eq qbs_prob_ennintegral_def2[OF 1])
qed

lemma(in standard_borel_prob_space) integral_as_qbs_integral:
 "(\<integral>\<^sub>Q x. k x \<partial>as_qbs_measure) = (\<integral> x. k x \<partial>P)"
  by(simp add: as_qbs_measure.abs_eq qbs_prob_integral_def2)

lemma(in standard_borel) measure_with_args_morphism:
  assumes [measurable]:"\<mu> \<in> X \<rightarrow>\<^sub>M prob_algebra M"
  shows "standard_borel_prob_space.as_qbs_measure \<circ> \<mu> \<in> measure_to_qbs X \<rightarrow>\<^sub>Q monadP_qbs (measure_to_qbs M)"
proof(auto intro!: qbs_morphismI)
  fix \<alpha>
  assume h[measurable]:"\<alpha> \<in> real_borel \<rightarrow>\<^sub>M X"
  have "\<forall>r. (standard_borel_prob_space.as_qbs_measure \<circ> \<mu> \<circ> \<alpha>) r = qbs_prob_space (measure_to_qbs M, g, ((\<lambda>l. distr (\<mu> l) real_borel f) \<circ> \<alpha>) r)"
  proof auto
    fix r
    interpret sp: standard_borel_prob_space "\<mu> (\<alpha> r)"
      using measurable_space[OF assms measurable_space[OF h]]
      by(simp add: standard_borel_prob_space_def space_prob_algebra)
    have 1[measurable_cong]: "sets (\<mu> (\<alpha> r)) = sets M"
      using measurable_space[OF assms measurable_space[OF h]] by(simp add: space_prob_algebra)
    have 2:"f \<in> \<mu> (\<alpha> r) \<rightarrow>\<^sub>M real_borel" "g \<in> real_borel \<rightarrow>\<^sub>M \<mu> (\<alpha> r)" "\<And>x. x \<in> space (\<mu> (\<alpha> r)) \<Longrightarrow> (g \<circ> f) x = x"
      using measurable_space[OF assms measurable_space[OF h]]
      by(simp_all add: standard_borel_prob_space_def sets_eq_imp_space_eq[OF 1])
    show "standard_borel_prob_space.as_qbs_measure (\<mu> (\<alpha> r)) = qbs_prob_space (measure_to_qbs M, g, distr (\<mu> (\<alpha> r)) real_borel f)"
      by(simp add: sp.as_qbs_measure_retract[OF 2] measure_to_qbs_cong_sets[OF  subprob_measurableD(2)[OF measurable_prob_algebraD[OF assms] measurable_space[OF h]]])
  qed
  thus "standard_borel_prob_space.as_qbs_measure \<circ> \<mu> \<circ> \<alpha> \<in> monadP_qbs_MPx (measure_to_qbs M)"
    by(auto intro!: bexI[where x=g] bexI[where x="(\<lambda>l. distr (\<mu> l) real_borel f) \<circ> \<alpha>"] simp: monadP_qbs_MPx_def in_MPx_def)
qed

lemma(in standard_borel) measure_with_args_recover:
  assumes "\<mu> \<in> space X \<rightarrow> space (prob_algebra M)"
      and "x \<in> space X"
    shows "qbs_prob_measure (standard_borel_prob_space.as_qbs_measure (\<mu> x)) = \<mu> x"
    using standard_borel_sets[of "\<mu> x"] funcset_mem[OF assms]
    by(simp add: standard_borel_prob_space_def space_prob_algebra standard_borel_prob_space.measure_as_qbs_measure_recover)

subsection \<open>Example of Probability Measures\<close>
text \<open>Probability measures on $\mathbb{R}$ can be represented as probability measures on the quasi-Borel space $\mathbb{R}$.\<close>
subsubsection \<open> Normal Distribution \<close>
definition normal_distribution :: "real \<times> real \<Rightarrow> real measure" where
"normal_distribution \<mu>\<sigma> = (if 0 < (snd \<mu>\<sigma>) then density lborel (\<lambda>x. ennreal (normal_density (fst \<mu>\<sigma>) (snd \<mu>\<sigma>) x))
                                      else return lborel 0)"

lemma normal_distribution_measurable:
 "normal_distribution \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G=borel])
  fix A :: "real set"
  assume h:"A \<in> sets borel"
  have "(\<lambda>x. emeasure (normal_distribution x) A) = (\<lambda>x. if 0 < (snd x) then emeasure (density lborel (\<lambda>r. ennreal (normal_density (fst x) (snd x) r))) A
                                                                                else emeasure (return lborel 0) A)"
    by(auto simp add: normal_distribution_def)
  also have "... \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)"
  proof(rule measurable_If)
    have [simp]:"(\<lambda>x. indicat_real A (snd x)) \<in> borel_measurable ((borel \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M borel)"
    proof -
      have "(\<lambda>x. indicat_real A (snd x)) = indicat_real A \<circ> snd"
        by auto
      also have "... \<in> borel_measurable ((borel \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M borel)"
        by (meson borel_measurable_indicator h measurable_comp measurable_snd)
      finally show ?thesis .
    qed
    have "(\<lambda>x. emeasure (density lborel (\<lambda>r. ennreal (normal_density (fst x) (snd x) r))) A) = (\<lambda>x. set_nn_integral lborel A (\<lambda>r. ennreal (normal_density (fst x) (snd x) r)))"
      using h by(auto intro!: emeasure_density)
    also have "... = (\<lambda>x. \<integral>\<^sup>+r. ennreal (normal_density (fst x) (snd x) r * indicat_real A r)\<partial>lborel)"
      by(simp add: nn_integral_set_ennreal)
    also have "... \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)"
      apply(auto intro!: lborel.borel_measurable_nn_integral
                   simp: split_beta' measurable_cong_sets[OF sets_pair_measure_cong[OF refl sets_lborel]] )
      unfolding normal_density_def
      by(rule borel_measurable_times) simp_all
    finally show "(\<lambda>x. emeasure (density lborel (\<lambda>r. ennreal (normal_density (fst x) (snd x) r))) A) \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)" .
  qed simp_all
  finally show "(\<lambda>x. emeasure (normal_distribution x) A) \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)" .
qed (auto simp add: sets.sigma_sets_eq[of borel,simplified] sets.Int_stable prob_space_normal_density normal_distribution_def prob_space_return)

definition qbs_normal_distribution :: "real \<Rightarrow> real \<Rightarrow> real qbs_prob_space" where
"qbs_normal_distribution \<equiv> curry (standard_borel_prob_space.as_qbs_measure \<circ> normal_distribution)"

lemma qbs_normal_distribution_morphism:
 "qbs_normal_distribution \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<real>\<^sub>Q (monadP_qbs \<real>\<^sub>Q)"
  unfolding qbs_normal_distribution_def
  by(rule curry_preserves_morphisms[OF real.measure_with_args_morphism[OF normal_distribution_measurable,simplified r_preserves_product]])

context
  fixes \<mu> \<sigma> :: real
  assumes sigma:"\<sigma> > 0"
begin

interpretation n_dist:standard_borel_prob_space "normal_distribution (\<mu>,\<sigma>)"
  by(simp add: standard_borel_prob_space_def sigma prob_space_normal_density normal_distribution_def)

lemma qbs_normal_distribution_def2:
 "qbs_normal_distribution \<mu> \<sigma> = n_dist.as_qbs_measure"
  by(simp add: qbs_normal_distribution_def)

lemma qbs_normal_distribution_integral:
 "(\<integral>\<^sub>Q x. f x \<partial> (qbs_normal_distribution \<mu> \<sigma>)) = (\<integral> x. f x \<partial> (density lborel (\<lambda>x. ennreal (normal_density \<mu> \<sigma> x))))"
  by(simp add: qbs_normal_distribution_def2 n_dist.integral_as_qbs_integral)
    (simp add: normal_distribution_def sigma)

lemma qbs_normal_distribution_expectation:
  assumes "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
    shows "(\<integral>\<^sub>Q x. f x \<partial> (qbs_normal_distribution \<mu> \<sigma>)) = (\<integral> x. normal_density \<mu> \<sigma> x * f x \<partial> lborel)"
  by(simp add: qbs_normal_distribution_integral assms integral_real_density integral_density)

end

subsubsection \<open> Uniform Distribution \<close>
definition interval_uniform_distribution :: "real \<Rightarrow> real \<Rightarrow> real measure" where
"interval_uniform_distribution a b \<equiv> (if a < b then uniform_measure lborel {a<..<b}
                                               else return lborel 0)"

lemma sets_interval_uniform_distribution[measurable_cong]:
 "sets (interval_uniform_distribution a b) = borel"
  by(simp add: interval_uniform_distribution_def)

lemma interval_uniform_distribution_meaurable:
 "(\<lambda>r. interval_uniform_distribution (fst r) (snd r)) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G="range (\<lambda>(a, b). {a<..<b})"])
  show "sets real_borel = sigma_sets UNIV (range (\<lambda>(a, b). {a<..<b}))"
    by(simp add: borel_eq_box)
next
  show "Int_stable (range (\<lambda>(a, b). {a<..<b::real}))"
    by(fastforce intro!: Int_stableI simp: split_beta' image_iff)
next
  show "range (\<lambda>(a, b). {a<..<b}) \<subseteq> Pow UNIV"
    by simp
next
  fix a
  show "prob_space (interval_uniform_distribution (fst a) (snd a))"
    by(simp add: interval_uniform_distribution_def prob_space_return prob_space_uniform_measure)
next
  fix a
  show " sets (interval_uniform_distribution (fst a) (snd a)) = sets real_borel"
    by(simp add: interval_uniform_distribution_def)
next
  fix A
  assume "A \<in> range (\<lambda>(a, b). {a<..<b::real})"
  then obtain a b where ha:"A = {a<..<b}" by auto
  consider  "b \<le> a" | "a < b" by fastforce
  then show "(\<lambda>x. emeasure (interval_uniform_distribution (fst x) (snd x)) A) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M ennreal_borel"
             (is "?f \<in> ?meas")
  proof cases
    case 1
    then show ?thesis
      by(simp add: ha)
  next
    case h2:2
    have "?f = (\<lambda>x. if fst x < snd x then ennreal (min (snd x) b - max (fst x) a) / ennreal (snd x - fst x) else indicator A 0)"
    proof(standard; auto simp: interval_uniform_distribution_def ha)
      fix x y :: real
      assume hxy:"x < y"
      consider "b \<le> x" | "a \<le> x \<and> x < b" | "x < a \<and> a < y" | "y \<le> a"
        using h2 by fastforce
      thus "emeasure lborel ({max x a<..<min y b}) / ennreal (y - x) = ennreal (min y b - max x a) / ennreal (y - x)"
        by cases (use hxy ennreal_neg h2 in auto)
    qed
    also have "... \<in> ?meas"
      by simp
    finally show ?thesis .
  qed
qed

definition qbs_interval_uniform_distribution :: "real \<Rightarrow> real \<Rightarrow> real qbs_prob_space" where
"qbs_interval_uniform_distribution \<equiv> curry (standard_borel_prob_space.as_qbs_measure \<circ> (\<lambda>r. interval_uniform_distribution (fst r) (snd r)))"

lemma qbs_interval_uniform_distribution_morphism:
 "qbs_interval_uniform_distribution \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<real>\<^sub>Q (monadP_qbs \<real>\<^sub>Q)"
  unfolding qbs_interval_uniform_distribution_def
  using curry_preserves_morphisms[OF real.measure_with_args_morphism[OF interval_uniform_distribution_meaurable,simplified r_preserves_product]] .

context
  fixes a b :: real
  assumes a_less_than_b:"a < b"
begin

definition "ab_qbs_uniform_distribution \<equiv> qbs_interval_uniform_distribution a b"

interpretation ab_u_dist: standard_borel_prob_space "interval_uniform_distribution a b"
  by(auto intro!: prob_space_uniform_measure simp: interval_uniform_distribution_def standard_borel_prob_space_def prob_space_return)

lemma qbs_interval_uniform_distribution_def2:
 "ab_qbs_uniform_distribution = ab_u_dist.as_qbs_measure"
  by(simp add: qbs_interval_uniform_distribution_def ab_qbs_uniform_distribution_def)

lemma qbs_uniform_distribution_expectation:
  assumes "f \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  shows "(\<integral>\<^sup>+\<^sub>Q x. f x \<partial>ab_qbs_uniform_distribution) = (\<integral>\<^sup>+x \<in> {a<..<b}. f x \<partial>lborel) / (b - a)"
        (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<integral>\<^sup>+x. f x \<partial>(interval_uniform_distribution a b))"
    using assms by(auto simp: qbs_interval_uniform_distribution_def2 intro!:ab_u_dist.ennintegral_as_qbs_ennintegral dest:ab_u_dist.qbs_morphism_dest[simplified measure_to_qbs_cong_sets[OF sets_interval_uniform_distribution]])
  also have "... = ?rhs"
    using assms
    by(auto simp: interval_uniform_distribution_def a_less_than_b intro!:nn_integral_uniform_measure[where M=lborel and S="{a<..<b}",simplified emeasure_lborel_Ioo[OF order.strict_implies_order[OF a_less_than_b]]])
  finally show ?thesis .
qed

end

subsubsection \<open> Bernoulli Distribution \<close>
definition qbs_bernoulli :: "real \<Rightarrow> bool qbs_prob_space" where
"qbs_bernoulli \<equiv> standard_borel_prob_space.as_qbs_measure \<circ> (\<lambda>x. measure_pmf (bernoulli_pmf x))"

lemma bernoulli_measurable:
 "(\<lambda>x. measure_pmf (bernoulli_pmf x)) \<in> real_borel \<rightarrow>\<^sub>M prob_algebra bool_borel"
proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G=UNIV],simp_all)
  fix A :: "bool set"
  have "A \<subseteq> {True,False}"
    by auto
  then consider "A = {}" | "A = {True}" | "A = {False}" | "A = {False,True}"
    by auto
  thus "(\<lambda>a. emeasure (measure_pmf (bernoulli_pmf a)) A) \<in> borel_measurable borel"
    by(cases,simp_all add: emeasure_measure_pmf_finite bernoulli_pmf.rep_eq UNIV_bool[symmetric])
qed (auto simp add: sets_borel_eq_count_space Int_stable_def measure_pmf.prob_space_axioms)

lemma qbs_bernoulli_morphism:
 "qbs_bernoulli \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q monadP_qbs \<bool>\<^sub>Q"
  using bool.measure_with_args_morphism[OF bernoulli_measurable]
  by (simp add: qbs_bernoulli_def)

lemma qbs_bernoulli_measure:
 "qbs_prob_measure (qbs_bernoulli p) = measure_pmf (bernoulli_pmf p)"
  using bool.measure_with_args_recover[of "\<lambda>x. measure_pmf (bernoulli_pmf x)" real_borel p] bernoulli_measurable
  by(simp add: measurable_def qbs_bernoulli_def)

context
  fixes p :: real
  assumes pgeq_0[simp]:"0 \<le> p" and pleq_1[simp]:"p \<le> 1"
begin

lemma qbs_bernoulli_expectation:
  "(\<integral>\<^sub>Q x. f x \<partial>qbs_bernoulli p) = f True * p + f False * (1 - p)"
  by(simp add: qbs_prob_integral_def2 qbs_bernoulli_measure)

end

end


section \<open> Weakest Preconditions \<close>

theory ITree_WP
  imports ITree_Relation
begin

named_theorems wp

definition wp_itree :: "('e, 'a, 'b) ktree \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" where
"wp_itree S P = (\<lambda>s. \<exists> s'. (s, s') \<in> itree_rel S \<and> P s')"

definition wlp_itree :: "('e, 'a, 'b) ktree \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" where
"wlp_itree S P = (\<lambda>s. \<forall>s'. (s, s') \<in> itree_rel S \<longrightarrow> P s')"

expr_constructor wlp_itree wp_itree

syntax
  "_wp"  :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("wp")
  "_wlp" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("wlp")

translations
  "_wp S P" == "CONST wp_itree S (P)\<^sub>e"
  "_wp S" == "CONST wp_itree S"
  "_wlp S P" == "CONST wlp_itree S (P)\<^sub>e"
  "_wlp S" == "CONST wlp_itree S"

lemma wlp_alt_def: "wlp S P = (\<lambda> s. \<forall> tr s'. S(s) \<midarrow>tr\<leadsto> \<checkmark> s' \<longrightarrow> P s')"
  by (auto simp add: wlp_itree_def itree_rel_def itree_pred_def retvals_def fun_eq_iff)

lemma wp_alt_def: "wp S P = (\<lambda> s. \<exists> tr s'. S(s) \<midarrow>tr\<leadsto> \<checkmark> s' \<and> P s')"
  by (auto simp add: wp_itree_def itree_rel_def itree_pred_def retvals_def fun_eq_iff)

abbreviation "pre P \<equiv> wp P True"

text \<open> The precondition corresponds to termination \<close>

lemma pre_terminates: "pre P = (terminates P)\<^sub>e"
  unfolding wp_alt_def by (auto simp add: SEXP_def terminates_def)

expr_constructor pre

lemma wp_Skip [wp]: "wp Skip P = P"
  by (expr_simp add: wp_itree_def Skip_rel)

lemma wlp_Skip [wp]: "wlp Skip P = P"
  by (expr_simp add: wlp_itree_def Skip_rel)

lemma wp_Skip' [wp]: "wp Skip = id"
  by (expr_simp add: wp_itree_def Skip_rel)

lemma wp_assigns [wp]: "wp \<langle>\<sigma>\<rangle>\<^sub>a P = (\<sigma> \<dagger> (P)\<^sub>e)"
  by (expr_simp add: wp_itree_def assigns_rel)

lemma wlp_assigns [wp]: "wlp \<langle>\<sigma>\<rangle>\<^sub>a P = (\<sigma> \<dagger> (P)\<^sub>e)"
  by (expr_simp add: wlp_itree_def assigns_rel)

lemma wlp_assign: "wlp (x := e) P = (P)\<^sub>e\<lbrakk>e/x\<rbrakk>"
  by (simp add: wlp_assigns)

lemma wp_assume [wp]: "wp (assume S) P = (S \<and> P)\<^sub>e"
  by (simp add: wp_itree_def assume_rel, expr_auto)

lemma wlp_assert [wp]: "wlp (assume S) P = (S \<longrightarrow> P)\<^sub>e"
  by (simp add: wlp_itree_def assume_rel, expr_simp)

lemma wp_test [wp]: "wp (test S) P = (S \<and> P)\<^sub>e"
  by (simp add: wp_itree_def test_rel, expr_simp)

lemma wlp_test [wp]: "wlp (test S) P = (S \<longrightarrow> P)\<^sub>e"
  by (simp add: wlp_itree_def test_rel, expr_simp)

lemma wp_seq [wp]: "wp (S ;; R) P = wp S (wp R P)"
  by (auto simp add: wp_itree_def seq_rel)

lemma wp_seq': "wp (S ;; R) = wp S \<circ> wp R"
  by (auto simp add: wp_itree_def seq_rel fun_eq_iff)

lemma wp_foldr_seq: "wp (foldr (\<lambda> i D. C i ;; D) xs Skip) = foldr (\<lambda> i Q. wp (C i) \<circ> Q) xs id"
  by (induct xs, simp_all add: wp_Skip' wp_seq')

lemma wp_foldr_seq_term:
  assumes "\<And> x. pre (C x) = (True)\<^sub>e"
  shows "pre (foldr (\<lambda> i D. C i ;; D) xs Skip) = (True)\<^sub>e"
  using assms by (induct xs, simp_all add: wp_Skip' wp_seq')

lemma wlp_seq [wp]: "wlp (S ;; R) P = wlp S (wlp R P)"
  by (auto simp add: wlp_itree_def seq_rel)

lemma wp_cond [wp]: "wp (if B then C\<^sub>1 else C\<^sub>2 fi) P = ((B \<longrightarrow> wp C\<^sub>1 P) \<and> (\<not> B \<longrightarrow> wp C\<^sub>2 P))\<^sub>e"
  by (auto simp add: wp_itree_def cond_rel fun_eq_iff)

lemma wlp_cond [wp]: "wlp (if B then C\<^sub>1 else C\<^sub>2 fi) P = ((B \<longrightarrow> wlp C\<^sub>1 P) \<and> (\<not> B \<longrightarrow> wlp C\<^sub>2 P))\<^sub>e"
  by (auto simp add: wlp_itree_def cond_rel fun_eq_iff)

lemma wlp_let [wp]: "wlp (let x \<leftarrow> e in S x) b = (wlp (S (e \<s>)) b)\<^sub>e"
  by (auto simp add: wlp_itree_def let_itree_def itree_rel_defs retvals_def SEXP_def)

lemma wlp_true [wp]: "wlp P True = (True)\<^sub>e"
  by (expr_simp add: wlp_itree_def)

lemma wp_Div [wp]: "wp Div P = (False)\<^sub>e"
  by (simp add: wp_itree_def Div_rel, expr_simp)

lemma wlp_Div [wp]: "wlp Div P = (True)\<^sub>e"
  by (simp add: wlp_itree_def Div_rel, expr_simp)

lemma wp_Stop [wp]: "wp Stop P = (False)\<^sub>e"
  by (simp add: wp_itree_def Stop_rel, expr_simp)

lemma wlp_Stop [wp]: "wlp Stop P = (True)\<^sub>e"
  by (simp add: wlp_itree_def Stop_rel, expr_simp)

lemma wp_input_in_where [wp]:
  "wb_prism c \<Longrightarrow> wp_itree (input_in_where c A S) P = [\<lambda> s. \<exists> v\<in>A s. fst (S v) s \<and> wp_itree (snd (S v)) P s]\<^sub>e"
  by (auto simp add: wp_itree_def itree_rel fun_eq_iff)

lemma wlp_input_in_where [wp]:
  "wb_prism c \<Longrightarrow> wlp_itree (input_in_where c A S) P = [\<lambda> s. \<forall> v\<in>A s. fst (S v) s \<longrightarrow> wlp_itree (snd (S v)) P s]\<^sub>e"
  by (auto simp add: wlp_itree_def itree_rel fun_eq_iff)

method wp uses add = (simp add: prog_defs wp usubst_eval add)

end