section \<open>Liberation\<close>

theory Liberation
  imports Main  "~~/src/HOL/Library/Lattice_Syntax"

begin

notation times (infixl "\<cdot>" 70)

locale cylindric_algebra =
  fixes cyl :: "'a \<Rightarrow> 'b::boolean_algebra \<Rightarrow> 'b::boolean_algebra"
  and dia :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  assumes c1 [simp]: "cyl i \<bottom> = \<bottom>"
  and c2: "x \<le> cyl i x"
  and c3: "cyl i (x \<sqinter> cyl i y) = cyl i x \<sqinter> cyl i y"
  and c4: "cyl i (cyl j x) = cyl j (cyl i x)"
  and c5 [simp]: "dia i i = \<top>"
  and c6: "i \<noteq> j \<Longrightarrow> i \<noteq> k \<Longrightarrow> d j k = cyl i (dia j i \<sqinter> dia i k)"
  and c7: "i \<noteq> j \<Longrightarrow> cyl i (dia i j \<sqinter> x) \<sqinter> cyl i (dia i j \<sqinter> -x) = \<bottom>"

begin

lemma cyl_idem [simp]: "cyl i (cyl i x) = cyl i x"
  by (metis c2 c3 inf_top.left_neutral top.extremum_uniqueI)

lemma c3_var [simp]: "cyl i (cyl i x \<sqinter> cyl i y) = cyl i x \<sqinter> cyl i y"
  by (simp add: c3)

lemma cyl_iso: "x \<le> y \<Longrightarrow> cyl i x \<le> cyl i y"
  by (metis c2 c3 inf.order_iff le_infI2)

lemma cyl_top [simp]: "cyl i \<top> = \<top>"
  by (simp add: antisym c2)

lemma cyl_very_strict: "(cyl i x = \<bottom>) = (x = \<bottom>)"
  by (metis bot.extremum_unique c1 c2)

lemma cyl_conjugate: "(cyl i x \<sqinter> y = \<bottom>) = (x \<sqinter> cyl i y = \<bottom>)"
  by (metis c3 cyl_very_strict inf_aci(1))

lemma cyl_compl1 [simp]: "cyl i (-cyl i x) = -cyl i x"
  by (metis c2 compl_unique cyl_conjugate cyl_idem inf_compl_bot le_iff_sup sup_compl_top_left2)

lemma cyl_compl2: "(cyl i x = x) = (cyl i (-x) = -x)"
  by (metis cyl_compl1 double_compl)

lemma cyl_join_pres_aux [simp]: "cyl i (cyl i x \<squnion> cyl i y) = cyl i x \<squnion> cyl i y"
  by (metis (no_types, lifting) c3 compl_sup cyl_compl1 cyl_compl2)

lemma cyl_join_pres: "cyl i (x \<squnion> y) = cyl i x \<squnion> cyl i y"
  by (smt c2 c3 cyl_join_pres_aux inf.order_iff inf_aci(1) inf_aci(2) inf_sup_distrib2 sup_ge1 sup_ge2)

lemma "i \<noteq> j \<Longrightarrow> cyl i x \<noteq> cyl j x"
  (*nitpick*)
  oops

lemma cyl_dia1: "i \<noteq> j \<Longrightarrow> i \<noteq> k \<Longrightarrow> cyl i (dia j k) = dia j k"
  by (simp add: c6)

lemma dia_sym_var: "i \<noteq> j \<Longrightarrow> dia i j = dia j i"
  by (smt c5 c6 compl_bot_eq compl_inf compl_unique cylindric_algebra.c7 cylindric_algebra.cyl_very_strict cylindric_algebra_axioms double_compl inf_sup_aci(1) inf_top.monoid_axioms monoid.right_neutral)

lemma dia_sym: "dia i j = dia j i"
  using dia_sym_var by force

lemma dia_cyl_top [simp]: "cyl i (dia i j) = \<top>"
  by (metis (mono_tags, hide_lams) c5 c6 cyl_top dia_sym inf.idem)

lemma dia_meet1: "i \<noteq> j \<Longrightarrow> dia i j \<sqinter> cyl i (dia i j \<sqinter> x) \<le> x"
proof-
  assume "i \<noteq> j"
  hence "cyl i (dia i j \<sqinter> x) \<sqinter> cyl i (dia i j \<sqinter> -x) = \<bottom>"
    by (simp add: c7)
  hence "cyl i (cyl i (dia i j \<sqinter> x)) \<sqinter> dia i j \<sqinter> -x = \<bottom>"
    by (simp add: cyl_conjugate inf_assoc)
  hence "cyl i (dia i j \<sqinter> x) \<sqinter> dia i j \<sqinter> -x = \<bottom>"
    by (simp add: cyl_idem)
  thus ?thesis
    by (smt abel_semigroup.commute inf.abel_semigroup_axioms inf.absorb_iff2 inf_compl_bot_right inf_sup_distrib1 inf_top.right_neutral sup_compl_top sup_inf_absorb)
qed

lemma dia_meet2: "i \<noteq> j \<Longrightarrow> cyl i (dia i j \<sqinter> x \<sqinter> y) = cyl i (dia i j \<sqinter> x) \<sqinter> cyl i (dia i j \<sqinter> y)"
  by (smt c2 c3 dia_meet1 inf.order_iff inf_aci(1) inf_aci(2))

definition subst :: "'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b" where
  "subst i j x = (if i = j then x else cyl i (dia i j \<sqinter> x))"

lemma subst_join: "subst i j (x \<squnion> y) = subst i j x \<squnion> subst i j y"
  by (simp add: cyl_join_pres inf_sup_distrib1 subst_def)

lemma subst_compl: "- (subst i j x) = subst i j (-x)"
  by (smt c7 compl_inf_bot compl_sup_top compl_unique cyl_join_pres dia_cyl_top inf_commute inf_sup_distrib2 inf_top.right_neutral subst_def)

lemma subst_top [simp]: "subst i j \<top> = \<top>"
  by (simp add: subst_def)

lemma subst_meet_var: "i \<noteq> j \<Longrightarrow> subst i j (x \<sqinter> y) = subst i j x \<sqinter> subst i j y"
  by (metis (no_types, lifting) dia_meet2 inf.assoc subst_def)

lemma subst_meet: "subst i j (x \<sqinter> y) = subst i j x \<sqinter> subst i j y"
  by (metis (no_types, lifting) dia_meet2 inf_assoc subst_def)

lemma subst_dia: "i \<noteq> k \<Longrightarrow> subst i j (dia i k) = dia j k"
  by (simp add: c6 dia_sym subst_def)

lemma subst_dia2: "i \<noteq> k \<Longrightarrow> i \<noteq> l \<Longrightarrow> subst i j (dia k l) = dia k l"
  by (simp add: c3 c6 subst_def)

lemma subst_dia_meet: "i \<noteq> j \<Longrightarrow> i \<noteq> k \<Longrightarrow> i \<noteq> l \<Longrightarrow> i \<noteq> m \<Longrightarrow> j \<noteq> k \<Longrightarrow> j \<noteq> l \<Longrightarrow> j \<noteq> m \<Longrightarrow> k \<noteq> l \<Longrightarrow> k \<noteq> m \<Longrightarrow> l \<noteq> m \<Longrightarrow> subst i j (dia i k \<sqinter> dia l m) = dia j k \<sqinter> dia l m"
proof -
  assume a1: "i \<noteq> j"
assume a2: "i \<noteq> k"
assume a3: "l \<noteq> m"
assume a4: "i \<noteq> l"
assume a5: "i \<noteq> m"
have f6: "\<forall>f fa a aa. \<not> cylindric_algebra f fa \<or> (a::'a) = aa \<or> (fa a aa::'b) = fa aa a"
by (meson cylindric_algebra.dia_sym_var)
then have f7: "dia l m = dia m l"
  using a3 cylindric_algebra_axioms by blast
have f8: "dia i j = dia j i"
  using f6 a1 cylindric_algebra_axioms by blast
  have f9: "dia j k = cyl i (dia j i \<sqinter> dia i k)"
    using a2 a1 by (meson c6)
have "cyl i (dia m l) = dia m l"
  using a5 a4 by (meson cyl_dia1)
  then have "cyl i (dia i j \<sqinter> dia m l) = dia m l"
by (metis (no_types) c3 dia_cyl_top inf_aci(1) inf_top.monoid_axioms monoid.right_neutral)
  then show ?thesis
    using f9 f8 f7 a1 by (metis (no_types) dia_meet2 inf_assoc subst_def)
qed

end

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_sort_nat_NStoogeSort2IsSort
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

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

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
  "third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function twoThirds :: "Nat => Nat" where
  "twoThirds y =
   (if (y = (S (S Z))) then S Z else
      (if (y = (S Z)) then S Z else
         (case y of
            Z => Z
            | S z => plus (S (S Z)) (twoThirds (minus y (S (S (S Z))))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if le y z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "Nat list => Nat list"
  and nstoogesort2 :: "Nat list => Nat list"
  and nstooge2sort1 :: "Nat list => Nat list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "((nstoogesort2 xs) = (isort xs))"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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_18
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

fun t2 :: "Nat => Nat => bool" where
  "t2 x (Z) = False"
| "t2 (Z) (S z) = True"
| "t2 (S x2) (S z) = t2 x2 z"

theorem property0 :
  "t2 i (S (t22 i m))"
  oops

end


(* Author: Tobias Nipkow *)

section \<open>Unbalanced Tree Implementation of Map\<close>

theory Tree_Map
imports
  Tree_Set
  Map_Specs
begin

fun lookup :: "('a::linorder*'b) tree \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup Leaf x = None" |
"lookup (Node l (a,b) r) x =
  (case cmp x a of LT \<Rightarrow> lookup l x | GT \<Rightarrow> lookup r x | EQ \<Rightarrow> Some b)"

fun update :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) tree \<Rightarrow> ('a*'b) tree" where
"update x y Leaf = Node Leaf (x,y) Leaf" |
"update x y (Node l (a,b) r) = (case cmp x a of
   LT \<Rightarrow> Node (update x y l) (a,b) r |
   EQ \<Rightarrow> Node l (x,y) r |
   GT \<Rightarrow> Node l (a,b) (update x y r))"

fun delete :: "'a::linorder \<Rightarrow> ('a*'b) tree \<Rightarrow> ('a*'b) tree" where
"delete x Leaf = Leaf" |
"delete x (Node l (a,b) r) = (case cmp x a of
  LT \<Rightarrow> Node (delete x l) (a,b) r |
  GT \<Rightarrow> Node l (a,b) (delete x r) |
  EQ \<Rightarrow> if r = Leaf then l else let (ab',r') = split_min r in Node l ab' r')"

subsection "Functional Correctness Proofs"

lemma lookup_map_of:
  "sorted1(inorder t) \<Longrightarrow> lookup t x = map_of (inorder t) x"
by (induction t) (auto simp: map_of_simps split: option.split)

lemma inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update a b t) = upd_list a b (inorder t)"
by(induction t) (auto simp: upd_list_simps)

lemma inorder_delete:
  "sorted1(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(induction t) (auto simp: del_list_simps split_minD split: prod.splits)

interpretation M: Map_by_Ordered
where empty = empty and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case 2 thus ?case by(simp add: lookup_map_of)
next
  case 3 thus ?case by(simp add: inorder_update)
next
  case 4 thus ?case by(simp add: inorder_delete)
qed auto

end


(*  Title:      HOL/Algebra/IntRing.thy
    Author:     Stephan Hohe, TU Muenchen
    Author:     Clemens Ballarin
*)

