(*  Title:       Utilities for Lambda-Free Orders
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Utilities for Lambda-Free Orders\<close>

theory Lambda_Free_Util
imports "HOL-Library.Extended_Nat" "HOL-Library.Multiset_Order"
begin

text \<open>
This theory gathers various lemmas that likely belong elsewhere in Isabelle or
the \emph{Archive of Formal Proofs}. Most (but certainly not all) of them are
used to formalize orders on \<open>\<lambda>\<close>-free higher-order terms.
\<close>

subsection \<open>Finite Sets\<close>

lemma finite_set_fold_singleton[simp]: "Finite_Set.fold f z {x} = f x z"
proof -
  have "fold_graph f z {x} (f x z)"
    by (auto intro: fold_graph.intros)
  moreover
  {
    fix X y
    have "fold_graph f z X y \<Longrightarrow> (X = {} \<longrightarrow> y = z) \<and> (X = {x} \<longrightarrow> y = f x z)"
      by (induct rule: fold_graph.induct) auto
  }
  ultimately have "(THE y. fold_graph f z {x} y) = f x z"
    by blast
  thus ?thesis
    by (simp add: Finite_Set.fold_def)
qed

subsection \<open>Function Power\<close>

lemma funpow_lesseq_iter:
  fixes f :: "('a::order) \<Rightarrow> 'a"
  assumes mono: "\<And>k. k \<le> f k" and m_le_n: "m \<le> n"
  shows "(f ^^ m) k \<le> (f ^^ n) k"
  using m_le_n by (induct n) (fastforce simp: le_Suc_eq intro: mono order_trans)+

lemma funpow_less_iter:
  fixes f :: "('a::order) \<Rightarrow> 'a"
  assumes mono: "\<And>k. k < f k" and m_lt_n: "m < n"
  shows "(f ^^ m) k < (f ^^ n) k"
  using m_lt_n by (induct n) (auto, blast intro: mono less_trans dest: less_antisym)

subsection \<open>Least Operator\<close>

lemma Least_eq[simp]: "(LEAST y. y = x) = x" and "(LEAST y. x = y) = x" for x :: "'a::order"
  by (blast intro: Least_equality)+

lemma Least_in_nonempty_set_imp_ex:
  fixes f :: "'b \<Rightarrow> ('a::wellorder)"
  assumes
    A_nemp: "A \<noteq> {}" and
    P_least: "P (LEAST y. \<exists>x \<in> A. y = f x)"
  shows "\<exists>x \<in> A. P (f x)"
proof -
  obtain a where a: "a \<in> A"
    using A_nemp by fast
  have "\<exists>x. x \<in> A \<and> (LEAST y. \<exists>x. x \<in> A \<and> y = f x) = f x"
    by (rule LeastI[of _ "f a"]) (fast intro: a)
  thus ?thesis
    by (metis P_least)
qed

lemma Least_eq_0_enat: "P 0 \<Longrightarrow> (LEAST x :: enat. P x) = 0"
  by (simp add: Least_equality)

subsection \<open>Antisymmetric Relations\<close>

lemma irrefl_trans_imp_antisym: "irrefl r \<Longrightarrow> trans r \<Longrightarrow> antisym r"
  unfolding irrefl_def trans_def antisym_def by fast

lemma irreflp_transp_imp_antisymP: "irreflp p \<Longrightarrow> transp p \<Longrightarrow> antisymp p"
  by (fact irrefl_trans_imp_antisym [to_pred])

subsection \<open>Acyclic Relations\<close>

lemma finite_nonempty_ex_succ_imp_cyclic:
  assumes
    fin: "finite A" and
    nemp: "A \<noteq> {}" and
    ex_y: "\<forall>x \<in> A. \<exists>y \<in> A. (y, x) \<in> r"
  shows "\<not> acyclic r"
proof -
  let ?R = "{(x, y). x \<in> A \<and> y \<in> A \<and> (x, y) \<in> r}"

  have R_sub_r: "?R \<subseteq> r"
    by auto

  have "?R \<subseteq> A \<times> A"
    by auto
  hence fin_R: "finite ?R"
    by (auto intro: fin dest!: infinite_super)

  have "\<not> acyclic ?R"
    by (rule notI, drule finite_acyclic_wf[OF fin_R], unfold wf_eq_minimal, drule spec[of _ A],
      use ex_y nemp in blast)
  thus ?thesis
    using R_sub_r acyclic_subset by auto
qed

subsection \<open>Reflexive, Transitive Closure\<close>

lemma relcomp_subset_left_imp_relcomp_trancl_subset_left:
  assumes sub: "R O S \<subseteq> R"
  shows "R O S\<^sup>* \<subseteq> R"
proof
  fix x
  assume "x \<in> R O S\<^sup>*"
  then obtain n where "x \<in> R O S ^^ n"
    using rtrancl_imp_relpow by fastforce
  thus "x \<in> R"
  proof (induct n)
    case (Suc m)
    thus ?case
      by (metis (no_types) O_assoc inf_sup_ord(3) le_iff_sup relcomp_distrib2 relpow.simps(2)
        relpow_commute sub subsetCE)
  qed auto
qed

lemma f_chain_in_rtrancl:
  assumes m_le_n: "m \<le> n" and f_chain: "\<forall>i \<in> {m..<n}. (f i, f (Suc i)) \<in> R"
  shows "(f m, f n) \<in> R\<^sup>*"
proof (rule relpow_imp_rtrancl, rule relpow_fun_conv[THEN iffD2], intro exI conjI)
  let ?g = "\<lambda>i. f (m + i)"
  let ?k = "n - m"

  show "?g 0 = f m"
    by simp
  show "?g ?k = f n"
    using m_le_n by force
  show "(\<forall>i < ?k. (?g i, ?g (Suc i)) \<in> R)"
    by (simp add: f_chain)
qed

lemma f_rev_chain_in_rtrancl:
  assumes m_le_n: "m \<le> n" and f_chain: "\<forall>i \<in> {m..<n}. (f (Suc i), f i) \<in> R"
  shows "(f n, f m) \<in> R\<^sup>*"
  by (rule f_chain_in_rtrancl[OF m_le_n, of "\<lambda>i. f (n + m - i)", simplified])
    (metis f_chain le_add_diff Suc_diff_Suc Suc_leI atLeastLessThan_iff diff_Suc_diff_eq1 diff_less
      le_add1 less_le_trans zero_less_Suc)

subsection \<open>Well-Founded Relations\<close>

lemma wf_app: "wf r \<Longrightarrow> wf {(x, y). (f x, f y) \<in> r}"
  unfolding wf_eq_minimal by (intro allI, drule spec[of _ "f ` Q" for Q]) fast

lemma wfP_app: "wfP p \<Longrightarrow> wfP (\<lambda>x y. p (f x) (f y))"
  unfolding wfP_def by (rule wf_app[of "{(x, y). p x y}" f, simplified])

lemma wf_exists_minimal:
  assumes wf: "wf r" and Q: "Q x"
  shows "\<exists>x. Q x \<and> (\<forall>y. (f y, f x) \<in> r \<longrightarrow> \<not> Q y)"
  using wf_eq_minimal[THEN iffD1, OF wf_app[OF wf], rule_format, of _ "{x. Q x}", simplified, OF Q]
  by blast

lemma wfP_exists_minimal:
  assumes wf: "wfP p" and Q: "Q x"
  shows "\<exists>x. Q x \<and> (\<forall>y. p (f y) (f x) \<longrightarrow> \<not> Q y)"
  by (rule wf_exists_minimal[of "{(x, y). p x y}" Q x, OF wf[unfolded wfP_def] Q, simplified])

lemma finite_irrefl_trans_imp_wf: "finite r \<Longrightarrow> irrefl r \<Longrightarrow> trans r \<Longrightarrow> wf r"
  by (erule finite_acyclic_wf) (simp add: acyclic_irrefl)

lemma finite_irreflp_transp_imp_wfp:
  "finite {(x, y). p x y} \<Longrightarrow> irreflp p \<Longrightarrow> transp p \<Longrightarrow> wfP p"
  using finite_irrefl_trans_imp_wf[of "{(x, y). p x y}"]
  unfolding wfP_def transp_def irreflp_def trans_def irrefl_def mem_Collect_eq prod.case
  by assumption

lemma wf_infinite_down_chain_compatible:
  assumes
    wf_R: "wf R" and
    inf_chain_RS: "\<forall>i. (f (Suc i), f i) \<in> R \<union> S" and
    O_subset: "R O S \<subseteq> R"
  shows "\<exists>k. \<forall>i. (f (Suc (i + k)), f (i + k)) \<in> S"
proof (rule ccontr)
  assume "\<nexists>k. \<forall>i. (f (Suc (i + k)), f (i + k)) \<in> S"
  hence "\<forall>k. \<exists>i. (f (Suc (i + k)), f (i + k)) \<notin> S"
    by blast
  hence "\<forall>k. \<exists>i > k. (f (Suc i), f i) \<notin> S"
    by (metis add.commute add_Suc less_add_Suc1)
  hence "\<forall>k. \<exists>i > k. (f (Suc i), f i) \<in> R"
    using inf_chain_RS by blast
  hence "\<exists>i > k. (f (Suc i), f i) \<in> R \<and> (\<forall>j > k. (f (Suc j), f j) \<in> R \<longrightarrow> j \<ge> i)" for k
    using wf_eq_minimal[THEN iffD1, OF wf_less, rule_format,
      of _ "{i. i > k \<and> (f (Suc i), f i) \<in> R}", simplified]
    by (meson not_less)
  then obtain j_of where
    j_of_gt: "\<And>k. j_of k > k" and
    j_of_in_R: "\<And>k. (f (Suc (j_of k)), f (j_of k)) \<in> R" and
    j_of_min: "\<And>k. \<forall>j > k. (f (Suc j), f j) \<in> R \<longrightarrow> j \<ge> j_of k"
    by moura

  have j_of_min_s: "\<And>k j. j > k \<Longrightarrow> j < j_of k \<Longrightarrow> (f (Suc j), f j) \<in> S"
    using j_of_min inf_chain_RS by fastforce

  define g :: "nat \<Rightarrow> 'a" where "\<And>k. g k = f (Suc ((j_of ^^ k) 0))"

  have between_g[simplified]: "(f ((j_of ^^ (Suc i)) 0), f (Suc ((j_of ^^ i) 0))) \<in> S\<^sup>*" for i
  proof (rule f_rev_chain_in_rtrancl; clarify?)
    show "Suc ((j_of ^^ i) 0) \<le> (j_of ^^ Suc i) 0"
      using j_of_gt by (simp add: Suc_leI)
  next
    fix ia
    assume ia: "ia \<in> {Suc ((j_of ^^ i) 0)..<(j_of ^^ Suc i) 0}"
    have ia_gt: "ia > (j_of ^^ i) 0"
      using ia by auto
    have ia_lt: "ia < j_of ((j_of ^^ i) 0)"
      using ia by auto
    show "(f (Suc ia), f ia) \<in> S"
      by (rule j_of_min_s[OF ia_gt ia_lt])
  qed

  have "\<And>i. (g (Suc i), g i) \<in> R"
    unfolding g_def funpow.simps comp_def
    by (rule subsetD[OF relcomp_subset_left_imp_relcomp_trancl_subset_left[OF O_subset]])
      (rule relcompI[OF j_of_in_R between_g])
  moreover have "\<forall>f. \<exists>i. (f (Suc i), f i) \<notin> R"
    using wf_R[unfolded wf_iff_no_infinite_down_chain] by blast
  ultimately show False
    by blast
qed

subsection \<open>Wellorders\<close>

lemma (in wellorder) exists_minimal:
  fixes x :: 'a
  assumes "P x"
  shows "\<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> y \<ge> x)"
  using assms by (auto intro: LeastI Least_le)

subsection \<open>Lists\<close>

lemma rev_induct2[consumes 1, case_names Nil snoc]:
  "length xs = length ys \<Longrightarrow> P [] [] \<Longrightarrow>
   (\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (xs @ [x]) (ys @ [y])) \<Longrightarrow> P xs ys"
proof (induct xs arbitrary: ys rule: rev_induct)
  case (snoc x xs ys)
  thus ?case
    by (induct ys rule: rev_induct) simp_all
qed auto

lemma in_lists_iff_set: "xs \<in> lists A \<longleftrightarrow> set xs \<subseteq> A"
  by fast

lemma butlast_append_Cons[simp]: "butlast (xs @ y # ys) = xs @ butlast (y # ys)"
  using butlast_append[of xs "y # ys", simplified] by simp

lemma rev_in_lists[simp]: "rev xs \<in> lists A \<longleftrightarrow> xs \<in> lists A"
  by auto

lemma hd_le_sum_list:
  fixes xs :: "'a::ordered_ab_semigroup_monoid_add_imp_le list"
  assumes "xs \<noteq> []" and "\<forall>i < length xs. xs ! i \<ge> 0"
  shows "hd xs \<le> sum_list xs"
  using assms
  by (induct xs rule: rev_induct, simp_all,
    metis add_cancel_right_left add_increasing2 hd_append2 lessI less_SucI list.sel(1) nth_append
      nth_append_length order_refl self_append_conv2 sum_list.Nil)

lemma sum_list_ge_length_times:
  fixes a :: "'a::{ordered_ab_semigroup_add,semiring_1}"
  assumes "\<forall>i < length xs. xs ! i \<ge> a"
  shows "sum_list xs \<ge> of_nat (length xs) * a"
  using assms
proof (induct xs)
  case (Cons x xs)
  note ih = this(1) and xxs_i_ge_a = this(2)

  have xs_i_ge_a: "\<forall>i < length xs. xs ! i \<ge> a"
    using xxs_i_ge_a by auto

  have "x \<ge> a"
    using xxs_i_ge_a by auto
  thus ?case
    using ih[OF xs_i_ge_a] by (simp add: ring_distribs ordered_ab_semigroup_add_class.add_mono)
qed auto

lemma zip_append_0_upt:
  "zip (xs @ ys) [0..<length xs + length ys] =
   zip xs [0..<length xs] @ zip ys [length xs..<length xs + length ys]"
proof (induct ys arbitrary: xs)
  case (Cons y ys)
  note ih = this
  show ?case
    using ih[of "xs @ [y]"] by (simp, cases ys, simp, simp add: upt_rec)
qed auto

lemma zip_eq_butlast_last:
  assumes len_gt0: "length xs > 0" and len_eq: "length xs = length ys"
  shows "zip xs ys = zip (butlast xs) (butlast ys) @ [(last xs, last ys)]"
  using len_eq len_gt0 by (induct rule: list_induct2) auto

subsection \<open>Extended Natural Numbers\<close>

lemma the_enat_0[simp]: "the_enat 0 = 0"
  by (simp add: zero_enat_def)

lemma the_enat_1[simp]: "the_enat 1 = 1"
  by (simp add: one_enat_def)

lemma enat_le_minus_1_imp_lt: "m \<le> n - 1 \<Longrightarrow> n \<noteq> \<infinity> \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> m < n" for m n :: enat
  by (cases m; cases n; simp add: zero_enat_def one_enat_def)

lemma enat_diff_diff_eq: "k - m - n = k - (m + n)" for k m n :: enat
  by (cases k; cases m; cases n) auto

lemma enat_the_enat_iden[simp]: "n \<noteq> \<infinity> \<Longrightarrow> enat (the_enat n) = n"
  by auto

lemma the_enat_minus_nat: "m \<noteq> \<infinity> \<Longrightarrow> the_enat (m - enat n) = the_enat m - n"
  by auto

lemma enat_the_enat_le: "enat (the_enat x) \<le> x"
  by (cases x; simp)

lemma enat_the_enat_minus_le: "enat (the_enat (x - y)) \<le> x"
  by (cases x; cases y; simp)

lemma enat_le_imp_minus_le: "k \<le> m \<Longrightarrow> k - n \<le> m" for k m n :: enat
  by (metis Groups.add_ac(2) enat_diff_diff_eq enat_ord_simps(3) enat_sub_add_same
    enat_the_enat_iden enat_the_enat_minus_le idiff_0_right idiff_infinity idiff_infinity_right
    order_trans_rules(23) plus_enat_simps(3))

lemma add_diff_assoc2_enat: "m \<ge> n \<Longrightarrow> m - n + p = m + p - n" for m n p :: enat
  by (cases m; cases n; cases p; auto)

lemma enat_mult_minus_distrib: "enat x * (y - z) = enat x * y - enat x * z"
  by (cases y; cases z; auto simp: enat_0 right_diff_distrib')

subsection \<open>Multisets\<close>

lemma add_mset_lt_left_lt: "a < b \<Longrightarrow> add_mset a A < add_mset b A"
  unfolding less_multiset\<^sub>H\<^sub>O by auto

lemma add_mset_le_left_le: "a \<le> b \<Longrightarrow> add_mset a A \<le> add_mset b A" for a :: "'a :: linorder"
  unfolding less_multiset\<^sub>H\<^sub>O by auto

lemma add_mset_lt_right_lt: "A < B \<Longrightarrow> add_mset a A < add_mset a B"
  unfolding less_multiset\<^sub>H\<^sub>O by auto

lemma add_mset_le_right_le: "A \<le> B \<Longrightarrow> add_mset a A \<le> add_mset a B"
  unfolding less_multiset\<^sub>H\<^sub>O by auto

lemma add_mset_lt_lt_lt:
  assumes a_lt_b: "a < b" and A_le_B: "A < B"
  shows "add_mset a A < add_mset b B"
  by (rule less_trans[OF add_mset_lt_left_lt[OF a_lt_b] add_mset_lt_right_lt[OF A_le_B]])

lemma add_mset_lt_lt_le: "a < b \<Longrightarrow> A \<le> B \<Longrightarrow> add_mset a A < add_mset b B"
  using add_mset_lt_lt_lt le_neq_trans by fastforce

lemma add_mset_le_le_le:
  fixes a :: "'a :: linorder"
  assumes a_le_b: "a \<le> b" and A_le_B: "A \<le> B"
  shows "add_mset a A \<le> add_mset b B"
  by (rule order.trans[OF add_mset_le_left_le[OF a_le_b] add_mset_le_right_le[OF A_le_B]])

declare filter_eq_replicate_mset [simp] image_mset_subseteq_mono [intro]

lemma nonempty_subseteq_mset_eq_singleton: "M \<noteq> {#} \<Longrightarrow> M \<subseteq># {#x#} \<Longrightarrow> M = {#x#}"
  by (cases M) (auto dest: subset_mset.diff_add)

lemma nonempty_subseteq_mset_iff_singleton: "(M \<noteq> {#} \<and> M \<subseteq># {#x#} \<and> P) \<longleftrightarrow> M = {#x#} \<and> P"
  by (cases M) (auto dest: subset_mset.diff_add)

lemma count_gt_imp_in_mset[intro]: "count M x > n \<Longrightarrow> x \<in># M"
  using count_greater_zero_iff by fastforce

lemma size_lt_imp_ex_count_lt: "size M < size N \<Longrightarrow> \<exists>x \<in># N. count M x < count N x"
  by (metis count_eq_zero_iff leD not_le_imp_less not_less_zero size_mset_mono subseteq_mset_def)

lemma filter_filter_mset[simp]: "{#x \<in># {#x \<in># M. Q x#}. P x#} = {#x \<in># M. P x \<and> Q x#}"
  by (induct M) auto

lemma size_filter_ne_elem: "x \<in># M \<Longrightarrow> size {#y \<in># M. y \<noteq> x#} < size M"
  by (simp add: size_filter_unsat_elem[of x M "\<lambda>y. y \<noteq> x"])

lemma size_eq_ex_count_lt:
  assumes
    sz_m_eq_n: "size M = size N" and
    m_eq_n: "M \<noteq> N"
  shows "\<exists>x. count M x < count N x"
proof -
  obtain x where "count M x \<noteq> count N x"
    using m_eq_n by (meson multiset_eqI)
  moreover
  {
    assume "count M x < count N x"
    hence ?thesis
      by blast
  }
  moreover
  {
    assume cnt_x: "count M x > count N x"

    have "size {#y \<in># M. y = x#} + size {#y \<in># M. y \<noteq> x#} =
      size {#y \<in># N. y = x#} + size {#y \<in># N. y \<noteq> x#}"
      using sz_m_eq_n multiset_partition by (metis size_union)
    hence sz_m_minus_x: "size {#y \<in># M. y \<noteq> x#} < size {#y \<in># N. y \<noteq> x#}"
      using cnt_x by simp
    then obtain y where "count {#y \<in># M. y \<noteq> x#} y < count {#y \<in># N. y \<noteq> x#} y"
      using size_lt_imp_ex_count_lt[OF sz_m_minus_x] by blast
    hence "count M y < count N y"
      by (metis count_filter_mset less_asym)
    hence ?thesis
      by blast
  }
  ultimately show ?thesis
    by fastforce
qed

  let ?Ma = "{#y \<in># M. y \<noteq> x#}"
  let ?Mb = "{#y \<in># M. y = x#}"
  let ?Na = "{#y \<in># N. y \<noteq> x#}"
  let ?Nb = "{#y \<in># N. y = x#}"

  have m_part: "M = ?Mb + ?Ma" and n_part: "N = ?Nb + ?Na"
    using multiset_partition by blast+

  have f_eq_ma_na: "F = set_mset ?Ma \<union> set_mset ?Na"
    using x_f_eq_m_n x_ni_f by auto

  show ?case
  proof (cases "count (image_mset f ?Ma) b < count (image_mset f ?Na) b")
    case cnt_ba: True
    obtain xa where "f xa = b" and "count ?Ma xa < count ?Na xa"
      using ih[OF f_eq_ma_na cnt_ba] by blast
    thus ?thesis
      by (metis count_filter_mset not_less0)
  next
    case cnt_ba: False
    have fx_eq_b: "f x = b"
      using cnt_b cnt_ba by (subst (asm) m_part, subst (asm) n_part, auto, presburger)
    moreover have "count M x < count N x"
      using cnt_b cnt_ba by (subst (asm) m_part, subst (asm) n_part, auto simp: fx_eq_b)
    ultimately show ?thesis
      by blast
  qed
qed auto

lemma count_image_mset_lt_imp_lt:
  assumes cnt_b: "count (image_mset f M) b < count (image_mset f N) b"
  shows "\<exists>x. f x = b \<and> count M x < count N x"
  by (rule count_image_mset_lt_imp_lt_raw[of "set_mset M \<union> set_mset N", OF _ refl cnt_b]) auto

lemma count_image_mset_le_imp_lt_raw:
  assumes
    "finite A" and
    "A = set_mset M \<union> set_mset N" and
    "count (image_mset f M) (f a) + count N a < count (image_mset f N) (f a) + count M a"
  shows "\<exists>b. f b = f a \<and> count M b < count N b"
  using assms
proof (induct A arbitrary: M N rule: finite_induct)
  case (insert x F)
  note fin = this(1) and x_ni_f = this(2) and ih = this(3) and x_f_eq_m_n = this(4) and
    cnt_lt = this(5)

  let ?Ma = "{#y \<in># M. y \<noteq> x#}"
  let ?Mb = "{#y \<in># M. y = x#}"
  let ?Na = "{#y \<in># N. y \<noteq> x#}"
  let ?Nb = "{#y \<in># N. y = x#}"

  have m_part: "M = ?Mb + ?Ma" and n_part: "N = ?Nb + ?Na"
    using multiset_partition by blast+

  have f_eq_ma_na: "F = set_mset ?Ma \<union> set_mset ?Na"
    using x_f_eq_m_n x_ni_f by auto

  show ?case
  proof (cases "f x = f a")
    case fx_ne_fa: False

    have cnt_fma_fa: "count (image_mset f ?Ma) (f a) = count (image_mset f M) (f a)"
      using fx_ne_fa by (subst (2) m_part) auto
    have cnt_fna_fa: "count (image_mset f ?Na) (f a) = count (image_mset f N) (f a)"
      using fx_ne_fa by (subst (2) n_part) auto
    have cnt_ma_a: "count ?Ma a = count M a"
      using fx_ne_fa by (subst (2) m_part) auto
    have cnt_na_a: "count ?Na a = count N a"
      using fx_ne_fa by (subst (2) n_part) auto

    obtain b where fb_eq_fa: "f b = f a" and cnt_b: "count ?Ma b < count ?Na b"
      using ih[OF f_eq_ma_na] cnt_lt unfolding cnt_fma_fa cnt_fna_fa cnt_ma_a cnt_na_a by blast
    have fx_ne_fb: "f x \<noteq> f b"
      using fb_eq_fa fx_ne_fa by simp

    have cnt_ma_b: "count ?Ma b = count M b"
      using fx_ne_fb by (subst (2) m_part) auto
    have cnt_na_b: "count ?Na b = count N b"
      using fx_ne_fb by (subst (2) n_part) auto

    show ?thesis
      using fb_eq_fa cnt_b unfolding cnt_ma_b cnt_na_b by blast
  next
    case fx_eq_fa: True
    show ?thesis
    proof (cases "x = a")
      case x_eq_a: True
      have "count (image_mset f ?Ma) (f a) + count ?Na a
        < count (image_mset f ?Na) (f a) + count ?Ma a"
        using cnt_lt x_eq_a by (subst (asm) (1 2) m_part, subst (asm) (1 2) n_part, auto)
      thus ?thesis
        using ih[OF f_eq_ma_na] by (metis count_filter_mset nat_neq_iff)
    next
      case x_ne_a: False
      show ?thesis
      proof (cases "count M x < count N x")
        case True
        thus ?thesis
          using fx_eq_fa by blast
     next
        case False
        hence cnt_x: "count M x \<ge> count N x"
          by fastforce
        have "count M x + count (image_mset f ?Ma) (f a) + count ?Na a
          < count N x + count (image_mset f ?Na) (f a) + count ?Ma a"
          using cnt_lt x_ne_a fx_eq_fa by (subst (asm) (1 2) m_part, subst (asm) (1 2) n_part, auto)
        hence "count (image_mset f ?Ma) (f a) + count ?Na a
          < count (image_mset f ?Na) (f a) + count ?Ma a"
          using cnt_x by linarith
        thus ?thesis
          using ih[OF f_eq_ma_na] by (metis count_filter_mset nat_neq_iff)
      qed
    qed
  qed
qed auto

lemma count_image_mset_le_imp_lt:
  assumes
    "count (image_mset f M) (f a) \<le> count (image_mset f N) (f a)" and
    "count M a > count N a"
  shows "\<exists>b. f b = f a \<and> count M b < count N b"
  using assms by (auto intro: count_image_mset_le_imp_lt_raw[of "set_mset M \<union> set_mset N"])

lemma Max_in_mset: "M \<noteq> {#} \<Longrightarrow> Max_mset M \<in># M"
  by simp

lemma Max_lt_imp_lt_mset:
  assumes n_nemp: "N \<noteq> {#}" and max: "Max_mset M < Max_mset N" (is "?max_M < ?max_N")
  shows "M < N"
proof (cases "M = {#}")
  case m_nemp: False

  have max_n_in_n: "?max_N \<in># N"
    using n_nemp by simp
  have max_n_nin_m: "?max_N \<notin># M"
    using max Max_ge leD by auto

  have "M \<noteq> N"
    using max by auto
  moreover
  {
    fix y
    assume "count N y < count M y"
    hence "y \<in># M"
      by blast
    hence "?max_M \<ge> y"
      by simp
    hence "?max_N > y"
      using max by auto
    hence "\<exists>x > y. count M x < count N x"
      using max_n_nin_m max_n_in_n by fastforce
  }
  ultimately show ?thesis
    unfolding less_multiset\<^sub>H\<^sub>O by blast
qed (auto simp: n_nemp)

lemma fold_mset_singleton[simp]: "fold_mset f z {#x#} = f x z"
  by (simp add: fold_mset_def)

end


theory Topological_Spaces
imports Category Orders
begin

locale "open" =
  fixes "open" :: "'a set set"

locale topological_space = "open" +
  fixes universe :: "'a set"
  assumes open_empty [simp, intro]: "{} \<in> open"
  assumes open_UNIV [simp, intro]: "universe \<in> open"
  assumes open_subsets: "x \<in> open \<Longrightarrow> x \<subseteq> universe"
  assumes open_Int [intro]: "S \<in> open \<Longrightarrow> T \<in> open \<Longrightarrow> (S \<inter> T) \<in> open "
  assumes open_Union [intro]: "\<forall>S\<in>K. S \<in> open \<Longrightarrow> (\<Union>K) \<in> open "

locale finite_topological_space = topological_space +
  assumes finite_universe[simp]: "finite universe"

locale cover = topological_space +
  fixes covering :: "'a set set"
  assumes cover_open[simp, intro]: "covering \<subseteq> open"
  assumes covers: "\<Union>(covering) = universe"

definition "lower S \<equiv> {X. \<exists>Y\<in>S. X \<le> Y}"

lemma Sup_is_lower_Sup:"\<Union>S = \<Union>(lower S)"
  apply (clarsimp simp: lower_def)
  apply (safe; clarsimp)

   apply blast
  apply blast
  done

term lattice

locale maximal_cover = cover +
  assumes antichain: "x \<in> covering \<Longrightarrow> y \<in> covering \<Longrightarrow> \<not> (x \<subset> y) "

lemma maximal_in_finite_set: "x \<in> S \<Longrightarrow> P (x :: 'a :: preorder) \<Longrightarrow> finite S \<Longrightarrow> (\<exists>y\<ge>x. y \<in> S \<and>  P y \<and> (\<forall>z\<in>S. P z \<longrightarrow> \<not>(z > y)))"
  apply (induct S arbitrary: x rule:infinite_finite_induct; clarsimp)
  apply (elim disjE; clarsimp?)
   apply (metis (no_types, lifting) dual_order.refl less_le_not_le order_trans)
  by (metis (full_types) dual_order.strict_trans2 less_le_not_le)

definition "maximal P x \<equiv> P x \<and> (\<forall>y. P y \<longrightarrow> \<not>(y > x))"

context finite_topological_space
begin

abbreviation (input) "max_cover x \<equiv> maximal_cover open universe x"

definition "cover_join X Y = {Z. Z \<in> X \<union> Y \<and> (\<forall>Z'. Z' \<in> X \<union> Y \<longrightarrow> \<not> Z \<subset> Z')} "

definition "cover_meet X Y = {Z. Z \<in> lower X \<inter> lower Y \<and> (\<forall>Z'. Z' \<in> lower X \<inter> lower Y \<longrightarrow> \<not> Z \<subset> Z')} "

lemma in_cover_is_open: "maximal_cover open universe z \<Longrightarrow> x \<in> z \<Longrightarrow> x \<in> open"
  by (meson cover.cover_open in_mono maximal_cover_def)

lemma spec_set_eq: "X = Y \<Longrightarrow> c \<in> Y \<Longrightarrow> c \<in> X"
  apply (blast)
  done

lemma cover_meet_is_inf: "max_cover A \<Longrightarrow> max_cover B \<Longrightarrow> x \<in> cover_meet A B \<Longrightarrow> (\<exists>y\<in>A.\<exists>z\<in>B. x = y \<inter> z)"
  apply (clarsimp simp: cover_meet_def)
  apply (clarsimp simp: lower_def)
  by (meson Int_greatest Int_lower1 Int_lower2 order_neq_le_trans)

lemma not_psub_iff:"(\<not> x \<subset> y) \<longleftrightarrow> x = y \<or>  (\<exists>c. c \<in> x \<and> c \<notin> y)"
  apply (intro iffI)
  apply (safe; clarsimp)
  apply (blast)+
  done

lemma in_univ_in_inter:"maximal_cover open universe A \<Longrightarrow>  maximal_cover open universe B \<Longrightarrow> t \<in> universe \<Longrightarrow> \<exists>U\<in>A. \<exists>V\<in>B. t \<in> U \<inter> V"
  by (metis (mono_tags, opaque_lifting) Int_iff Union_iff cover.covers maximal_cover.axioms(1))

lemma in_univ_in_inter':"maximal_cover open universe A \<Longrightarrow>  maximal_cover open universe B \<Longrightarrow> t \<in> universe \<Longrightarrow> \<forall>U\<in>A. t \<in> U \<longrightarrow> (\<exists>V\<in>B. t \<in> U \<inter> V)"
  by (metis (mono_tags, opaque_lifting) Int_iff Union_iff cover.covers maximal_cover.axioms(1))

lemma lower_Sup: "lower S = (\<Union>x\<in>S. lower {x})"
  apply (safe; clarsimp simp: lower_def)
  by blast

lemma finite_lower: "finite S \<Longrightarrow> \<forall>x\<in>S. finite x \<Longrightarrow> finite (lower S)"
  apply (subst lower_Sup)
  apply (subst finite_UN; clarsimp)
  by (clarsimp simp: lower_def)

lemma cover_meet_iff: "max_cover a \<Longrightarrow> max_cover b \<Longrightarrow> x \<in> cover_meet a b \<longleftrightarrow> maximal (\<lambda>x. \<exists>U V. U \<in> a \<and> V \<in> b \<and> x \<subseteq> U \<inter> V) x"
  apply (clarsimp simp: cover_meet_def lower_def)
  apply (safe; clarsimp?)
     apply (clarsimp simp: maximal_def)
  apply (intro conjI)
      apply (rule_tac x=xa in exI, intro conjI; clarsimp?)
      apply (rule_tac x=xaa in exI, intro conjI; clarsimp?)
     apply (meson Int_lower1 inf.cobounded2 inf_greatest order_neq_le_trans)
(*
     apply (clarsimp)
     apply (metis equalityE insert_subsetI psubset_insert_iff)*)
  apply (clarsimp simp: maximal_def)
    apply (blast)
apply (clarsimp simp: maximal_def)
    apply (blast)
  apply (clarsimp simp: maximal_def)
  by (metis Int_iff inf.absorb_iff2 inf_assoc psubsetI)

find_consts "'a set \<Rightarrow> 'a set set"

lemma max_cover_closed: "maximal_cover open universe x \<Longrightarrow> maximal_cover open universe y \<Longrightarrow> \<Union> (cover_meet x y) = universe "
apply (safe)[1]
           apply (clarsimp simp: cover_meet_def lower_def )
           apply (subgoal_tac "X=xaa \<inter> xb")

            apply (meson in_cover_is_open in_mono open_subsets)
  apply (smt (z3) Int_absorb dual_order.strict_iff_order finite_topological_space.in_cover_is_open finite_topological_space_axioms inf.absorb_iff2 inf.cobounded1 inf.cobounded2 inf_greatest topological_space.open_subsets topological_space_axioms)
          apply (clarsimp)
          apply (clarsimp simp: cover_meet_def)
          apply (frule_tac A=x and B=y in in_univ_in_inter, assumption, assumption)
          apply (clarsimp)
          apply (insert maximal_in_finite_set)[1]
          apply (atomize)
          apply (erule_tac x="U \<inter> xaa" in allE)
          apply (erule_tac x="{x. x \<subseteq> universe}" in allE)
          apply (erule_tac x="\<lambda>v. v \<in> (lower x \<inter> lower y)" in allE)
          apply (drule mp)
           apply (clarsimp)
  apply (meson in_cover_is_open in_mono open_subsets)
          apply (drule mp)
  apply (clarsimp simp: lower_def, intro conjI)
            apply blast
  apply blast
          apply (drule mp)
  apply (clarsimp)
           (* apply (meson finite_UnionD finite_universe open_Union open_subsets rev_finite_subset) *)
          apply (clarsimp)
          apply (rule_tac x=ya in exI; clarsimp)
          apply (intro conjI)
           apply (clarsimp)
           apply (erule_tac x=Z' in allE)
  apply (clarsimp)
           apply (metis Sup_is_lower_Sup Union_upper cover.covers maximal_cover.axioms(1) psubsetI)
  by blast

lemma Int_greatest: "xa \<subseteq> U \<and> xa \<subseteq> V \<longleftrightarrow> xa \<subseteq> (U \<inter> V)"
  by (safe; blast)

lemma maximal_iff: " maximal (\<lambda>xa. \<exists>U. U \<in> x \<and> (\<exists>V. V \<in> y \<and> xa \<subseteq> U \<and> xa \<subseteq> V)) z \<longleftrightarrow> (\<exists>U. U \<in> x \<and> (\<exists>V. V \<in> y \<and> z = U \<inter> V)) \<and> (\<forall>z'. (\<exists>U. U \<in> x \<and> (\<exists>V. V \<in> y \<and> z' \<subseteq> U \<inter> V)) \<longrightarrow> \<not> z \<subset> z')  "
  apply (clarsimp simp: maximal_def)
  apply (intro iffI; clarsimp?)
   apply (metis dual_order.strict_iff_order inf.cobounded2 inf_greatest inf_sup_ord(1))
  by (blast)

lemma maximal_iff': "maximal (\<lambda>xa. \<exists>U. U \<in> x \<and> (\<exists>V. V \<in> y \<and> xa \<subseteq> U \<and> xa \<subseteq> V)) = maximal (\<lambda>v. v \<in> lower x \<inter> lower y)"
  apply (rule ext, safe; clarsimp simp: maximal_def)
   apply (safe; clarsimp simp: lower_def)
     apply (blast)
    apply (blast)
   apply blast
  by (smt (verit, del_insts) lower_def mem_Collect_eq)

(* Max covers are closed under antichain-meet *)
lemma max_cover_closed_meet[simp]:" maximal_cover open universe x \<Longrightarrow> maximal_cover open universe y \<Longrightarrow> maximal_cover open universe (cover_meet x y)"
  apply (standard; clarsimp?)
    apply (clarsimp simp: cover_meet_iff maximal_iff)
    apply (meson in_cover_is_open open_Int)
   apply (erule (1) max_cover_closed)
  apply (clarsimp simp: cover_meet_def lower_def)
  by blast

(* Max covers are closed under antichain-join *)

lemma max_cover_closed_join[simp]:" maximal_cover open universe x \<Longrightarrow> maximal_cover open universe y \<Longrightarrow> maximal_cover open universe (cover_join x y)"
   apply (unfold_locales)[1]
   apply (clarsimp simp: cover_join_def)
   apply (meson in_cover_is_open)
    apply (intro set_eqI iffI; clarsimp)
      apply (clarsimp simp: cover_join_def)
       apply (meson in_cover_is_open in_mono open_subsets)
       apply (clarsimp simp: cover_join_def)
     apply (smt (verit, ccfv_threshold) Int_iff in_univ_in_inter maximal_cover.antichain psubsetD psubset_trans)
    apply (clarsimp simp: cover_join_def)
  by blast

end

end


theory Case_Demo
imports Main
begin

lemma "x=5 \<Longrightarrow> x#xs = 5#xs" by auto

lemma "x#xs = y#ys"
  apply auto
  oops

lemma "x#ys \<noteq> []"
  by auto

lemma "(676478456242734::nat) \<noteq> 0" by auto

  (* Simple case expressions *)
  term "case l of [] \<Rightarrow> 0 | x#xs \<Rightarrow> x + length xs"
  term "case n of 0 \<Rightarrow> 0 | Suc _ \<Rightarrow> 1" (* Wildcards may be used *)

  term "case l of [] \<Rightarrow> 0 | _ \<Rightarrow> 1" (* Wildcard will match any remaining patterns *)

  term "case s of [] \<Rightarrow> 1 | [x,y] \<Rightarrow> x+y | _ \<Rightarrow> 0"
    (* Also complex patterns possible. However, they are translated to
        sequential patterns on parsing. See output.*)

  (* The full adder by case, with tuples *)

  definition fa :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<times> bool" where
    "fa a b c = ( case (a,b,c) of
      (False, False, False) \<Rightarrow> (False, False)
    | (False, False, True ) \<Rightarrow> (True , False)
    | (False, True , False) \<Rightarrow> (True , False)
    | (False, True , True ) \<Rightarrow> (False, True )
    | (True , False, False) \<Rightarrow> (True , False)
    | (True , False, True ) \<Rightarrow> (False, True )
    | (True , True , False) \<Rightarrow> (False, True )
    | (True , True , True ) \<Rightarrow> (True , True )
    )"

  fun to_nat :: "bool list \<Rightarrow> nat" where
    "to_nat [] = 0"
  | "to_nat (x#xs) = (if x then 1 else 0) + 2*to_nat xs"

  fun addc :: "bool list \<Rightarrow> bool list \<Rightarrow> bool \<Rightarrow> bool list" where
    "addc [] [] c = (if c then [True] else [])"
  | "addc [] (b#bs) c = (case fa False b c of (s,c) \<Rightarrow> s#addc [] bs c)"
  | "addc (a#as) [] c = (case fa a False c of (s,c) \<Rightarrow> s#addc as [] c)"
  | "addc (a#as) (b#bs) c = (case fa a b c of (s,c) \<Rightarrow> s#addc as bs c)"

  (* Proof: Induction on structure of addc function, using fastforce to automatically discharge goals. auto doesn't work here.
    Details: Later
  *)
  lemma "to_nat (addc as bs c) = (to_nat as + to_nat bs + (if c then 1 else 0))"
    apply (induction as bs c rule: addc.induct)
    apply simp
    apply (fastforce simp: fa_def)
    apply (fastforce simp: fa_def)
    apply (fastforce simp: fa_def)
    done

fun odd where
  "odd 0 = False"
| "odd (Suc n) = (n mod 2 = 0)"

definition odd' :: "nat \<Rightarrow> bool" where "odd' n = (n mod 2 = 1)"

(*
fun f :: "nat \<Rightarrow> nat" where "f n = f n + 1"
*)

end


theory CoBinaryTree
imports "$HIPSTER_HOME/IsaHipster"

begin
setup Misc_Data.set_noisy
setup Tactic_Data.set_sledgehammer_coinduct
(* setup Tactic_Data.set_no_proof *)
setup Misc_Data.set_time (* Print out timing info *)
setup Misc_Data.set_hammer_timeout_medium (* set sledgehammer timeout to 20 s*)

codatatype 'a Tree =
  Node (left: "'a Tree") (lab: 'a) (right: "'a Tree")

primcorec mirror :: "'a Tree => 'a Tree"
where
  "mirror t = (case t of (Node l x r) \<Rightarrow> Node (mirror r) x (mirror l))"

primcorec tmap :: "('a => 'b) => 'a Tree => 'b Tree"
where
 "tmap f t = (case t of (Node l x r) \<Rightarrow> Node (tmap f l) (f x) (tmap f r))"
cohipster mirror
lemma lemma_a [thy_expl]: "mirror (mirror y) = y"
  by(coinduction arbitrary: y rule: Tree.coinduct_strong)
    (simp add: Tree.case_eq_if)

lemma lemma_aa [thy_expl]: "Node (mirror x2) z (mirror y) = mirror (Node y z x2)"
by (simp add: mirror.code)

lemma lemma_ab [thy_expl]: "mirror (Node x2 z (mirror y)) = Node y z (mirror x2)"
  by (metis lemma_a lemma_aa)

lemma lemma_ac [thy_expl]: "mirror (Node (mirror x2) z y) = Node (mirror y) z x2"
  by (metis lemma_a lemma_aa)

cohipster mirror tmap
lemma lemma_ad [thy_expl]: "tmap z (mirror x2) = mirror (tmap z x2)"
by(coinduction arbitrary: x2 z rule: Tree.coinduct_strong)
  (smt Tree.case_eq_if mirror.simps(1) mirror.simps(2) mirror.simps(3) tmap.simps(1) tmap.simps(2) tmap.simps(3))

(*primcorec tsum :: "nat Tree \<Rightarrow> nat Tree \<Rightarrow> nat Tree"
  where "tsum t u = Node (tsum (left t) (left u)) (lab t + lab u) (tsum (right t) (right u))"
*)
primcorec tsum :: "nat Tree \<Rightarrow> nat Tree \<Rightarrow> nat Tree"
  where  "tsum t u = (case t of (Node tle tx tr) \<Rightarrow> case u of (Node ul ux ur) \<Rightarrow> Node (tsum tle ul) (tx+ux) (tsum tr ur))"

(* Note: for these proofs I needed to increase the timeout in Sledgehammer from 10 to 20 s per proof.
   The default for Sledgehammer when called interactively is 30s. *)
cohipster tsum mirror
lemma lemma_ae [thy_expl]: "tsum y x = tsum x y"
  by(coinduction arbitrary: x y rule: Tree.coinduct_strong)
    (smt Tree.case_eq_if add.commute tsum.simps(1) tsum.simps(2) tsum.simps(3))

lemma lemma_af [thy_expl]: "tsum (tsum x y) z = tsum x (tsum y z)"
  by(coinduction arbitrary: x y z rule: Tree.coinduct_strong)
(smt Tree.case_eq_if ab_semigroup_add_class.add_ac(1) tsum.simps(1) tsum.simps(2) tsum.simps(3))

lemma lemma_ag [thy_expl]: "mirror (tsum y (mirror x)) = tsum x (mirror y)"
by(coinduction arbitrary: x y rule: Tree.coinduct_strong)
  (smt Tree.case_eq_if lemma_ae mirror.simps(1) mirror.simps(2) mirror.simps(3) tsum.simps(1) tsum.simps(2) tsum.simps(3))

lemma lemma_ah [thy_expl]: "tsum (mirror x) (mirror y) = mirror (tsum x y)"
  by (metis lemma_a lemma_ae lemma_ag)

lemma lemma_ai [thy_expl]: "mirror (tsum x (tsum y (mirror z))) = tsum (mirror (tsum x y)) z"
  by (metis lemma_ae lemma_af lemma_ag)

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"
  "HOL-Library.While_Combinator"
  "HOL-Library.Monad_Syntax"
begin

section \<open>Adapt Gauss-Jordan elimination to DTMCs\<close>

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[simp]: "\<And>s t. 0 \<le> \<iota> s t" and \<rho>_nonneg[simp]: "\<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 standard (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"
  by (simp add: assms if_distrib [of "\<lambda>x. x * a" for a] cong: if_cong)

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 \<open>s \<in> S\<close> 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 \<open>gauss_jordan' M a = Some f\<close>
  moreover define M' where "M' = (\<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: bind_split_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) sum.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 -
  define M' where "M' = (\<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: sum.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 \<open>j < card S\<close> 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 \<open>pCTL model checking\<close>

subsection \<open>Syntax\<close>

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 \<open>Semantics\<close>

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> ennreal" 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 (ennreal 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

subsection \<open>Implementation of \<open>Sat\<close>\<close>

subsubsection \<open>\<open>Prob0\<close>\<close>

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 \<open>s' \<in> R\<close> 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 \<open>\<Phi> \<subseteq> S\<close> 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 \<open>\<open>Prob1\<close>\<close>

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 \<open>s \<in> S\<close> 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> acc_on (- (\<Psi> \<union> ?P0))"
        from \<open>s \<in> S\<close> s_t have "t \<in> S"
          by (rule E_rtrancl_closed) auto

        show "\<exists>t'\<in>\<Psi> \<union> ?P0. (t, t') \<in> acc"
        proof cases
          assume "t \<in> ?P0" then show ?thesis by auto
        next
          assume "t \<notin> ?P0"
          with \<open>t\<in>S\<close> 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> acc"
            by (rule rev_subsetD) (intro rtrancl_mono Sigma_mono, auto)
          with \<open>s \<in> \<Psi>\<close> show ?thesis by auto
        qed
      next
        have "acc_on (- (\<Psi> \<union> ?P0)) `` {s} \<subseteq> S"
          using \<open>s \<in> S\<close> by (auto intro: E_rtrancl_closed)
        then show "finite (acc_on (- (\<Psi> \<union> ?P0)) `` {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 \<open>s \<in> \<Phi> - \<Psi>\<close> 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 _ _ *] \<open>shd \<omega> \<in> S\<close>
            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 \<open>s \<in> S\<close> 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 \<open>\<open>ProbU\<close>,  \<open>ExpCumm\<close>, and \<open>ExpState\<close>\<close>

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> ennreal" 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> ennreal" where
"ExpState s 0       = \<rho> s" |
"ExpState s (Suc k) = (\<Sum>s'\<in>S. \<tau> s s' * ExpState s' k)"

subsubsection \<open>\<open>LES\<close>\<close>

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 \<open>\<open>ProbUinfty\<close>, compute unbounded until\<close>

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 \<open>\<open>ExpFuture\<close>, compute unbounded reward\<close>

definition ExpFuture :: "'s set \<Rightarrow> ('s \<Rightarrow> ennreal) 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 ennreal (sol s) else \<infinity>)
    }"

subsubsection \<open>\<open>Sat\<close>\<close>

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 (ennreal 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)

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 \<open>q \<in> S\<close> 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 \<open>s \<in> Prob0 \<Phi> \<Psi>\<close> 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 \<open>Finite expected reward\<close>

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 "acc `` {s} \<subseteq> S"
        using E_rtrancl_closed[of s _ _ E] \<open>s \<in> S\<close> by auto
      then show "finite (acc `` {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 \<open>s \<notin> svalid F\<close> 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!: sum.cong simp: field_simps)
  also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * l s') - l s"
    using \<open>s \<in> S\<close> by (simp add: sum_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 \<open>s \<in> S\<close> 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: if_split_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 \<open>s \<in> S\<close> 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 \<open>s \<in> S\<close> 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] \<open>s\<in>S\<close>
    have "AE \<omega> in T s. ev (HLD ?F) (s ## \<omega>)"
      by (simp split: if_split_asm)
    with * show False ..
  qed
qed

subsubsection \<open>The expected reward implies a unique LES\<close>

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 "enn2real (\<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' * enn2real (\<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. ennreal (\<tau> s s' * enn2real (?E s')))"
  proof (rule sum.cong)
    fix s' assume "s' \<in> S"
    show "\<tau> s s' * ?E s' = ennreal (\<tau> s s' * enn2real (?E s'))"
    proof cases
      assume "\<tau> s s' \<noteq> 0"
      with \<open>s \<in> S\<close> \<open>s' \<in> S\<close> have "s' \<in> E s" by (simp add: set_pmf_iff)
      from \<open>s \<notin> ?F\<close> AE_until have "AE \<omega> in T s. (HLD S suntil HLD ?F) (s ## \<omega>)"
        using svalid_subset_S \<open>s \<in> S\<close> by simp
      with nn_integral_reward_finite[OF \<open>s' \<in> S\<close>, of F] \<open>s \<in> S\<close> \<open>s' \<in> E s\<close> \<open>s \<notin> ?F\<close>
      have "?E s' \<noteq> \<infinity>"
        by (simp add: AE_T_iff[of _ s] AE_measure_pmf_iff suntil_Stream
                 del: reward.simps)
      then show ?thesis by (cases "?E s'") (auto simp: ennreal_mult)
    qed simp
  qed simp

  have "AE \<omega> in T s. ?R (s ## \<omega>) = \<rho> s + \<iota> s (shd \<omega>) + ?R \<omega>"
    using \<open>s \<notin> svalid F\<close> 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 \<open>s \<in> S\<close>
    by (subst nn_integral_add)
       (auto simp add: space_PiM PiE_iff simp del: reward.simps)
  also have "\<dots> = ennreal (\<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s')) + (\<integral>\<^sup>+\<omega>. ?R \<omega> \<partial>T s)"
    using \<open>s \<in> S\<close>
    by (subst nn_integral_eq_sum)
       (auto simp: field_simps sum.distrib sum_distrib_left[symmetric] ennreal_mult[symmetric] sum_nonneg)
  finally show ?thesis
    apply (simp del: reward.simps)
    apply (subst nn_integral_eq_sum[OF \<open>s \<in> S\<close> reward_measurable])
    apply (simp del: reward.simps ennreal_plus add: * ennreal_plus[symmetric] sum_nonneg)
    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 = enn2real (\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s)"
    (is "\<forall>s\<in>S. l s = enn2real (\<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 "enn2real (\<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' * enn2real (\<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!: sum.cong simp: field_simps)
  also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * l s') - l s"
    using \<open>s \<in> S\<close> by (simp add: sum_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 \<open>s \<in> S\<close>] \<open>s \<in> Y\<close> \<open>s \<notin> ?F\<close> 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 = enn2real (\<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 = enn2real (\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s)" .
qed

subsection \<open>Soundness of @{const Sat}\<close>

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

next
  case (7 rel r F1 F2)
  moreover
  define constants :: "'s \<Rightarrow> real" where "constants = (\<lambda>s. if s \<in> (svalid F2) then 1 else 0)"
  moreover define distr where "distr = 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: bind_split_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. ennreal (\<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>. ennreal (\<Sum>i<Suc k. \<rho> ((s ## \<omega>) !! i) + \<iota> ((s ## \<omega>) !! i) (\<omega> !! i)) \<partial>T s)
        = (\<integral>\<^sup>+\<omega>. ennreal (\<rho> s + \<iota> s (\<omega> !! 0)) + ennreal (\<Sum>i<k. \<rho> (\<omega> !! i) + \<iota> (\<omega> !! i) (\<omega> !! (Suc i))) \<partial>T s)"
        by (auto intro!: nn_integral_cong
                 simp del: ennreal_plus
                 simp: ennreal_plus[symmetric] sum_nonneg sum.reindex lessThan_Suc_eq_insert_0 zero_notin_Suc_image)
      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 \<open>s \<in> S\<close>
        by (intro nn_integral_add AE_I2) (auto simp: sum_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 \<open>s \<in> S\<close> by (subst nn_integral_eq_sum)
          (auto simp del: ennreal_plus simp: ennreal_plus[symmetric] ennreal_mult[symmetric] sum_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 \<open>s \<in> S\<close> by (subst nn_integral_eq_sum) (auto simp: Suc)
      also have "\<dots> = ExpCumm s (Suc k)"
        using \<open>s \<in> S\<close>
        by (simp add: field_simps sum.distrib sum_distrib_left[symmetric] ennreal_mult[symmetric]
            ennreal_plus[symmetric] sum_nonneg del: ennreal_plus)
      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. ennreal (\<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 }
  then show ?case by auto

next
  case (10 rel r F)
  moreover
  let ?F = "svalid F"
  define N where "N \<equiv> Prob0 S ?F"
  moreover define Y where "Y \<equiv> Prob1 N S ?F"
  moreover define const where "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: bind_split_asm)

  from l have EF: "ExpFuture ?F =
    Some (\<lambda>s. if s \<in> Y then ennreal (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 = enn2real (\<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 \<open>s \<in> S\<close>] this
    have "(\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) \<noteq> \<infinity>"
      by (simp add: )
    with l_eq \<open>s \<in> S\<close> have "(\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) = ennreal (l s)"
      by (auto simp: less_top) }
  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: bind_split_asm)

subsection \<open>Completeness of @{const Sat}\<close>

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)

  define constants :: "'s \<Rightarrow> real" where "constants = (\<lambda>s. if s \<in> svalid \<Psi> then 1 else 0)"
  define distr where "distr = 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!: sum.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 sum_subtractf)
        finally show ?thesis
          using * prob_sum[OF \<open>s \<in> S\<close>] 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>"
  define N where "N \<equiv> Prob0 S ?F"
  define Y where "Y \<equiv> Prob1 N S ?F"
  define const where "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' * enn2real (?E s')) = const s"
    proof
      fix s assume "s \<in> S"
      show "(\<Sum>s'\<in>S. LES (S - Y \<union> svalid \<Phi>) s s' * enn2real (?E s')) = const s"
      proof cases
        assume s: "s \<in> S - (Y - svalid \<Phi>)"
        show ?thesis
        proof cases
          assume "s \<in> Y"
          with \<open>s \<in> S\<close> s \<open>s \<in> Y\<close> 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 \<open>s \<in> S\<close>
          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') * enn2real (?E s')) =
          (\<Sum>s'\<in>S. \<tau> s s' * enn2real (?E s') - (if s' = s then 1 else 0) * enn2real (?E s'))"
          by (auto intro!: sum.cong simp: field_simps)
        also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * enn2real (?E s')) - enn2real (?E s)"
          using \<open>s \<in> S\<close> by (simp add: sum_subtractf single_l)
        finally show ?thesis
          using s \<open>s \<in> S\<close> existence_of_ExpFuture[OF N_def Y_def \<open>s \<in> S\<close> 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: bind_split)+

subsection \<open>Completeness and Soundness @{const Sat}\<close>

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

end

end


theory ConcretePoly

imports Main

begin

fun pad_lists_r :: "int list \<Rightarrow> int list \<Rightarrow> (int list * int list) \<Rightarrow> (int list * int list)" where
"pad_lists_r [] [] out = out" |
"pad_lists_r (x # xs) [] (xso, yso) = pad_lists_r xs [] (x # xso, 0 # yso)" |
"pad_lists_r [] (y # ys) (xso, yso) = pad_lists_r [] ys (0 # xso, y # yso)" |
"pad_lists_r (x # xs) (y # ys) (xso, yso) = pad_lists_r xs ys (x # xso, y # yso)"

fun pad_lists :: "int list \<Rightarrow> int list \<Rightarrow> (int list * int list)" where
"pad_lists xs ys = (let (xp, yp) = pad_lists_r xs ys ([], []) in (rev xp, rev yp))"

datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var x = x" |
"eval (Const i) _ = i" |
"eval (Add l r) x = (eval l x) + (eval r x)" |
"eval (Mult l r) x = (eval l x) * (eval r x)"

fun var_to_exp :: "nat \<Rightarrow> exp" where
"var_to_exp n = (
  if n = 0 then (Const 1)
  else if n < 2 then Var
  else Mult Var (var_to_exp (n - 1))
)"

fun make_polynomial_r :: "int list \<Rightarrow> nat \<Rightarrow> exp \<Rightarrow> exp" where
"make_polynomial_r [] _ e = e" |
"make_polynomial_r (c # cs) n e =
  make_polynomial_r cs (n + 1) (Add e (Mult (Const c) (var_to_exp n)))"

fun make_polynomial :: "int list \<Rightarrow> exp" where
"make_polynomial cs = make_polynomial_r (tl cs) 1 (Const (hd cs))"

value "make_polynomial [5, 0, 1]"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalp cs x = (
  let poly = make_polynomial cs in
  eval poly x
)"

fun sum_coeffs :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"sum_coeffs xs ys = (let (xsp, ysp) = pad_lists xs ys in map (\<lambda>(x, y). x + y) (zip xsp ysp))"

fun mult_coeffs :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"mult_coeffs [] ys = []" |
"mult_coeffs (x # xs) ys = sum_coeffs (map (\<lambda>y. y * x) ys) (0 # (mult_coeffs xs ys))"

fun coeffs_r :: "exp \<Rightarrow> int list" where
"coeffs_r (Const i) = [i]" |
"coeffs_r Var = [0, 1, 2]" |
"coeffs_r (Add l r) = sum_coeffs (coeffs_r l) (coeffs_r r)" |
"coeffs_r (Mult l r) = mult_coeffs (coeffs_r l) (coeffs_r r)"

fun coeffs :: "exp \<Rightarrow> int list" where
"coeffs e = coeffs_r e"

fun evalc :: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalc [] v = 0" |
"evalc (x # xs) v = x + v * (evalc xs v)"

value "evalc [4,3,1] 2"

(*
lemma coefficients_produce_correct_polynomial[simp]:
"make_polynomial (coeffs e) = e"
  apply(induction e)
  apply(simp)
*)

theorem "evalp (coeffs e) x = eval e x"
  by smt
  (* apply(induction e)*)

(*
lemma evalc_add: "evalc (sum_coeffs

theorem "evalc (coeffs e) x = eval e x"
  apply(induction e)
  apply(simp add: algebra_simps)

*)
end