theory IntRing
imports "HOL-Computational_Algebra.Primes" QuotRing Lattice
begin

section \<open>The Ring of Integers\<close>

subsection \<open>Some properties of @{typ int}\<close>

lemma dvds_eq_abseq:
  fixes k :: int
  shows "l dvd k \<and> k dvd l \<longleftrightarrow> \<bar>l\<bar> = \<bar>k\<bar>"
  by (metis dvd_if_abs_eq lcm.commute lcm_proj1_iff_int)

subsection \<open>\<open>\<Z>\<close>: The Set of Integers as Algebraic Structure\<close>

abbreviation int_ring :: "int ring" ("\<Z>")
  where "int_ring \<equiv> \<lparr>carrier = UNIV, mult = ( * ), one = 1, zero = 0, add = (+)\<rparr>"

lemma int_Zcarr [intro!, simp]: "k \<in> carrier \<Z>"
  by simp

lemma int_is_cring: "cring \<Z>"
proof (rule cringI)
  show "abelian_group \<Z>"
    by (rule abelian_groupI) (auto intro: left_minus)
  show "Group.comm_monoid \<Z>"
    by (simp add: Group.monoid.intro monoid.monoid_comm_monoidI)
qed (auto simp: distrib_right)

subsection \<open>Interpretations\<close>

text \<open>Since definitions of derived operations are global, their
  interpretation needs to be done as early as possible --- that is,
  with as few assumptions as possible.\<close>

interpretation int: monoid \<Z>
  rewrites "carrier \<Z> = UNIV"
    and "mult \<Z> x y = x * y"
    and "one \<Z> = 1"
    and "pow \<Z> x n = x^n"
proof -
  \<comment> \<open>Specification\<close>
  show "monoid \<Z>" by standard auto
  then interpret int: monoid \<Z> .

  \<comment> \<open>Carrier\<close>
  show "carrier \<Z> = UNIV" by simp

  \<comment> \<open>Operations\<close>
  { fix x y show "mult \<Z> x y = x * y" by simp }
  show "one \<Z> = 1" by simp
  show "pow \<Z> x n = x^n" by (induct n) simp_all
qed

interpretation int: comm_monoid \<Z>
  rewrites "finprod \<Z> f A = prod f A"
proof -
  \<comment> \<open>Specification\<close>
  show "comm_monoid \<Z>" by standard auto
  then interpret int: comm_monoid \<Z> .

  \<comment> \<open>Operations\<close>
  { fix x y have "mult \<Z> x y = x * y" by simp }
  note mult = this
  have one: "one \<Z> = 1" by simp
  show "finprod \<Z> f A = prod f A"
    by (induct A rule: infinite_finite_induct, auto)
qed

interpretation int: abelian_monoid \<Z>
  rewrites int_carrier_eq: "carrier \<Z> = UNIV"
    and int_zero_eq: "zero \<Z> = 0"
    and int_add_eq: "add \<Z> x y = x + y"
    and int_finsum_eq: "finsum \<Z> f A = sum f A"
proof -
  \<comment> \<open>Specification\<close>
  show "abelian_monoid \<Z>" by standard auto
  then interpret int: abelian_monoid \<Z> .

  \<comment> \<open>Carrier\<close>
  show "carrier \<Z> = UNIV" by simp

  \<comment> \<open>Operations\<close>
  { fix x y show "add \<Z> x y = x + y" by simp }
  note add = this
  show zero: "zero \<Z> = 0"
    by simp
  show "finsum \<Z> f A = sum f A"
    by (induct A rule: infinite_finite_induct, auto)
qed

interpretation int: abelian_group \<Z>
  (* The equations from the interpretation of abelian_monoid need to be repeated.
     Since the morphisms through which the abelian structures are interpreted are
     not the identity, the equations of these interpretations are not inherited. *)
  (* FIXME *)
  rewrites "carrier \<Z> = UNIV"
    and "zero \<Z> = 0"
    and "add \<Z> x y = x + y"
    and "finsum \<Z> f A = sum f A"
    and int_a_inv_eq: "a_inv \<Z> x = - x"
    and int_a_minus_eq: "a_minus \<Z> x y = x - y"
proof -
  \<comment> \<open>Specification\<close>
  show "abelian_group \<Z>"
  proof (rule abelian_groupI)
    fix x
    assume "x \<in> carrier \<Z>"
    then show "\<exists>y \<in> carrier \<Z>. y \<oplus>\<^bsub>\<Z>\<^esub> x = \<zero>\<^bsub>\<Z>\<^esub>"
      by simp arith
  qed auto
  then interpret int: abelian_group \<Z> .
  \<comment> \<open>Operations\<close>
  { fix x y have "add \<Z> x y = x + y" by simp }
  note add = this
  have zero: "zero \<Z> = 0" by simp
  {
    fix x
    have "add \<Z> (- x) x = zero \<Z>"
      by (simp add: add zero)
    then show "a_inv \<Z> x = - x"
      by (simp add: int.minus_equality)
  }
  note a_inv = this
  show "a_minus \<Z> x y = x - y"
    by (simp add: int.minus_eq add a_inv)
qed (simp add: int_carrier_eq int_zero_eq int_add_eq int_finsum_eq)+

interpretation int: "domain" \<Z>
  rewrites "carrier \<Z> = UNIV"
    and "zero \<Z> = 0"
    and "add \<Z> x y = x + y"
    and "finsum \<Z> f A = sum f A"
    and "a_inv \<Z> x = - x"
    and "a_minus \<Z> x y = x - y"
proof -
  show "domain \<Z>"
    by unfold_locales (auto simp: distrib_right distrib_left)
qed (simp add: int_carrier_eq int_zero_eq int_add_eq int_finsum_eq int_a_inv_eq int_a_minus_eq)+

text \<open>Removal of occurrences of @{term UNIV} in interpretation result
  --- experimental.\<close>

lemma UNIV:
  "x \<in> UNIV \<longleftrightarrow> True"
  "A \<subseteq> UNIV \<longleftrightarrow> True"
  "(\<forall>x \<in> UNIV. P x) \<longleftrightarrow> (\<forall>x. P x)"
  "(\<exists>x \<in> UNIV. P x) \<longleftrightarrow> (\<exists>x. P x)"
  "(True \<longrightarrow> Q) \<longleftrightarrow> Q"
  "(True \<Longrightarrow> PROP R) \<equiv> PROP R"
  by simp_all

interpretation int (* FIXME [unfolded UNIV] *) :
  partial_order "\<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr>"
  rewrites "carrier \<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr> = UNIV"
    and "le \<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr> x y = (x \<le> y)"
    and "lless \<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr> x y = (x < y)"
proof -
  show "partial_order \<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr>"
    by standard simp_all
  show "carrier \<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr> = UNIV"
    by simp
  show "le \<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr> x y = (x \<le> y)"
    by simp
  show "lless \<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr> x y = (x < y)"
    by (simp add: lless_def) auto
qed

interpretation int (* FIXME [unfolded UNIV] *) :
  lattice "\<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr>"
  rewrites "join \<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr> x y = max x y"
    and "meet \<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr> x y = min x y"
proof -
  let ?Z = "\<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr>"
  show "lattice ?Z"
    apply unfold_locales
    apply (simp_all add: least_def Upper_def greatest_def Lower_def)
    apply arith+
    done
  then interpret int: lattice "?Z" .
  show "join ?Z x y = max x y"
    by (metis int.le_iff_meet iso_tuple_UNIV_I join_comm linear max.absorb_iff2 max_def)
  show "meet ?Z x y = min x y"
    using int.meet_le int.meet_left int.meet_right by auto
qed

interpretation int (* [unfolded UNIV] *) :
  total_order "\<lparr>carrier = UNIV::int set, eq = (=), le = (\<le>)\<rparr>"
  by standard clarsimp

subsection \<open>Generated Ideals of \<open>\<Z>\<close>\<close>

lemma int_Idl: "Idl\<^bsub>\<Z>\<^esub> {a} = {x * a | x. True}"
  by (simp_all add: cgenideal_def int.cgenideal_eq_genideal[symmetric])

lemma multiples_principalideal: "principalideal {x * a | x. True } \<Z>"
  by (metis UNIV_I int.cgenideal_eq_genideal int.cgenideal_is_principalideal int_Idl)

lemma prime_primeideal:
  assumes prime: "Factorial_Ring.prime p"
  shows "primeideal (Idl\<^bsub>\<Z>\<^esub> {p}) \<Z>"
proof (rule primeidealI)
  show "ideal (Idl\<^bsub>\<Z>\<^esub> {p}) \<Z>"
    by (rule int.genideal_ideal, simp)
  show "cring \<Z>"
    by (rule int_is_cring)
  have False if "UNIV = {v::int. \<exists>x. v = x * p}"
  proof -
    from that
    obtain i where "1 = i * p"
      by (blast intro:  elim: )
    then show False
      using prime by (auto simp add: abs_mult zmult_eq_1_iff)
  qed
  then show "carrier \<Z> \<noteq> Idl\<^bsub>\<Z>\<^esub> {p}"
    by (auto simp add: int.cgenideal_eq_genideal[symmetric] cgenideal_def)
  have "p dvd a \<or> p dvd b" if "a * b = x * p" for a b x
    by (simp add: prime prime_dvd_multD that)
  then show "\<And>a b. \<lbrakk>a \<in> carrier \<Z>; b \<in> carrier \<Z>; a \<otimes>\<^bsub>\<Z>\<^esub> b \<in> Idl\<^bsub>\<Z>\<^esub> {p}\<rbrakk>
           \<Longrightarrow> a \<in> Idl\<^bsub>\<Z>\<^esub> {p} \<or> b \<in> Idl\<^bsub>\<Z>\<^esub> {p}"
    by (auto simp add: int.cgenideal_eq_genideal[symmetric] cgenideal_def dvd_def mult.commute)
qed

subsection \<open>Ideals and Divisibility\<close>

lemma int_Idl_subset_ideal: "Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} = (k \<in> Idl\<^bsub>\<Z>\<^esub> {l})"
  by (rule int.Idl_subset_ideal') simp_all

lemma Idl_subset_eq_dvd: "Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} \<longleftrightarrow> l dvd k"
  by (subst int_Idl_subset_ideal) (auto simp: dvd_def int_Idl)

lemma dvds_eq_Idl: "l dvd k \<and> k dvd l \<longleftrightarrow> Idl\<^bsub>\<Z>\<^esub> {k} = Idl\<^bsub>\<Z>\<^esub> {l}"
proof -
  have a: "l dvd k \<longleftrightarrow> (Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l})"
    by (rule Idl_subset_eq_dvd[symmetric])
  have b: "k dvd l \<longleftrightarrow> (Idl\<^bsub>\<Z>\<^esub> {l} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {k})"
    by (rule Idl_subset_eq_dvd[symmetric])

  have "l dvd k \<and> k dvd l \<longleftrightarrow> Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} \<and> Idl\<^bsub>\<Z>\<^esub> {l} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {k}"
    by (subst a, subst b, simp)
  also have "Idl\<^bsub>\<Z>\<^esub> {k} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {l} \<and> Idl\<^bsub>\<Z>\<^esub> {l} \<subseteq> Idl\<^bsub>\<Z>\<^esub> {k} \<longleftrightarrow> Idl\<^bsub>\<Z>\<^esub> {k} = Idl\<^bsub>\<Z>\<^esub> {l}"
    by blast
  finally show ?thesis .
qed

lemma Idl_eq_abs: "Idl\<^bsub>\<Z>\<^esub> {k} = Idl\<^bsub>\<Z>\<^esub> {l} \<longleftrightarrow> \<bar>l\<bar> = \<bar>k\<bar>"
  apply (subst dvds_eq_abseq[symmetric])
  apply (rule dvds_eq_Idl[symmetric])
  done

subsection \<open>Ideals and the Modulus\<close>

definition ZMod :: "int \<Rightarrow> int \<Rightarrow> int set"
  where "ZMod k r = (Idl\<^bsub>\<Z>\<^esub> {k}) +>\<^bsub>\<Z>\<^esub> r"

lemmas ZMod_defs =
  ZMod_def genideal_def

lemma rcos_zfact:
  assumes kIl: "k \<in> ZMod l r"
  shows "\<exists>x. k = x * l + r"
proof -
  from kIl[unfolded ZMod_def] have "\<exists>xl\<in>Idl\<^bsub>\<Z>\<^esub> {l}. k = xl + r"
    by (simp add: a_r_coset_defs)
  then obtain xl where xl: "xl \<in> Idl\<^bsub>\<Z>\<^esub> {l}" and k: "k = xl + r"
    by auto
  from xl obtain x where "xl = x * l"
    by (auto simp: int_Idl)
  with k have "k = x * l + r"
    by simp
  then show "\<exists>x. k = x * l + r" ..
qed

lemma ZMod_imp_zmod:
  assumes zmods: "ZMod m a = ZMod m b"
  shows "a mod m = b mod m"
proof -
  interpret ideal "Idl\<^bsub>\<Z>\<^esub> {m}" \<Z>
    by (rule int.genideal_ideal) fast
  from zmods have "b \<in> ZMod m a"
    unfolding ZMod_def by (simp add: a_repr_independenceD)
  then have "\<exists>x. b = x * m + a"
    by (rule rcos_zfact)
  then obtain x where "b = x * m + a"
    by fast
  then have "b mod m = (x * m + a) mod m"
    by simp
  also have "\<dots> = ((x * m) mod m) + (a mod m)"
    by (simp add: mod_add_eq)
  also have "\<dots> = a mod m"
    by simp
  finally have "b mod m = a mod m" .
  then show "a mod m = b mod m" ..
qed

lemma ZMod_mod: "ZMod m a = ZMod m (a mod m)"
proof -
  interpret ideal "Idl\<^bsub>\<Z>\<^esub> {m}" \<Z>
    by (rule int.genideal_ideal) fast
  show ?thesis
    unfolding ZMod_def
    apply (rule a_repr_independence'[symmetric])
    apply (simp add: int_Idl a_r_coset_defs)
  proof -
    have "a = m * (a div m) + (a mod m)"
      by (simp add: mult_div_mod_eq [symmetric])
    then have "a = (a div m) * m + (a mod m)"
      by simp
    then show "\<exists>h. (\<exists>x. h = x * m) \<and> a = h + a mod m"
      by fast
  qed simp
qed

lemma zmod_imp_ZMod:
  assumes modeq: "a mod m = b mod m"
  shows "ZMod m a = ZMod m b"
proof -
  have "ZMod m a = ZMod m (a mod m)"
    by (rule ZMod_mod)
  also have "\<dots> = ZMod m (b mod m)"
    by (simp add: modeq[symmetric])
  also have "\<dots> = ZMod m b"
    by (rule ZMod_mod[symmetric])
  finally show ?thesis .
qed

corollary ZMod_eq_mod: "ZMod m a = ZMod m b \<longleftrightarrow> a mod m = b mod m"
  apply (rule iffI)
  apply (erule ZMod_imp_zmod)
  apply (erule zmod_imp_ZMod)
  done

subsection \<open>Factorization\<close>

definition ZFact :: "int \<Rightarrow> int set ring"
  where "ZFact k = \<Z> Quot (Idl\<^bsub>\<Z>\<^esub> {k})"

lemmas ZFact_defs = ZFact_def FactRing_def

lemma ZFact_is_cring: "cring (ZFact k)"
  by (simp add: ZFact_def ideal.quotient_is_cring int.cring_axioms int.genideal_ideal)

lemma ZFact_zero: "carrier (ZFact 0) = (\<Union>a. {{a}})"
  by (simp add: ZFact_defs A_RCOSETS_defs r_coset_def int.genideal_zero)

lemma ZFact_one: "carrier (ZFact 1) = {UNIV}"
  unfolding ZFact_defs A_RCOSETS_defs r_coset_def ring_record_simps int.genideal_one
proof
  have "\<And>a b::int. \<exists>x. b = x + a"
    by presburger
  then show "(\<Union>a::int. {\<Union>h. {h + a}}) \<subseteq> {UNIV}"
    by force
  then show "{UNIV} \<subseteq> (\<Union>a::int. {\<Union>h. {h + a}})"
    by (metis (no_types, lifting) UNIV_I UN_I singletonD singletonI subset_iff)
qed

lemma ZFact_prime_is_domain:
  assumes pprime: "Factorial_Ring.prime p"
  shows "domain (ZFact p)"
  by (simp add: ZFact_def pprime prime_primeideal primeideal.quotient_is_domain)

end


(* Author: Johannes Hölzl <hoelzl@in.tum.de>
   Author: Tobias Nipkow <nipkow@in.tum.de> *)
theory PCTL
imports
  "../Discrete_Time_Markov_Chain"
  "../../Gauss-Jordan-Elim-Fun/Gauss_Jordan_Elim_Fun"
  "~~/src/HOL/Library/While_Combinator"
  "~~/src/HOL/Library/Monad_Syntax"
begin

section {* Adapt Gauss-Jordan elimination to DTMCs *}

lemma split_option_bind:
  fixes x :: "'a option" and f :: "'a \<Rightarrow> 'b option" and P :: "'b option \<Rightarrow> bool"
  shows "P (x \<guillemotright>= f) \<longleftrightarrow> (x = None \<longrightarrow> P None) \<and> (\<forall>a. x = Some a \<longrightarrow> P (f a))"
  by (cases x) auto

lemma split_option_bind_asm:
  fixes x :: "'a option" and f :: "'a \<Rightarrow> 'b option" and P :: "'b option \<Rightarrow> bool"
  shows "P (x \<guillemotright>= f) \<longleftrightarrow> \<not> ((x = None \<and> \<not> P None) \<or> (\<exists>a. x = Some a \<and> \<not> P (f a)))"
  by (simp split: split_option_bind)

locale Finite_DTMC =
  fixes K :: "'s \<Rightarrow> 's pmf" and S :: "'s set" and \<rho> :: "'s \<Rightarrow> real" and \<iota> :: "'s \<Rightarrow> 's \<Rightarrow> real"
  assumes \<iota>_nonneg: "\<And>s t. 0 \<le> \<iota> s t" and \<rho>_nonneg: "\<And>s. 0 \<le> \<rho> s"
  assumes measurable_\<iota>: "(\<lambda>(a, b). \<iota> a b) \<in> borel_measurable (count_space UNIV \<Otimes>\<^sub>M count_space UNIV)"
  assumes finite_S[simp]: "finite S" and S_not_empty: "S \<noteq> {}"
  assumes E_closed: "(\<Union>s\<in>S. set_pmf (K s)) \<subseteq> S"
begin

lemma measurable_\<iota>'[measurable (raw)]:
  "f \<in> measurable M (count_space UNIV) \<Longrightarrow> g \<in> measurable M (count_space UNIV) \<Longrightarrow>
    (\<lambda>x. \<iota> (f x) (g x)) \<in> borel_measurable M"
  using measurable_compose[OF _ measurable_\<iota>, of "\<lambda>x. (f x, g x)" M] by simp

lemma measurable_\<rho>[measurable]: "\<rho> \<in> borel_measurable (count_space UNIV)"
  by simp

sublocale R: MC_with_rewards K \<iota> \<rho>
  by default (auto intro: \<iota>_nonneg \<rho>_nonneg)

lemma single_l:
  fixes s and x :: real assumes "s \<in> S"
  shows "(\<Sum>s'\<in>S. (if s' = s then 1 else 0) * l s') = x \<longleftrightarrow> l s = x"
proof -
  have "(\<Sum>s'\<in>S. (if s' = s then 1 else 0) * l s') = (\<Sum>s'\<in>S. (if s' = s then l s' else 0))"
    using `s \<in> S` by (auto intro!: setsum.cong)
  with `s \<in> S` show ?thesis
    using finite_S by (auto simp add: setsum.If_cases)
qed

definition "order = (SOME f. bij_betw f {..< card S} S)"

lemma
  shows bij_order[simp]: "bij_betw order {..< card S} S"
    and inj_order[simp]: "inj_on order {..<card S}"
    and image_order[simp]: "order ` {..<card S} = S"
    and order_S[simp, intro]: "\<And>i. i < card S \<Longrightarrow> order i \<in> S"
proof -
  from finite_same_card_bij[OF _ finite_S] show "bij_betw order {..< card S} S"
    unfolding order_def by (rule someI_ex) auto
  then show "inj_on order {..<card S}" "order ` {..<card S} = S"
    unfolding bij_betw_def by auto
  then show "\<And>i. i < card S \<Longrightarrow> order i \<in> S"
    by auto
qed

lemma order_Ex:
  assumes "s \<in> S" obtains i where "i < card S" "s = order i"
proof -
  from `s \<in> S` have "s \<in> order ` {..<card S}"
    by simp
  with that show thesis
    by (auto simp del: image_order)
qed

definition "iorder = the_inv_into {..<card S} order"

lemma bij_iorder: "bij_betw iorder S {..<card S}"
  unfolding iorder_def by (rule bij_betw_the_inv_into bij_order)+

lemma iorder_image_eq: "iorder ` S = {..<card S}"
  and inj_iorder: "inj_on iorder S"
  using bij_iorder  unfolding bij_betw_def by auto

lemma order_iorder: "\<And>s. s \<in> S \<Longrightarrow> order (iorder s) = s"
  unfolding iorder_def using bij_order
  by (intro f_the_inv_into_f) (auto simp: bij_betw_def)

definition gauss_jordan' :: "('s \<Rightarrow> 's \<Rightarrow> real) \<Rightarrow> ('s \<Rightarrow> real) \<Rightarrow> ('s \<Rightarrow> real) option" where
  "gauss_jordan' M a = do {
     let M' = (\<lambda>i j. if j = card S then a (order i) else M (order i) (order j)) ;
     sol \<leftarrow> gauss_jordan M' (card S) ;
     Some (\<lambda>i. sol (iorder i) (card S))
  }"

lemma gauss_jordan'_correct:
  assumes "gauss_jordan' M a = Some f"
  shows "\<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * f s') = a s"
proof -
  note `gauss_jordan' M a = Some f`
  moreover def M' \<equiv> "\<lambda>i j. if j = card S then
    a (order i) else M (order i) (order j)"
  ultimately obtain sol where sol: "gauss_jordan M' (card S) = Some sol"
    and f: "f = (\<lambda>i. sol (iorder i) (card S))"
    by (auto simp: gauss_jordan'_def Let_def split: split_option_bind_asm)

  from gauss_jordan_correct[OF sol]
  have "\<forall>i\<in>{..<card S}. (\<Sum>j<card S. M (order i) (order j) * sol j (card S)) = a (order i)"
    unfolding solution_def M'_def by (simp add: atLeast0LessThan)
  then show ?thesis
    unfolding iorder_image_eq[symmetric] f using inj_iorder
    by (subst (asm) setsum.reindex) (auto simp: order_iorder)
qed

lemma gauss_jordan'_complete:
  assumes exists: "\<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * x s') = a s"
  assumes unique: "\<And>y. \<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * y s') = a s \<Longrightarrow> \<forall>s\<in>S. y s = x s"
  shows "\<exists>y. gauss_jordan' M a = Some y"
proof -
  def M' \<equiv> "\<lambda>i j. if j = card S then
    a (order i) else M (order i) (order j)"

  { fix x
    have iorder_neq_card_S: "\<And>s. s \<in> S \<Longrightarrow> iorder s \<noteq> card S"
      using iorder_image_eq by (auto simp: set_eq_iff less_le)
    have "solution2 M' (card S) (card S) x \<longleftrightarrow>
      (\<forall>s\<in>{..<card S}. (\<Sum>s'\<in>{..<card S}. M' s s' * x s') = M' s (card S))"
      unfolding solution2_def by (auto simp: atLeast0LessThan)
    also have "\<dots> \<longleftrightarrow> (\<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * x (iorder s')) = a s)"
      unfolding iorder_image_eq[symmetric] M'_def
      using inj_iorder iorder_neq_card_S
      by (simp add: setsum.reindex order_iorder)
    finally have "solution2 M' (card S) (card S) x \<longleftrightarrow>
      (\<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * x (iorder s')) = a s)" . }
  note sol2_eq = this
  have "usolution M' (card S) (card S) (\<lambda>i. x (order i))"
    unfolding usolution_def
  proof safe
    from exists show "solution2 M' (card S) (card S) (\<lambda>i. x (order i))"
      by (simp add: sol2_eq order_iorder)
  next
    fix y j assume y: "solution2 M' (card S) (card S) y" and "j < card S"
    then have "\<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * y (iorder s')) = a s"
      by (simp add: sol2_eq)
    from unique[OF this]
    have "\<forall>i\<in>{..<card S}. y i = x (order i)"
      unfolding iorder_image_eq[symmetric]
      by (simp add: order_iorder)
    with `j < card S` show "y j = x (order j)" by simp
  qed
  from gauss_jordan_complete[OF _ this]
  show ?thesis
    by (auto simp: gauss_jordan'_def simp: M'_def)
qed

end

section {* pCTL model checking*}

subsection {* Syntax *}

datatype realrel = LessEqual | Less | Greater | GreaterEqual | Equal

datatype 's sform = "true"
                  | "Label" "'s set"
                  | "Neg" "'s sform"
                  | "And" "'s sform" "'s sform"
                  | "Prob" "realrel" "real" "'s pform"
                  | "Exp" "realrel" "real" "'s eform"
     and 's pform = "X" "'s sform"
                  | "U" "nat" "'s sform" "'s sform"
                  | "UInfinity" "'s sform" "'s sform" ("U\<^sup>\<infinity>")
     and 's eform = "Cumm" "nat" ("C\<^sup>\<le>")
                  | "State" "nat" ("I\<^sup>=")
                  | "Future" "'s sform"

primrec bound_until where
  "bound_until 0 \<phi> \<psi> = \<psi>"
| "bound_until (Suc n) \<phi> \<psi> = \<psi> or (\<phi> aand nxt (bound_until n \<phi> \<psi>))"

lemma measurable_bound_until[measurable]:
  assumes [measurable]: "Measurable.pred (stream_space M) \<phi>" "Measurable.pred (stream_space M) \<psi>"
  shows "Measurable.pred (stream_space M) (bound_until n \<phi> \<psi>)"
  by (induct n) simp_all

subsection {* Semantics *}

primrec inrealrel :: "realrel \<Rightarrow> 'a \<Rightarrow> ('a::linorder) \<Rightarrow> bool" where
"inrealrel LessEqual r q    \<longleftrightarrow> q \<le> r" |
"inrealrel Less r q         \<longleftrightarrow> q < r" |
"inrealrel Greater r q      \<longleftrightarrow> q > r" |
"inrealrel GreaterEqual r q \<longleftrightarrow> q \<ge> r" |
"inrealrel Equal r q        \<longleftrightarrow> q = r"

context Finite_DTMC
begin

abbreviation "prob s P \<equiv> measure (T s) {x\<in>space (T s). P x}"
abbreviation "E s \<equiv> set_pmf (K s)"

primrec svalid :: "'s sform \<Rightarrow> 's set"
and pvalid :: "'s pform \<Rightarrow> 's stream \<Rightarrow> bool"
and reward :: "'s eform \<Rightarrow> 's stream \<Rightarrow> ereal" where
"svalid true           = S" |
"svalid (Label L)      = {s \<in> S. s \<in> L}" |
"svalid (Neg F)        = S - svalid F" |
"svalid (And F1 F2)    = svalid F1 \<inter> svalid F2" |
"svalid (Prob rel r F) = {s \<in> S. inrealrel rel r \<P>(\<omega> in T s. pvalid F (s ## \<omega>)) }" |
"svalid (Exp rel r F)  = {s \<in> S. inrealrel rel (ereal r) (\<integral>\<^sup>+ \<omega>. reward F (s ## \<omega>) \<partial>T s) }" |

"pvalid (X F)        = nxt (HLD (svalid F))" |
"pvalid (U k F1 F2)  = bound_until k (HLD (svalid F1)) (HLD (svalid F2))" |
"pvalid (U\<^sup>\<infinity> F1 F2)   = HLD (svalid F1) suntil HLD (svalid F2)" |

"reward (C\<^sup>\<le> k)         = (\<lambda>\<omega>. (\<Sum>i<k. \<rho> (\<omega> !! i) + \<iota> (\<omega> !! i) (\<omega> !! (Suc i))))" |
"reward (I\<^sup>= k)         = (\<lambda>\<omega>. \<rho> (\<omega> !! k))" |
"reward (Future F)     = (\<lambda>\<omega>. if ev (HLD (svalid F)) \<omega> then reward_until (svalid F) (shd \<omega>) (stl \<omega>) else \<infinity>)"

lemma svalid_subset_S: "svalid F \<subseteq> S"
  by (induct F) auto

lemma finite_svalid[simp, intro]: "finite (svalid F)"
  using svalid_subset_S finite_S by (blast intro: finite_subset)

lemma svalid_sets[measurable]: "svalid F \<in> sets (count_space S)"
  using svalid_subset_S by auto

lemma reward_measurable[measurable]: "reward F \<in> borel_measurable R.S"
  by (cases F) (auto intro!: borel_measurable_ereal borel_measurable_setsum borel_measurable_add
    measurable_compose[OF measurable_snth])

lemma reward_nonneg: "0 \<le> reward F \<omega>"
  by (cases F)
     (auto intro!: setsum_nonneg add_nonneg_nonneg reward_until_nonneg \<rho>_nonneg \<iota>_nonneg)

subsection {* Implementation of @{text Sat} *}

subsubsection {* @{text Prob0}  *}

definition Prob0 where
  "Prob0 \<Phi> \<Psi> = S - while (\<lambda>R. \<exists>s\<in>\<Phi>. R \<inter> E s \<noteq> {} \<and> s \<notin> R) (\<lambda>R. R \<union> {s\<in>\<Phi>. R \<inter> E s \<noteq> {}}) \<Psi>"

lemma Prob0_subset_S: "Prob0 \<Phi> \<Psi> \<subseteq> S"
  unfolding Prob0_def by auto

lemma Prob0_iff_reachable:
  assumes "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S"
  shows "Prob0 \<Phi> \<Psi> = {s \<in> S. ((SIGMA x:\<Phi>. E x)\<^sup>* `` {s}) \<inter> \<Psi> = {}}" (is "_ = ?U")
  unfolding Prob0_def
proof (intro while_rule[where Q="\<lambda>R. S - R = ?U" and P="\<lambda>R. \<Psi> \<subseteq> R \<and> R \<subseteq> S - ?U"] conjI)
  show "wf {(B, A). A \<subset> B \<and> B \<subseteq> S}"
    by (rule wf_bounded_set[where ub="\<lambda>_. S" and f="\<lambda>x. x"]) auto
  show "\<Psi> \<subseteq> S - ?U"
    using assms by auto

  let ?\<Delta> = "\<lambda>R. {s\<in>\<Phi>. R \<inter> E s \<noteq> {}}"
  { fix R assume R: "\<Psi> \<subseteq> R \<and> R \<subseteq> S - ?U" and "\<exists>s\<in>\<Phi>. R \<inter> E s \<noteq> {} \<and> s \<notin> R"
    with assms show "(R \<union> ?\<Delta> R, R) \<in> {(B, A). A \<subset> B \<and> B \<subseteq> S}" "\<Psi> \<subseteq> R \<union> ?\<Delta> R"
      by auto

    { fix s s' assume s: "s \<in> \<Phi>" "s' \<in> R" "s' \<in> E s" and r: "(Sigma \<Phi> E)\<^sup>* `` {s} \<inter> \<Psi> = {}"
      with R have "(s, s') \<in> (Sigma \<Phi> E)\<^sup>*" "s' \<in> \<Phi> - \<Psi>"
        by (auto elim: converse_rtranclE)
      moreover with `s' \<in> R` R obtain s'' where "(s', s'') \<in> (Sigma \<Phi> E)\<^sup>*" "s'' \<in> \<Psi>"
        by auto
      ultimately have "(s, s'') \<in> (Sigma \<Phi> E)\<^sup>*" "s'' \<in> \<Psi>"
        by auto
      with r have False
        by auto }
    with `\<Phi> \<subseteq> S` R show "R \<union> ?\<Delta> R \<subseteq> S - ?U" by auto }

  { fix R assume R: "\<Psi> \<subseteq> R \<and> R \<subseteq> S - ?U" and dR: "\<not> (\<exists>s\<in>\<Phi>. R \<inter> E s \<noteq> {} \<and> s \<notin> R)"
    { fix s t assume s: "s \<in> S - R"
      assume s_t: "(s, t) \<in> (Sigma \<Phi> E)\<^sup>*" then have "t \<in> S - R"
      proof induct
        case (step t u) with R dR E_closed show ?case
          by auto
      qed fact
      then have "t \<notin> \<Psi>"
        using R by auto }
    with R show "S - R = ?U"
      by auto }
qed rule

lemma Prob0_iff:
  assumes "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S"
  shows "Prob0 \<Phi> \<Psi> = {s\<in>S. AE \<omega> in T s. \<not> (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)}" (is "_ = ?U")
  unfolding Prob0_iff_reachable[OF assms]
proof (intro Collect_cong conj_cong refl iffI)
  fix s assume s: "s \<in> S" "(Sigma \<Phi> E)\<^sup>* `` {s} \<inter> \<Psi> = {}"
  { fix \<omega> assume "(HLD \<Phi> suntil HLD \<Psi>) \<omega>" "enabled (shd \<omega>) (stl \<omega>)" "(Sigma \<Phi> E)\<^sup>* `` {shd \<omega>} \<inter> \<Psi> = {}"
    from this have False
    proof induction
      case (step \<omega>)
      moreover
      then have "(shd \<omega>, shd (stl \<omega>)) \<in> (Sigma \<Phi> E)\<^sup>*"
        by (auto simp: enabled.simps[of _ "stl \<omega>"] HLD_iff)
      then have "(Sigma \<Phi> E)\<^sup>* `` {shd (stl \<omega>)} \<subseteq> (Sigma \<Phi> E)\<^sup>* `` {shd \<omega>}"
        by auto
      ultimately show ?case
        by (auto simp add: enabled.simps[of _ "stl \<omega>"])
    qed (auto simp: HLD_iff) }
  from s this[of "s ## \<omega>" for \<omega>] show "AE \<omega> in T s. \<not> (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)"
    using AE_T_enabled[of s] by auto
next
  fix s assume s: "AE \<omega> in T s. \<not> (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)"
  { fix t assume "(s, t) \<in> (Sigma \<Phi> E)\<^sup>*" from this s have "t \<notin> \<Psi>"
    proof (induction rule: converse_rtrancl_induct)
      case (step s u) then show ?case
        by (simp add: AE_T_iff[where x=s] suntil_Stream[of _ _ s])
    qed (simp add: suntil_Stream) }
  then show "(Sigma \<Phi> E)\<^sup>* `` {s} \<inter> \<Psi> = {}"
    by auto
qed

lemma E_rtrancl_closed:
  assumes "s \<in> S" "(s, t) \<in> (SIGMA x:A. B x)\<^sup>*" "\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> E x" shows "t \<in> S"
  using assms(2,3,1) E_closed by induction force+

subsubsection {* @{text Prob1} *}

definition Prob1 where
  "Prob1 Y \<Phi> \<Psi> = Prob0 (\<Phi> - \<Psi>) Y"

lemma Prob1_iff:
  assumes "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S"
  shows "Prob1 (Prob0 \<Phi> \<Psi>) \<Phi> \<Psi> = {s\<in>S. AE \<omega> in T s. (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)}"
    (is "Prob1 ?P0 _ _ = {s\<in>S. ?pU s}")
proof -
  note P0 = Prob0_iff_reachable[OF assms]
  have *: "\<Phi> - \<Psi> \<subseteq> S" "?P0 \<subseteq> S"
    using P0 assms by auto

  have P0_subset: "S - \<Phi> - \<Psi> \<subseteq> ?P0"
    unfolding P0 by (auto elim: converse_rtranclE)

  have "Prob1 ?P0 \<Phi> \<Psi> = {s \<in> S. (Sigma (\<Phi> - \<Psi>) E)\<^sup>* `` {s} \<inter> ?P0 = {}}"
    unfolding Prob0_iff_reachable[OF *] Prob1_def ..
  also have "\<dots> = {s\<in>S. AE \<omega> in T s. (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)}"
  proof (intro Collect_cong conj_cong refl iffI)
    fix s assume s: "s \<in> S" "(Sigma (\<Phi> - \<Psi>) E)\<^sup>* `` {s} \<inter> ?P0 = {}"
    then have "s \<notin> ?P0"
      by auto
    then have "s \<in> \<Phi> - \<Psi> \<or> s \<in> \<Psi>"
      using P0_subset `s \<in> S` by auto
    moreover
    { assume "s \<in> \<Phi> - \<Psi>"
      have "AE \<omega> in T s. ev (HLD (\<Psi> \<union> ?P0)) \<omega>"
      proof (rule AE_T_ev_HLD)
        fix t assume s_t: "(s, t) \<in> (SIGMA s:UNIV. E s - (\<Psi> \<union> ?P0))\<^sup>*"
        from `s \<in> S` s_t have "t \<in> S"
          by (rule E_rtrancl_closed) auto

        show "\<exists>t'\<in>\<Psi> \<union> ?P0. (t, t') \<in> (Sigma UNIV E)\<^sup>*"
        proof cases
          assume "t \<in> ?P0" then show ?thesis by auto
        next
          assume "t \<notin> ?P0"
          with `t\<in>S` obtain s where t_s: "(t, s) \<in> (SIGMA x:\<Phi>. E x)\<^sup>*" and "s \<in> \<Psi>"
            unfolding P0 by auto
          from t_s have "(t, s) \<in> (SIGMA x:UNIV. E x)\<^sup>*"
            by (rule set_rev_mp) (intro rtrancl_mono Sigma_mono, auto)
          with `s \<in> \<Psi>` show ?thesis by auto
        qed
      next
        have "(SIGMA s:UNIV. E s - (\<Psi> \<union> Prob0 \<Phi> \<Psi>))\<^sup>* `` {s} \<subseteq> S"
          using `s \<in> S` by (auto intro: E_rtrancl_closed)
        then show "finite ((SIGMA s:UNIV. E s - (\<Psi> \<union> Prob0 \<Phi> \<Psi>))\<^sup>* `` {s})"
          using finite_S by (auto dest: finite_subset)
      qed
      then have "AE \<omega> in T s. (HLD \<Phi> suntil HLD \<Psi>) \<omega>"
        using AE_T_enabled
      proof eventually_elim
        fix \<omega> assume "ev (HLD (\<Psi> \<union> ?P0)) \<omega>" "enabled s \<omega>"
        from this s `s \<in> \<Phi> - \<Psi>` show "(HLD \<Phi> suntil HLD \<Psi>) \<omega>"
        proof (induction arbitrary: s)
          case (base \<omega>) then show ?case
            by (auto simp: HLD_iff enabled.simps[of s] intro: suntil.intros)
        next
          case (step \<omega>)
          then have "(s, shd \<omega>) \<in> (Sigma (\<Phi> - \<Psi>) E)"
            by (auto simp: enabled.simps[of s])
          then have *: "(Sigma (\<Phi> - \<Psi>) E)\<^sup>* `` {shd \<omega>} \<inter> ?P0 = {}"
            using step.prems by (auto intro: converse_rtrancl_into_rtrancl)
          then have "shd \<omega> \<in> \<Phi> - \<Psi> \<or> shd \<omega> \<in> \<Psi>" "shd \<omega> \<in> S"
            using P0_subset step.prems(1,2) E_closed by (auto simp add: enabled.simps[of s])
          then show ?case
            using step.prems(1) step.IH[OF _ _ *] `shd \<omega> \<in> S`
            by (auto simp add: suntil.simps[of _ _ \<omega>] HLD_iff[abs_def] enabled.simps[of s \<omega>])
        qed
      qed }
    ultimately show "AE \<omega> in T s. (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)"
      by (cases "s \<in> \<Phi> - \<Psi>") (auto simp add: suntil_Stream)
  next
    fix s assume s: "s \<in> S" "AE \<omega> in T s. (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)"
    { fix t assume "(s, t) \<in> (SIGMA s:\<Phi>-\<Psi>. E s)\<^sup>*"
      from this `s \<in> S` have "(AE \<omega> in T t. (HLD \<Phi> suntil HLD \<Psi>) (t ## \<omega>)) \<and> t \<in> S"
      proof induction
        case (step t u) with E_closed show ?case
          by (auto simp add: AE_T_iff[of _ t] suntil_Stream)
      qed (insert s, auto)
      then have "t \<notin> ?P0"
        unfolding Prob0_iff[OF assms] by (auto dest: T.AE_contr) }
    then show "(Sigma (\<Phi> - \<Psi>) E)\<^sup>* `` {s} \<inter> Prob0 \<Phi> \<Psi> = {}"
      by auto
  qed
  finally show ?thesis .
qed

subsubsection {* @{text ProbU},  @{text ExpCumm}, and @{text ExpState}  *}

abbreviation "\<tau> s t \<equiv> pmf (K s) t"

fun ProbU :: "'s \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> 's set \<Rightarrow> real" where
"ProbU q 0 S1 S2       = (if q \<in> S2 then 1 else 0)" |
"ProbU q (Suc k) S1 S2 =
  (if q \<in> S1 - S2 then (\<Sum>q'\<in>S. \<tau> q q' * ProbU q' k S1 S2)
                  else if q \<in> S2 then 1 else 0)"

fun ExpCumm :: "'s \<Rightarrow> nat \<Rightarrow> ereal" where
"ExpCumm s 0       = 0" |
"ExpCumm s (Suc k) = \<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * (\<iota> s s' + ExpCumm s' k))"

fun ExpState :: "'s \<Rightarrow> nat \<Rightarrow> ereal" where
"ExpState s 0       = \<rho> s" |
"ExpState s (Suc k) = (\<Sum>s'\<in>S. \<tau> s s' * ExpState s' k)"

subsubsection {* @{text LES} *}

definition LES :: "'s set \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> real" where
  "LES F r c =
       (if r \<in> F then (if c = r then 1 else 0)
                 else (if c = r then \<tau> r c - 1 else \<tau> r c ))"

subsubsection {* @{text ProbUinfty}, compute unbounded until *}

definition ProbUinfty :: "'s set \<Rightarrow> 's set \<Rightarrow> ('s \<Rightarrow> real) option" where
  "ProbUinfty S1 S2 = gauss_jordan' (LES (Prob0 S1 S2 \<union> S2))
                                    (\<lambda>i. if i \<in> S2 then 1 else 0)"

subsubsection {* @{text ExpFuture}, compute unbounded reward *}

definition ExpFuture :: "'s set \<Rightarrow> ('s \<Rightarrow> ereal) option" where
  "ExpFuture F = do {
      let N = Prob0 S F ;
      let Y = Prob1 N S F ;
      sol \<leftarrow> gauss_jordan' (LES (S - Y \<union> F))
        (\<lambda>i. if i \<in> Y \<and> i \<notin> F then - \<rho> i - (\<Sum>s'\<in>S. \<tau> i s' * \<iota> i s') else 0) ;
      Some (\<lambda>s. if s \<in> Y then ereal (sol s) else \<infinity>)
    }"

subsubsection {* @{text Sat} *}

fun Sat :: "'s sform \<Rightarrow> 's set option" where
"Sat true                   = Some S" |
"Sat (Label L)              = Some {s \<in> S. s \<in> L}" |
"Sat (Neg F)                = do { F \<leftarrow> Sat F ; Some (S - F) }" |
"Sat (And F1 F2)            = do { F1 \<leftarrow> Sat F1 ; F2 \<leftarrow> Sat F2 ; Some (F1 \<inter> F2) }" |

"Sat (Prob rel r (X F))        = do { F \<leftarrow> Sat F ; Some {q \<in> S. inrealrel rel r (\<Sum>q'\<in>F. \<tau> q q')} }" |
"Sat (Prob rel r (U k F1 F2))  = do { F1 \<leftarrow> Sat F1 ; F2 \<leftarrow> Sat F2 ; Some {q \<in> S. inrealrel rel r (ProbU q k F1 F2) } }" |
"Sat (Prob rel r (U\<^sup>\<infinity> F1 F2))   = do { F1 \<leftarrow> Sat F1 ; F2 \<leftarrow> Sat F2 ; P \<leftarrow> ProbUinfty F1 F2 ; Some {q \<in> S. inrealrel rel r (P q) } }" |

"Sat (Exp rel r (Cumm k))      = Some {s \<in> S. inrealrel rel r (ExpCumm s k) }" |
"Sat (Exp rel r (State k))     = Some {s \<in> S. inrealrel rel r (ExpState s k) }" |
"Sat (Exp rel r (Future F))    = do { F \<leftarrow> Sat F ; E \<leftarrow> ExpFuture F ; Some {q \<in> S. inrealrel rel (ereal r) (E q) } }"

lemma prob_sum:
  "s \<in> S \<Longrightarrow> Measurable.pred R.S P \<Longrightarrow> \<P>(\<omega> in T s. P \<omega>) = (\<Sum>t\<in>S. \<tau> s t * \<P>(\<omega> in T t. P (t ## \<omega>)))"
  unfolding prob_T using E_closed by (subst integral_measure_pmf[OF finite_S]) (auto simp: mult.commute)

lemma nn_integral_eq_sum:
  "s \<in> S \<Longrightarrow> f \<in> borel_measurable R.S \<Longrightarrow> (\<integral>\<^sup>+x. f x \<partial>T s) = (\<Sum>t\<in>S. \<tau> s t * (\<integral>\<^sup>+x. f (t ## x) \<partial>T t))"
  unfolding nn_integral_T using E_closed
  by (subst nn_integral_measure_pmf_support[OF finite_S])
     (auto simp: mult.commute nn_integral_nonneg)

lemma emeasure_T_space[simp]: "emeasure (T s) (space R.S) = 1"
  using T.emeasure_space_1 by simp

lemma \<tau>_distr[simp]: "s \<in> S \<Longrightarrow> (\<Sum>t\<in>S. \<tau> s t) = 1"
  using prob_sum[of s "\<lambda>_. True"] by simp

lemma ProbU:
  "q \<in> S \<Longrightarrow> ProbU q k (svalid F1) (svalid F2) = \<P>(\<omega> in T q. pvalid (U k F1 F2) (q ## \<omega>))"
proof (induct k arbitrary: q)
  case 0 with T.prob_space show ?case by simp
next
  case (Suc k)

  have "\<P>(\<omega> in T q. pvalid (U (Suc k) F1 F2) (q ## \<omega>)) =
    (if q \<in> svalid F2 then 1 else if q \<in> svalid F1 then
      \<Sum>t\<in>S. \<tau> q t * \<P>(\<omega> in T t. pvalid (U k F1 F2) (t ## \<omega>)) else 0)"
    using `q \<in> S` by (subst prob_sum) simp_all
  also have "\<dots> = ProbU q (Suc k) (svalid F1) (svalid F2)"
    using Suc by simp
  finally show ?case ..
qed

lemma Prob0_imp_not_Psi:
  assumes "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S" "s \<in> Prob0 \<Phi> \<Psi>" shows "s \<notin> \<Psi>"
proof -
  have "s \<in> S" using `s \<in> Prob0 \<Phi> \<Psi>` Prob0_subset_S by auto
  with assms show ?thesis by (auto simp add: Prob0_iff suntil_Stream)
qed

lemma Psi_imp_not_Prob0:
  assumes "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S" shows "s \<in> \<Psi> \<Longrightarrow> s \<notin> Prob0 \<Phi> \<Psi>"
  using Prob0_imp_not_Psi[OF assms] by metis

subsubsection {* Finite expected reward *}

abbreviation "s0 \<equiv> SOME s. s \<in> S"

lemma s0_in_S: "s0 \<in> S"
  using S_not_empty by (auto intro!: someI_ex[of "\<lambda>x. x \<in> S"])

lemma nn_integral_reward_finite:
  assumes "s \<in> S"
  assumes until: "AE \<omega> in T s. (HLD S suntil HLD (svalid F)) (s ## \<omega>)"
  shows "(\<integral>\<^sup>+ \<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) \<noteq> \<infinity>"
proof -
  have "(\<integral>\<^sup>+ \<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) = (\<integral>\<^sup>+ \<omega>. reward_until (svalid F) s \<omega> \<partial>T s)"
    using until by (auto intro!: nn_integral_cong_AE ev_suntil)
  also have "\<dots> \<noteq> \<infinity>"
  proof cases
    assume "s \<notin> svalid F"
    show ?thesis
    proof (rule nn_integral_reward_until_finite)
      have "(Sigma (- svalid F) E)\<^sup>* `` {s} \<subseteq> S"
        using E_rtrancl_closed[of s _ "- svalid F" E] `s \<in> S` by auto
      then show "finite ((Sigma (- svalid F) E)\<^sup>* `` {s})"
        using finite_S by (auto dest: finite_subset)
      show "AE \<omega> in T s. (ev (HLD (svalid F))) \<omega>"
        using until by (auto simp add: suntil_Stream `s \<notin> svalid F` intro: ev_suntil)
    qed auto
  qed simp
  finally show ?thesis .
qed

lemma uniqueness_of_ProbU:
  assumes sol:
    "\<forall>s\<in>S. (\<Sum>s'\<in>S. LES (Prob0 (svalid F1) (svalid F2) \<union> svalid F2) s s' * l s') =
      (if s \<in> svalid F2 then 1 else 0)"
  shows "\<forall>s\<in>S. l s = \<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>))"
proof (rule unique)
  show "svalid F1 \<subseteq> S" "svalid F2 \<subseteq> S"
    "Prob0 (svalid F1) (svalid F2) \<subseteq> Prob0 (svalid F1) (svalid F2) \<union> svalid F2"
    "svalid F2 \<subseteq> Prob0 (svalid F1) (svalid F2) \<union> svalid F2"
    "Prob0 (svalid F1) (svalid F2) \<union> svalid F2 \<subseteq> S"
    using svalid_subset_S by (auto simp: Prob0_def)
next
  fix s assume s: "s \<in> S" "s \<notin> Prob0 (svalid F1) (svalid F2) \<union> svalid F2"
  have "(\<Sum>s'\<in>S. (if s' = s then \<tau> s s' - 1 else \<tau> s s') * l s') =
    (\<Sum>s'\<in>S. \<tau> s s' * l s' - (if s' = s then 1 else 0) * l s')"
    by (auto intro!: setsum.cong simp: field_simps)
  also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * l s') - l s"
    using `s \<in> S` by (simp add: setsum_subtractf single_l)
  finally show "l s - 0 = (\<Sum>s'\<in>S. \<tau> s s' * l s')"
    using sol[THEN bspec, of s] s by (simp add: LES_def)
next
  fix s assume s: "s \<in> S" "s \<notin> Prob0 (svalid F1) (svalid F2) \<union> svalid F2"
  then show "\<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>)) - 0 =
    (\<Sum>t\<in>S. \<tau> s t * \<P>(\<omega> in T t. pvalid (U\<^sup>\<infinity> F1 F2) (t ## \<omega>)))"
    unfolding Prob0_iff[OF svalid_subset_S svalid_subset_S]
    by (subst prob_sum) (auto simp add: suntil_Stream)
next
  fix s assume "s \<in> Prob0 (svalid F1) (svalid F2) \<union> svalid F2"
  then show "l s = \<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>))"
  proof
    assume P0: "s \<in> Prob0 (svalid F1) (svalid F2)"
    then have "s \<in> S" "AE \<omega> in T s. \<not> (HLD (svalid F1) suntil HLD (svalid F2)) (s ## \<omega>)"
      unfolding Prob0_iff[OF svalid_subset_S svalid_subset_S] by auto
    then have "\<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>)) = 0"
      by (intro T.prob_eq_0_AE) simp
    moreover have "l s = 0"
      using `s \<in> S` P0 sol[THEN bspec, of s] Prob0_subset_S
        Prob0_imp_not_Psi[OF svalid_subset_S svalid_subset_S P0]
      by (auto simp: LES_def single_l split: split_if_asm)
    ultimately show "l s = \<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>))" by simp
  next
    assume s: "s \<in> svalid F2"
    moreover with svalid_subset_S have "s \<in> S" by auto
    moreover note Psi_imp_not_Prob0[OF svalid_subset_S svalid_subset_S s]
    ultimately have "l s = 1"
      using sol[THEN bspec, of s]
      by (auto simp: LES_def single_l dest: Psi_imp_not_Prob0[OF svalid_subset_S svalid_subset_S])
    then show "l s = \<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>))"
      using s by (simp add: suntil_Stream)
  qed
qed

lemma infinite_reward:
  fixes s F
  defines "N \<equiv> Prob0 S (svalid F)" (is "_ \<equiv> Prob0 S ?F")
  defines "Y \<equiv> Prob1 N S (svalid F)"
  assumes s: "s \<in> S" "s \<notin> Y"
  shows "(\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) = \<infinity>"
proof -
  { assume "(AE \<omega> in T s. ev (HLD ?F) \<omega>)"
    with AE_T_enabled have "(AE \<omega> in T s. (HLD S suntil HLD ?F) \<omega>)"
    proof eventually_elim
      fix \<omega> assume "ev (HLD ?F) \<omega>" "enabled s \<omega>"
      from this `s \<in> S` show "(HLD S suntil HLD ?F) \<omega>"
      proof (induction arbitrary: s)
        case (step \<omega>) show ?case
          using E_closed step.IH[of "shd \<omega>"] step.prems
          by (auto simp: subset_eq enabled.simps[of s] suntil.simps[of _ _ \<omega>] HLD_iff)
       qed (auto intro: suntil.intros)
    qed }
  moreover have "\<not> (AE \<omega> in T s. (HLD S suntil HLD ?F) (s ## \<omega>))"
    using s svalid_subset_S unfolding N_def Y_def by (simp add: Prob1_iff)
  ultimately have *: "\<not> (AE \<omega> in T s. ev (HLD ?F) (s ## \<omega>))"
    using `s \<in> S` by (cases "s \<in> ?F") (auto simp add: suntil_Stream ev_Stream)

  show ?thesis
  proof (rule ccontr)
    assume "\<not> ?thesis"
    from nn_integral_PInf_AE[OF _ this] `s\<in>S`
    have "AE \<omega> in T s. ev (HLD ?F) (s ## \<omega>)"
      by (simp split: split_if_asm)
    with * show False ..
  qed
qed

subsubsection {* The expected reward implies a unique LES *}

lemma existence_of_ExpFuture:
  fixes s F
  assumes N_def: "N \<equiv> Prob0 S (svalid F)" (is "_ \<equiv> Prob0 S ?F")
  assumes Y_def: "Y \<equiv> Prob1 N S (svalid F)"
  assumes s: "s \<in> S" "s \<notin> S - (Y - ?F)"
  shows "real (\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s)
    - (\<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s')) =
    (\<Sum>s'\<in>S. \<tau> s s' * real(\<integral>\<^sup>+\<omega>. reward (Future F) (s' ## \<omega>) \<partial>T s'))"
proof -
  let ?R = "reward (Future F)"

  from s have "s \<in> Prob1 (Prob0 S ?F) S ?F"
    unfolding Y_def N_def by auto
  then have AE_until: "AE \<omega> in T s. (HLD S suntil HLD (svalid F)) (s ## \<omega>)"
    using Prob1_iff[of S ?F] svalid_subset_S by auto

  from s have "s \<notin> ?F" by auto

  let ?E = "\<lambda>s'. \<integral>\<^sup>+ \<omega>. reward (Future F) (s' ## \<omega>) \<partial>T s'"
  have *: "(\<Sum>s'\<in>S. \<tau> s s' * ?E s') = (\<Sum>s'\<in>S. ereal (\<tau> s s' * real (?E s')))"
  proof (rule setsum.cong)
    fix s' assume "s' \<in> S"
    show "\<tau> s s' * ?E s' = ereal (\<tau> s s' * real (?E s'))"
    proof cases
      assume "\<tau> s s' \<noteq> 0"
      with `s \<in> S` `s' \<in> S` have "s' \<in> E s" by (simp add: set_pmf_iff)
      from `s \<notin> ?F` AE_until have "AE \<omega> in T s. (HLD S suntil HLD ?F) (s ## \<omega>)"
        using svalid_subset_S `s \<in> S` by simp
      with nn_integral_reward_finite[OF `s' \<in> S`, of F] `s \<in> S` `s' \<in> E s` `s \<notin> ?F`
      have "\<bar>?E s'\<bar> \<noteq> \<infinity>"
        by (simp add: nn_integral_nonneg AE_T_iff[of _ s] AE_measure_pmf_iff suntil_Stream
                 del: reward.simps)
      then show ?thesis by (cases "?E s'") auto
    qed (simp add: zero_ereal_def[symmetric])
  qed simp

  have "AE \<omega> in T s. ?R (s ## \<omega>) = \<rho> s + \<iota> s (shd \<omega>) + ?R \<omega>"
    using `s \<notin> svalid F` by (auto simp: ev_Stream)
  then have "(\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s) = (\<integral>\<^sup>+\<omega>. (\<rho> s + \<iota> s (shd \<omega>)) + ?R \<omega> \<partial>T s)"
    by (rule nn_integral_cong_AE)
  also have "\<dots> = (\<integral>\<^sup>+\<omega>. \<rho> s + \<iota> s (shd \<omega>) \<partial>T s) +
    (\<integral>\<^sup>+\<omega>. ?R \<omega> \<partial>T s)"
    using `s \<in> S`
    by (subst nn_integral_add)
       (auto simp add: space_PiM PiE_iff reward_nonneg \<iota>_nonneg \<rho>_nonneg simp del: reward.simps)
  also have "\<dots> = ereal (\<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s')) + (\<integral>\<^sup>+\<omega>. ?R \<omega> \<partial>T s)"
    using `s \<in> S`
    by (subst nn_integral_eq_sum)
       (auto simp: field_simps setsum.distrib setsum_right_distrib[symmetric] \<rho>_nonneg \<iota>_nonneg)
  finally show ?thesis
    apply (simp del: reward.simps)
    apply (subst nn_integral_eq_sum[OF `s \<in> S` reward_measurable])
    apply (simp del: reward.simps add: *)
    done
qed

lemma uniqueness_of_ExpFuture:
  fixes F
  assumes N_def: "N \<equiv> Prob0 S (svalid F)" (is "_ \<equiv> Prob0 S ?F")
  assumes Y_def: "Y \<equiv> Prob1 N S (svalid F)"
  assumes const_def: "const \<equiv> \<lambda>s. if s \<in> Y \<and> s \<notin> svalid F then - \<rho> s - (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s') else 0"
  assumes sol: "\<And>s. s\<in>S \<Longrightarrow> (\<Sum>s'\<in>S. LES (S - Y \<union> ?F) s s' * l s') = const s"
  shows "\<forall>s\<in>S. l s = real(\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s)"
    (is "\<forall>s\<in>S. l s = real(\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s)")
proof (rule unique)
  show "S \<subseteq> S" "?F \<subseteq> S" using svalid_subset_S by auto
  show "S - (Y - ?F) \<subseteq> S" "Prob0 S ?F \<subseteq> S - (Y - ?F)" "?F \<subseteq> S - (Y - ?F)"
    using svalid_subset_S
    by (auto simp add: Y_def N_def Prob1_iff)
       (auto simp add: Prob0_iff dest!: T.AE_contr)
next
  fix s assume "s \<in> S" "s \<notin> S - (Y - ?F)"
  then show "real (\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s) - (\<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s')) =
    (\<Sum>s'\<in>S. \<tau> s s' * real(\<integral>\<^sup>+\<omega>. ?R (s' ## \<omega>) \<partial>T s'))"
    by (rule existence_of_ExpFuture[OF N_def Y_def])
next
  fix s assume "s \<in> S" "s \<notin> S - (Y - ?F)"
  then have "s \<in> Y" "s \<notin> ?F" by auto
  have "(\<Sum>s'\<in>S. (if s' = s then \<tau> s s' - 1 else \<tau> s s') * l s') =
    (\<Sum>s'\<in>S. \<tau> s s' * l s' - (if s' = s then 1 else 0) * l s')"
    by (auto intro!: setsum.cong simp: field_simps)
  also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * l s') - l s"
    using `s \<in> S` by (simp add: setsum_subtractf single_l)
  finally have "l s = (\<Sum>s'\<in>S. \<tau> s s' * l s') - (\<Sum>s'\<in>S. (if s' = s then \<tau> s s' - 1 else \<tau> s s') * l s')"
    by (simp add: field_simps)
  then show "l s - (\<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s')) = (\<Sum>s'\<in>S. \<tau> s s' * l s')"
    using sol[OF `s \<in> S`] `s \<in> Y` `s \<notin> ?F` by (simp add: const_def LES_def)
next
  fix s assume s: "s \<in> S - (Y - ?F)"
  with sol[of s] have "l s = 0"
    by (cases "s \<in> ?F") (simp_all add: const_def LES_def single_l)
  also have "0 = real (\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s)"
  proof cases
    assume "s \<in> ?F" then show ?thesis
      by (simp add: HLD_iff ev_Stream)
  next
    assume "s \<notin> ?F"
    with s have "s \<in> S - Y" by auto
    with infinite_reward[of s F] show ?thesis
      by (simp add: Y_def N_def del: reward.simps)
  qed
  finally show "l s = real (\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s)" .
qed

lemma inrealrel_ereal[simp]: "inrealrel r (ereal x) (ereal y) \<longleftrightarrow> inrealrel r x y"
  by (cases r) auto

subsection {* Soundness of @{const Sat} *}

next
  case (6 rel r k F1 F2)
  then show ?case
    by (simp add: ProbU cong: conj_cong split: split_option_bind_asm)

next
  case (7 rel r F1 F2)
  moreover def constants \<equiv> "\<lambda>s::'s. if s \<in> (svalid F2) then 1 else (0::real)"
  moreover def distr \<equiv> "LES (Prob0 (svalid F1) (svalid F2) \<union> svalid F2)"
  ultimately obtain l where eq: "Sat F1 = Some (svalid F1)" "Sat F2 = Some (svalid F2)"
    and l: "gauss_jordan' distr constants = Some l"
    by atomize_elim (simp add: ProbUinfty_def split: split_option_bind_asm)

  from l have P: "ProbUinfty (svalid F1) (svalid F2) = Some l"
    unfolding ProbUinfty_def constants_def distr_def by simp

  have "\<forall>s\<in>S. l s = \<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>))"
  proof (rule uniqueness_of_ProbU)
    show "\<forall>s\<in>S. (\<Sum>s'\<in>S. LES (Prob0 (svalid F1) (svalid F2) \<union> svalid F2) s s' * l s') =
                   (if s \<in> svalid F2 then 1 else 0)"
      using gauss_jordan'_correct[OF l]
      unfolding distr_def constants_def by simp
  qed
  then show ?case
    by (auto simp add: eq P)
next
  case (8 rel r k)
  { fix s assume "s \<in> S"
    then have "ExpCumm s k = (\<integral>\<^sup>+ x. ereal (\<Sum>i<k. \<rho> ((s ## x) !! i) + \<iota> ((s ## x) !! i) (x !! i)) \<partial>T s)"
    proof (induct k arbitrary: s)
      case 0 then show ?case by simp
    next
      case (Suc k)
      have "(\<integral>\<^sup>+\<omega>. ereal (\<Sum>i<Suc k. \<rho> ((s ## \<omega>) !! i) + \<iota> ((s ## \<omega>) !! i) (\<omega> !! i)) \<partial>T s)
        = (\<integral>\<^sup>+\<omega>. ereal (\<rho> s + \<iota> s (\<omega> !! 0)) + ereal (\<Sum>i<k. \<rho> (\<omega> !! i) + \<iota> (\<omega> !! i) (\<omega> !! (Suc i))) \<partial>T s)"
        by (auto intro!: nn_integral_cong
                 simp: setsum.reindex lessThan_Suc_eq_insert_0 Zero_notin_Suc)
      also have "\<dots> = (\<integral>\<^sup>+\<omega>. \<rho> s + \<iota> s (\<omega> !! 0) \<partial>T s) +
          (\<integral>\<^sup>+\<omega>. (\<Sum>i<k. \<rho> (\<omega> !! i) + \<iota> (\<omega> !! i) (\<omega> !! (Suc i))) \<partial>T s)"
        using `s \<in> S`
        by (intro nn_integral_add AE_I2)
           (auto intro!: setsum_nonneg add_nonneg_nonneg \<iota>_nonneg \<rho>_nonneg)
      also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * (\<rho> s + \<iota> s s')) +
        (\<integral>\<^sup>+\<omega>. (\<Sum>i<k. \<rho> (\<omega> !! i) + \<iota> (\<omega> !! i) (\<omega> !! (Suc i))) \<partial>T s)"
        using `s \<in> S` by (subst nn_integral_eq_sum) (auto simp: \<rho>_nonneg \<iota>_nonneg)
      also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * (\<rho> s + \<iota> s s')) +
        (\<Sum>s'\<in>S. \<tau> s s' * ExpCumm s' k)"
        using `s \<in> S` by (subst nn_integral_eq_sum) (auto simp: Suc)
      also have "\<dots> = ExpCumm s (Suc k)"
        using `s \<in> S`
        by (simp add: field_simps setsum.distrib setsum_right_distrib[symmetric]
                      setsum_ereal[symmetric] plus_ereal.simps[symmetric] \<iota>_nonneg \<rho>_nonneg
                      ereal_pos_distrib pmf_nonneg
                 del: setsum_ereal)
      finally show ?case by simp
    qed }
  then show ?case by auto

next
  case (9 rel r k)
  { fix s assume "s \<in> S"
    then have "ExpState s k = (\<integral>\<^sup>+ x. ereal (\<rho> ((s ## x) !! k)) \<partial>T s)"
    proof (induct k arbitrary: s)
      case (Suc k) then show ?case by (simp add: nn_integral_eq_sum[of s])
    qed (simp add: \<rho>_nonneg) }
  then show ?case by auto

next
  case (10 rel r F)
  moreover
  let ?F = "svalid F"
  def N \<equiv> "Prob0 S ?F"
  moreover def Y \<equiv> "Prob1 N S ?F"
  moreover def const \<equiv> "\<lambda>s. if s \<in> Y \<and> s \<notin> ?F then - \<rho> s - (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s') else 0"
  ultimately obtain l
    where l: "gauss_jordan' (LES (S - Y \<union> ?F)) const = Some l"
    and F: "Sat F = Some ?F"
    by (auto simp: ExpFuture_def Let_def split: split_option_bind_asm)

  from l have EF: "ExpFuture ?F =
    Some (\<lambda>s. if s \<in> Y then ereal (l s) else \<infinity>)"
    unfolding ExpFuture_def N_def Y_def const_def by auto

  let ?R = "reward (Future F)"
  have l_eq: "\<forall>s\<in>S. l s = real(\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s)"
  proof (rule uniqueness_of_ExpFuture[OF N_def Y_def const_def])
    fix s assume "s \<in> S"
    show "\<And>s. s\<in>S \<Longrightarrow> (\<Sum>s'\<in>S. LES (S - Y \<union> ?F) s s' * l s') = const s"
      using gauss_jordan'_correct[OF l] by auto
  qed
  { fix s assume [simp]: "s \<in> S" "s \<in> Y"
    then have "s \<in> Prob1 (Prob0 S ?F) S ?F"
      unfolding Y_def N_def by auto
    then have "AE \<omega> in T s. (HLD S suntil HLD ?F) (s ## \<omega>)"
      using svalid_subset_S by (auto simp add: Prob1_iff)
    from nn_integral_reward_finite[OF `s \<in> S`] this nn_integral_nonneg
    have "\<bar>\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s\<bar> \<noteq> \<infinity>"
      by (simp add: nn_integral_nonneg)
    with l_eq `s \<in> S` have "(\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) = ereal (l s)"
      by auto }
  moreover
  { fix s assume "s \<in> S" "s \<notin> Y"
    with infinite_reward[of s F]
    have "(\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) = \<infinity>"
      by (simp add: Y_def N_def) }
  ultimately show ?case
    apply (auto simp add: EF F simp del: reward.simps)
    apply (case_tac "x \<in> Y")
    apply auto
    done
qed (auto split: split_option_bind_asm)

subsection {* Completeness of @{const Sat} *}

theorem Sat_complete:
  "Sat F \<noteq> None"
proof (induct F rule: Sat.induct)
  case (7 r rel \<Phi> \<Psi>)
  then have F: "Sat \<Phi> = Some (svalid \<Phi>)" "Sat \<Psi> = Some (svalid \<Psi>)"
    by (auto intro!: Sat_sound)

  def constants \<equiv> "\<lambda>s::'s. if s \<in> svalid \<Psi> then 1 else (0::real)"
  def distr \<equiv> "LES (Prob0 (svalid \<Phi>) (svalid \<Psi>) \<union> svalid \<Psi>)"
  have "\<exists>l. gauss_jordan' distr constants = Some l"
  proof (rule gauss_jordan'_complete[OF _ uniqueness_of_ProbU])
    show "\<forall>s\<in>S. (\<Sum>s'\<in>S. distr s s' * \<P>(\<omega> in T s'. pvalid (U\<^sup>\<infinity> \<Phi> \<Psi>) (s' ## \<omega>))) = constants s"
      apply (simp add: distr_def constants_def LES_def del: pvalid.simps space_T)
    proof safe
      fix s assume "s \<in> svalid \<Psi>" "s \<in> S"
      then show "(\<Sum>s'\<in>S. (if s' = s then 1 else 0) * \<P>(\<omega> in T s'. pvalid (U\<^sup>\<infinity> \<Phi> \<Psi>) (s' ## \<omega>))) = 1"
        by (simp add: single_l suntil_Stream)
    next
      fix s assume s: "s \<notin> svalid \<Psi>" "s \<in> S"
      let ?x = "\<lambda>s'. \<P>(\<omega> in T s'. pvalid (U\<^sup>\<infinity> \<Phi> \<Psi>) (s' ## \<omega>))"
      show "(\<Sum>s'\<in>S. (if s \<in> Prob0 (svalid \<Phi>) (svalid \<Psi>) then if s' = s then 1 else 0 else if s' = s then \<tau> s s' - 1 else \<tau> s s') * ?x s') = 0"
      proof cases
        assume "s \<in> Prob0 (svalid \<Phi>) (svalid \<Psi>)"
        with s show ?thesis
          by (simp add: single_l Prob0_iff svalid_subset_S T.prob_eq_0_AE del: space_T)
      next
        assume s_not_0: "s \<notin> Prob0 (svalid \<Phi>) (svalid \<Psi>)"
        with s have *:"\<And>s' \<omega>. s' \<in> S \<Longrightarrow> pvalid (U\<^sup>\<infinity> \<Phi> \<Psi>) (s ## s' ## \<omega>) = pvalid (U\<^sup>\<infinity> \<Phi> \<Psi>) (s' ## \<omega>)"
          by (auto simp: suntil_Stream Prob0_iff svalid_subset_S)

        have "(\<Sum>s'\<in>S. (if s' = s then \<tau> s s' - 1 else \<tau> s s') * ?x s') =
          (\<Sum>s'\<in>S. \<tau> s s' * ?x s' - (if s' = s then 1 else 0) * ?x s')"
          by (auto intro!: setsum.cong simp: field_simps)
        also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * ?x s') - ?x s"
          using s by (simp add: single_l setsum_subtractf)
        finally show ?thesis
          using * prob_sum[OF `s \<in> S`] s_not_0 by (simp del: pvalid.simps)
      qed
    qed
  qed (simp add: distr_def constants_def)
  then have P: "\<exists>l. ProbUinfty (svalid \<Phi>) (svalid \<Psi>) = Some l"
    unfolding ProbUinfty_def constants_def distr_def by simp
  with F show ?case
    by auto
next
  case (10 rel r \<Phi>)
  then have F: "Sat \<Phi> = Some (svalid \<Phi>)"
    by (auto intro!: Sat_sound)

  let ?F = "svalid \<Phi>"
  def N \<equiv> "Prob0 S ?F"
  def Y \<equiv> "Prob1 N S ?F"
  def const \<equiv> "\<lambda>s. if s \<in> Y \<and> s \<notin> ?F then - \<rho> s - (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s') else 0"
  let ?E = "\<lambda>s'. \<integral>\<^sup>+ \<omega>. reward (Future \<Phi>) (s' ## \<omega>) \<partial>T s'"
  have "\<exists>l. gauss_jordan' (LES (S - Y \<union> ?F)) const = Some l"
  proof (rule gauss_jordan'_complete[OF _ uniqueness_of_ExpFuture[OF N_def Y_def const_def]])
    show "\<forall>s\<in>S. (\<Sum>s'\<in>S. LES (S - Y \<union> svalid \<Phi>) s s' * real (?E s')) = const s"
    proof
      fix s assume "s \<in> S"
      show "(\<Sum>s'\<in>S. LES (S - Y \<union> svalid \<Phi>) s s' * real (?E s')) = const s"
      proof cases
        assume s: "s \<in> S - (Y - svalid \<Phi>)"
        show ?thesis
        proof cases
          assume "s \<in> Y"
          with `s \<in> S` s `s \<in> Y` show ?thesis
            by (simp add: LES_def const_def single_l ev_Stream)
        next
          assume "s \<notin> Y"
          with infinite_reward[of s \<Phi>] Y_def N_def s `s \<in> S`
          show ?thesis by (simp add: const_def LES_def single_l del: reward.simps)
        qed
      next
        assume s: "s \<notin> S - (Y - svalid \<Phi>)"

        have "(\<Sum>s'\<in>S. (if s' = s then \<tau> s s' - 1 else \<tau> s s') * real (?E s')) =
          (\<Sum>s'\<in>S. \<tau> s s' * real (?E s') - (if s' = s then 1 else 0) * real (?E s'))"
          by (auto intro!: setsum.cong simp: field_simps)
        also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * real (?E s')) - real (?E s)"
          using `s \<in> S` by (simp add: setsum_subtractf single_l)
        finally show ?thesis
          using s `s \<in> S` existence_of_ExpFuture[OF N_def Y_def `s \<in> S` s]
          by (simp add: LES_def const_def del: reward.simps)
      qed
    qed
  qed simp
  then have P: "\<exists>l. ExpFuture (svalid \<Phi>) = Some l"
    unfolding ExpFuture_def const_def N_def Y_def by auto
  with F show ?case
    by auto
qed (force split: split_option_bind)+

subsection {* Completeness and Soundness @{const Sat} *}

corollary Sat: "Sat \<Phi> = Some (svalid \<Phi>)"
  using Sat_sound Sat_complete by auto

end

end


theory ex4_04 imports Main "~~/src/HOL/IMP/Star" begin

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
for r where
irefl: "iter r 0 x x" |
istep: "iter r n xa y \<Longrightarrow> r x xa \<Longrightarrow> iter r (n+1) x y"

theorem "star r x y \<Longrightarrow> \<exists>n. iter r n x y"
apply(induction rule: star.induct)
apply (meson irefl)
by (meson istep)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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_40
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

theorem property0 :
  "((take Z xs) = (nil2))"
  oops

end


theory MFilter imports HOML
begin (*Some abbreviations for auxiliary operations*)
abbreviation a::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("_\<^bold>\<in>_")
                               where "x\<^bold>\<in>S \<equiv> S x"
abbreviation b::\<gamma> ("\<^bold>\<emptyset>") where "\<^bold>\<emptyset> \<equiv> \<lambda>x. \<^bold>\<bottom>"
abbreviation c::\<gamma> ("\<^bold>U") where "\<^bold>U \<equiv> \<lambda>x. \<^bold>\<top>"
abbreviation d::"\<gamma>\<Rightarrow>\<gamma>\<Rightarrow>\<sigma>" ("_\<^bold>\<subseteq>_")
             where "\<phi>\<^bold>\<subseteq>\<psi> \<equiv> \<^bold>\<forall>x.((\<phi> x) \<^bold>\<rightarrow> (\<psi> x))"
abbreviation e::"\<gamma>\<Rightarrow>\<gamma>\<Rightarrow>\<gamma>" ("_\<^bold>\<sqinter>_")
             where "\<phi>\<^bold>\<sqinter>\<psi> \<equiv> \<lambda>x.((\<phi> x) \<^bold>\<and> (\<psi> x))"
abbreviation f::"\<gamma>\<Rightarrow>\<gamma>" ("\<inverse>_") where "\<inverse>\<psi> \<equiv> \<lambda>x. \<^bold>\<not>(\<psi> x)"

(*Definition of modal filter*)
abbreviation g::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("Filter")
 where "Filter \<Phi> \<equiv> (((\<^bold>U\<^bold>\<in>\<Phi>) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<emptyset>\<^bold>\<in>\<Phi>))
         \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>. (((\<phi>\<^bold>\<in>\<Phi>) \<^bold>\<and> (\<phi>\<^bold>\<subseteq>\<psi>)) \<^bold>\<rightarrow> (\<psi>\<^bold>\<in>\<Phi>))))
         \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>. (((\<phi>\<^bold>\<in>\<Phi>) \<^bold>\<and> (\<psi>\<^bold>\<in>\<Phi>)) \<^bold>\<rightarrow> ((\<phi>\<^bold>\<sqinter>\<psi>)\<^bold>\<in>\<Phi>)))"

(*Definition of modal ultrafilter *)
abbreviation h::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("UFilter") where
 "UFilter \<Phi> \<equiv> (Filter \<Phi>)\<^bold>\<and>(\<^bold>\<forall>\<phi>.((\<phi>\<^bold>\<in>\<Phi>) \<^bold>\<or> ((\<inverse>\<phi>)\<^bold>\<in>\<Phi>)))"

(*Modal Filter and ultrafilter are consistent*)
lemma "\<lfloor>\<^bold>\<forall>\<Phi> \<phi>.((UFilter \<Phi>) \<^bold>\<rightarrow> \<^bold>\<not>((\<phi>\<^bold>\<in>\<Phi>) \<^bold>\<and> ((\<inverse>\<phi>)\<^bold>\<in>\<Phi>)))\<rfloor>"
  by force
end


theory Heap
  imports Main "../Algebra/PartialMonoid"
begin

section {* Heaplet Model *}

type_synonym heap = "nat \<Rightarrow> nat option"

definition ortho :: "(nat \<Rightarrow> nat option) \<Rightarrow> (nat \<Rightarrow> nat option) \<Rightarrow> bool" (infix "\<bottom>" 55)
  where "h1 \<bottom> h2 \<equiv> dom h1 \<inter> dom h2 = {}"

lemma theI: "h x = Some y \<Longrightarrow> the (h x) = y"
  by simp

lemma heap_divider: "h1 \<bottom> h2 \<Longrightarrow> h1 x = Some y \<Longrightarrow> (h1 ++ h2) x = Some y"
  by (auto simp: ortho_def map_add_def split: option.splits)

lemma heap_add_comm: "h1 \<bottom> h2 \<Longrightarrow> h1 ++ h2 = h2 ++ h1"
  by (auto simp: ortho_def intro: map_add_comm)

interpretation partial_comm_monoid map_add ortho Map.empty
  by default (auto simp: ortho_def intro: map_add_comm)

lemma heap_split: "h x = Some y \<Longrightarrow> h = [x \<mapsto> y] ++ h(x := None)"
  by (metis (mono_tags, lifting) domIff empty_map_add fun_upd_same fun_upd_triv fun_upd_upd map_add_upd_left)

end