theory BPlusTree_Range
imports BPlusTree
    "HOL-Data_Structures.Set_Specs"
    "HOL-Library.Sublist"
    BPlusTree_Split
begin

text "Lrange describes all elements in a set that are greater or equal to l,
a lower bounded range (with no upper bound)"

definition Lrange where
  "Lrange l X = {x \<in> X. x \<ge> l}"

definition "lrange_filter l = filter (\<lambda>x. x \<ge> l)"

lemma lrange_filter_iff_Lrange: "set (lrange_filter l xs) = Lrange l (set xs)"
  by (auto simp add: lrange_filter_def Lrange_def)

fun lrange_list where
  "lrange_list l (x#xs) = (if x \<ge> l then (x#xs) else lrange_list l xs)" |
  "lrange_list l [] = []"

lemma sorted_leq_lrange: "sorted_wrt (\<le>) xs \<Longrightarrow> lrange_list (l::'a::linorder) xs = lrange_filter l xs"
  apply(induction xs)
  apply(auto simp add: lrange_filter_def)
  by (metis dual_order.trans filter_True)

lemma sorted_less_lrange: "sorted_less xs \<Longrightarrow> lrange_list (l::'a::linorder) xs = lrange_filter l xs"
  by (simp add: sorted_leq_lrange strict_sorted_iff)

lemma lrange_list_sorted: "sorted_less (xs@x#ys) \<Longrightarrow>
  lrange_list l (xs@x#ys) =
  (if l < x then (lrange_list l xs)@x#ys else lrange_list l (x#ys))"
  by (induction xs arbitrary: x) auto

lemma lrange_filter_sorted: "sorted_less (xs@x#ys) \<Longrightarrow>
  lrange_filter l (xs@x#ys) =
  (if l < x then (lrange_filter l xs)@x#ys else lrange_filter l (x#ys))"
  by (metis lrange_list_sorted sorted_less_lrange sorted_wrt_append)

lemma lrange_suffix: "suffix (lrange_list l xs) xs"
  apply(induction xs)
  apply (auto dest: suffix_ConsI)
  done

locale split_range = split_tree split
  for split::
    "('a bplustree \<times> 'a::{linorder,order_top}) list \<Rightarrow> 'a
       \<Rightarrow> ('a bplustree \<times> 'a) list \<times> ('a bplustree \<times> 'a) list" +
  fixes lrange_list ::  "'a \<Rightarrow> ('a::{linorder,order_top}) list \<Rightarrow> 'a list"
  assumes lrange_list_req:
    (* we later derive such a function from a split function similar to the above *)
    "sorted_less ks \<Longrightarrow> lrange_list l ks = lrange_filter l ks"
begin

fun lrange:: "'a bplustree \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "lrange (Leaf ks) x = (lrange_list x ks)" |
  "lrange (Node ts t) x = (
      case split ts x of (_,(sub,sep)#rs) \<Rightarrow> (
             lrange sub x @ leaves_list rs @ leaves t
      )
   | (_,[]) \<Rightarrow> lrange t x
  )"

text "lrange proof"

(* lift to split *)

lemma lrange_sorted_split:
  assumes "Laligned (Node ts t) u"
    and "sorted_less (leaves (Node ts t))"
    and "split ts x = (ls, rs)"
  shows "lrange_filter x (leaves (Node ts t)) = lrange_filter x (leaves_list rs @ leaves t)"
proof (cases ls)
  case Nil
  then have "ts = rs"
    using assms by (auto dest!: split_conc)
  then show ?thesis by simp
next
  case Cons
  then obtain ls' sub sep where ls_tail_split: "ls = ls' @ [(sub,sep)]"
    by (metis list.simps(3) rev_exhaust surj_pair)
  then have x_sm_sep: "sep < x"
    using split_req(2)[of ts x ls' sub sep rs]
    using Laligned_sorted_separators[OF assms(1)]
    using assms sorted_cons sorted_snoc
    by blast
  moreover have leaves_split: "leaves (Node ts t) = leaves_list ls @ leaves_list rs @ leaves t"
    using assms(3) leaves_split by blast
  then show ?thesis
  proof (cases "leaves_list ls")
    case Nil
    then show ?thesis
      using leaves_split
      by (metis self_append_conv2)
  next
    case Cons
    then obtain leavesls' l' where leaves_tail_split: "leaves_list ls = leavesls' @ [l']"
      by (metis list.simps(3) rev_exhaust)
    then have "l' \<le> sep"
    proof -
      have "l' \<in> set (leaves_list ls)"
        using leaves_tail_split by force
      then have "l' \<in> set (leaves (Node ls' sub))"
        using ls_tail_split
        by auto
      moreover have "Laligned (Node ls' sub) sep"
        using assms split_conc[OF assms(3)] Cons ls_tail_split
        using Laligned_split_left[of ls' sub sep rs t u]
        by simp
      ultimately show ?thesis
        using Laligned_leaves_inbetween[of "Node ls' sub" sep]
        by blast
    qed
    then have "l' < x"
      using le_less_trans x_sm_sep by blast
    then show ?thesis
      using assms(2) ls_tail_split leaves_tail_split leaves_split x_sm_sep
      using lrange_filter_sorted[of "leavesls'" l' "leaves_list rs @ leaves t" x]
      by (auto simp add: lrange_filter_def)
  qed
qed

lemma lrange_sorted_split_right:
  assumes "split ts x = (ls, (sub,sep)#rs)"
    and "sorted_less (leaves (Node ts t))"
    and "Laligned (Node ts t) u"
  shows "lrange_filter x (leaves_list ((sub,sep)#rs) @ leaves t) = lrange_filter x (leaves sub)@leaves_list rs@leaves t"
proof -
  from assms have "x \<le> sep"
  proof -
    from assms have "sorted_less (separators ts)"
      by (meson Laligned_sorted_inorder sorted_cons sorted_inorder_separators sorted_snoc)
    then show ?thesis
      using split_req(3)
      using assms
      by fastforce
  qed
  moreover have leaves_split: "leaves (Node ts t) = leaves_list ls @ leaves sub @ leaves_list rs @ leaves t"
    using split_conc[OF assms(1)] by auto
  ultimately show ?thesis
  proof (cases "leaves_list rs @ leaves t")
    case Nil
    then show ?thesis
      by (metis assms(1) leaves_split same_append_eq self_append_conv split_tree.leaves_split split_tree_axioms)
  next
    case (Cons r' rs')
    then have "sep < r'"
      by (metis (mono_tags, lifting) Laligned_split_right aligned_leaves_inbetween append.right_neutral append_assoc assms(1) assms(3) concat.simps(1) leaves_conc list.set_intros(1) list.simps(8) split_tree.split_conc split_tree_axioms)
    then have  "x < r'"
      using \<open>x \<le> sep\<close> by auto
    moreover have "sorted_less (leaves_list ((sub,sep)#rs) @ leaves t)"
      using assms sorted_wrt_append split_conc
      by fastforce
    ultimately show ?thesis
      using lrange_filter_sorted[of "leaves sub" "r'" "rs'" x] Cons
      by auto
  qed
qed

theorem lrange_set:
  assumes "sorted_less (leaves t)"
    and "aligned l t u"
  shows "lrange t x = lrange_filter x (leaves t)"
  using assms
proof(induction t x arbitrary: l u rule: lrange.induct)
  case (1 ks x)
  then show ?case
    using lrange_list_req
    by auto
next
  case (2 ts t x)
  then obtain ls rs where list_split: "split ts x = (ls, rs)"
    by (meson surj_pair)
  then have list_conc: "ts = ls @ rs"
    using split_conc by auto
  show ?case
  proof (cases rs)
    case Nil
    then have "lrange (Node ts t) x = lrange t x"
      by (simp add: list_split)
    also have "\<dots> = lrange_filter x (leaves t)"
      by (metis "2.IH"(1) "2.prems"(1) "2.prems"(2) align_last' list_split local.Nil sorted_leaves_induct_last)
    also have "\<dots> = lrange_filter x (leaves (Node ts t))"
      by (metis "2.prems"(1) "2.prems"(2) aligned_imp_Laligned leaves.simps(2) list_conc list_split local.Nil lrange_sorted_split same_append_eq self_append_conv split_tree.leaves_split split_tree_axioms)
    finally show ?thesis .
  next
    case (Cons a list)
    then obtain sub sep where a_split: "a = (sub,sep)"
      by (cases a)
      then have "lrange (Node ts t) x = lrange sub x @ leaves_list list @ leaves t"
        using list_split Cons a_split
        by auto
      also have "\<dots> = lrange_filter x (leaves sub) @ leaves_list list @ leaves t"
        using "2.IH"(2)[of ls rs "(sub,sep)" list sub sep]
        using "2.prems" a_split list_conc list_split local.Cons sorted_leaves_induct_subtree
              align_sub
        by (metis in_set_conv_decomp)
      also have "\<dots> = lrange_filter x (leaves (Node ts t))"
        by (metis "2.prems"(1) "2.prems"(2) a_split aligned_imp_Laligned list_split local.Cons lrange_sorted_split lrange_sorted_split_right)
      finally show ?thesis  .
    qed
qed

text "Now the alternative explanation that first obtains the correct leaf node
and in a second step obtains the correct element from the leaf node."

fun leaf_nodes_lrange:: "'a bplustree \<Rightarrow> 'a \<Rightarrow> 'a bplustree list" where
  "leaf_nodes_lrange (Leaf ks) x = [Leaf ks]" |
  "leaf_nodes_lrange (Node ts t) x = (
      case split ts x of (_,(sub,sep)#rs) \<Rightarrow> (
             leaf_nodes_lrange sub x @ leaf_nodes_list rs @ leaf_nodes t
      )
   | (_,[]) \<Rightarrow> leaf_nodes_lrange t x
  )"

text "lrange proof"

(* lift to split *)

lemma concat_leaf_nodes_leaves_list: "(concat (map leaves (leaf_nodes_list ts))) = leaves_list ts"
  apply(induction ts)
  subgoal by auto
  subgoal using concat_leaf_nodes_leaves by auto
  done

theorem leaf_nodes_lrange_set:
  assumes "sorted_less (leaves t)"
    and "aligned l t u"
  shows "suffix (lrange_filter x (leaves t)) (concat (map leaves (leaf_nodes_lrange t x)))"
  using assms
proof(induction t x arbitrary: l u rule: lrange.induct)
  case (1 ks x)
  then show ?case
    apply simp
    by (metis lrange_suffix sorted_less_lrange)
next
  case (2 ts t x)
  then obtain ls rs where list_split: "split ts x = (ls, rs)"
    by (meson surj_pair)
  then have list_conc: "ts = ls @ rs"
    using split_conc by auto
  show ?case
  proof (cases rs)
    case Nil
    then have *: "leaf_nodes_lrange (Node ts t) x = leaf_nodes_lrange t x"
      by (simp add: list_split)
    moreover have "suffix (lrange_filter x (leaves t)) (concat (map leaves (leaf_nodes_lrange t x)))"
      by (metis "2.IH"(1) "2.prems"(1) "2.prems"(2) align_last' list_split local.Nil sorted_leaves_induct_last)
    then have "suffix (lrange_filter x (leaves (Node ts t))) (concat (map leaves (leaf_nodes_lrange t x)))"
      by (metis "2.prems"(1) "2.prems"(2) aligned_imp_Laligned leaves.simps(2) list_conc list_split local.Nil lrange_sorted_split same_append_eq self_append_conv split_tree.leaves_split split_tree_axioms)
    ultimately show ?thesis by simp
  next
    case (Cons a list)
    then obtain sub sep where a_split: "a = (sub,sep)"
      by (cases a)
      then have "leaf_nodes_lrange (Node ts t) x = leaf_nodes_lrange sub x @ leaf_nodes_list list @ leaf_nodes t"
        using list_split Cons a_split
        by auto
      moreover have *: "suffix (lrange_filter x (leaves sub)) (concat (map leaves (leaf_nodes_lrange sub x)))"
        by (metis "2.IH"(2) "2.prems"(1) "2.prems"(2) a_split align_sub in_set_conv_decomp list_conc list_split local.Cons sorted_leaves_induct_subtree)
      then have "suffix (lrange_filter x (leaves (Node ts t))) (concat (map leaves (leaf_nodes_lrange sub x @ leaf_nodes_list list @ leaf_nodes t)))"
      proof (goal_cases)
        case 1
        have "lrange_filter x (leaves (Node ts t)) = lrange_filter x (leaves sub @ leaves_list list @ leaves t)"
          by (metis (no_types, lifting) "2.prems"(1) "2.prems"(2) a_split aligned_imp_Laligned append.assoc concat_map_maps fst_conv list.simps(9) list_split local.Cons lrange_sorted_split maps_simps(1))
        also have "\<dots> = lrange_filter x (leaves sub) @ leaves_list list @ leaves t"
          by (metis "2.prems"(1) "2.prems"(2) a_split aligned_imp_Laligned calculation list_split local.Cons lrange_sorted_split_right split_range.lrange_sorted_split split_range_axioms)
        moreover have "(concat (map leaves (leaf_nodes_lrange sub x @ leaf_nodes_list list @ leaf_nodes t))) = (concat (map leaves (leaf_nodes_lrange sub x)) @ leaves_list list @ leaves t)"
          using concat_leaf_nodes_leaves_list[of list] concat_leaf_nodes_leaves[of t]
          by simp
        ultimately show ?case
          using *
          by simp
      qed
      ultimately show ?thesis by simp
    qed
qed

lemma leaf_nodes_lrange_not_empty: "\<exists>ks list. leaf_nodes_lrange t x = (Leaf ks)#list \<and> (Leaf ks) \<in> set (leaf_nodes t)"
  apply(induction t x rule: leaf_nodes_lrange.induct)
  apply (auto split!: prod.splits list.splits)
  by (metis Cons_eq_appendI fst_conv in_set_conv_decomp split_conc)

text "Note that, conveniently, this argument is purely syntactic,
we do not need to show that this has anything to do with linear orders"

lemma leaf_nodes_lrange_pre_lrange: "leaf_nodes_lrange t x = (Leaf ks)#list \<Longrightarrow> lrange_list x ks @ (concat (map leaves list)) = lrange t x"
proof(induction t x arbitrary: ks list rule: leaf_nodes_lrange.induct)
  case (1 ks x)
  then show ?case by simp
next
  case (2 ts t x ks list)
  then show ?case
  proof(cases "split ts x")
    case split: (Pair ls rs)
    then show ?thesis
    proof (cases rs)
      case Nil
      then show ?thesis
        using "2.IH"(1) "2.prems" split by auto
    next
      case (Cons subsep rss)
      then show ?thesis
      proof(cases subsep)
        case sub_sep: (Pair sub sep)
        thm "2.IH"(2) "2.prems"
        have "\<exists>list'. leaf_nodes_lrange sub x = (Leaf ks)#list'"
          using "2.prems" split Cons sub_sep leaf_nodes_lrange_not_empty[of sub x]
            apply simp
          by fastforce
        then obtain list' where *: "leaf_nodes_lrange sub x = (Leaf ks)#list'"
          by blast
        moreover have "list = list'@concat (map (leaf_nodes \<circ> fst) rss) @ leaf_nodes t"
          using *
          using "2.prems" split Cons sub_sep
          by simp
        ultimately show ?thesis
          using split "2.IH"(2)[OF split[symmetric] Cons sub_sep[symmetric] *,symmetric]
                Cons sub_sep concat_leaf_nodes_leaves_list[of rss] concat_leaf_nodes_leaves[of t]
          by simp
      qed
    qed
  qed
qed

text "We finally obtain a function that is way easier to reason about in the imperative setting"
fun concat_leaf_nodes_lrange where
  "concat_leaf_nodes_lrange t x = (case leaf_nodes_lrange t x of (Leaf ks)#list \<Rightarrow> lrange_list x ks @ (concat (map leaves list)))"

lemma concat_leaf_nodes_lrange_lrange: "concat_leaf_nodes_lrange t x = lrange t x"
proof -
  obtain ks list where *: "leaf_nodes_lrange t x = (Leaf ks)#list"
    using leaf_nodes_lrange_not_empty by blast
  then have "concat_leaf_nodes_lrange t x = lrange_list x ks @ (concat (map leaves list))"
    by simp
  also have "\<dots> = lrange t x"
    using leaf_nodes_lrange_pre_lrange[OF *]
    by simp
  finally show ?thesis .
qed

end

context split_list
begin

definition lrange_split where
"lrange_split l xs = (case split_list xs l of (ls,rs) \<Rightarrow> rs)"

lemma lrange_filter_split:
  assumes "sorted_less xs"
    and "split_list xs l = (ls,rs)"
  shows "lrange_list l xs = rs"
  find_theorems split_list
proof(cases rs)
  case rs_Nil: Nil
  then show ?thesis
  proof(cases ls)
    case Nil
    then show ?thesis
      using assms split_list_req(1)[of xs l ls rs] rs_Nil
      by simp
  next
    case Cons
    then obtain lss sep where snoc: "ls = lss@[sep]"
      by (metis append_butlast_last_id list.simps(3))
    then have "sep < l"
      using assms(1) assms(2) split_list_req(2) by blast
    then show ?thesis
      using lrange_list_sorted[of lss sep rs l]
            snoc split_list_req(1)[OF assms(2)]
            assms rs_Nil
      by simp
  qed
next
  case ls_Cons: (Cons sep rss)
  then have *: "l \<le> sep"
    using assms(1) assms(2) split_list_req(3) by auto
  then show ?thesis
  proof(cases ls)
    case Nil
    then show ?thesis
    using lrange_list_sorted[of ls sep rss l]
          split_list_req(1)[OF assms(2)] assms
          ls_Cons *
    by simp
  next
    case Cons
    then obtain lss sep2 where snoc: "ls = lss@[sep2]"
      by (metis append_butlast_last_id list.simps(3))
    then have "sep2 < l"
      using assms(1) assms(2) split_list_req(2) by blast
    moreover have "sorted_less (lss@[sep2])"
      using assms(1) assms(2) ls_Cons snoc sorted_mid_iff sorted_snoc split_list_req(1) by blast
    ultimately show ?thesis
      using lrange_list_sorted[of ls sep rss l]
            lrange_list_sorted[of lss "sep2" "[]" l]
            split_list_req(1)[OF assms(2)] assms
            ls_Cons * snoc
      by simp
  qed
qed

lemma lrange_split_req:
  assumes "sorted_less xs"
  shows "lrange_split l xs = lrange_filter l xs"
  unfolding lrange_split_def
  using lrange_filter_split[of xs l] assms
  using sorted_less_lrange
  by (simp split!: prod.splits)

end

context split_full
begin

sublocale split_range split lrange_split
  using lrange_split_req
  by unfold_locales auto

end

end


theory Lexord_List
imports Main
begin

typedef 'a lexlist = "{xs::'a list. True}"
  morphisms unlex Lex
by auto

definition "lexlist \<equiv> Lex"

lemma lexlist_ext:
  "Lex xs = Lex ys \<Longrightarrow> xs = ys"
by (auto simp: Lex_inject)

lemma Lex_unlex [simp, code abstype]:
  "Lex (unlex lxs) = lxs"
  by (fact unlex_inverse)

lemma unlex_lexlist [simp, code abstract]:
  "unlex (lexlist xs) = xs"
  by (metis lexlist_ext unlex_inverse lexlist_def)

definition list_less :: "'a :: ord list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "list_less xs ys \<longleftrightarrow> (xs, ys) \<in> lexord {(u, v). u < v}"

definition list_le where
  "list_le xs ys \<longleftrightarrow> list_less xs ys \<or> xs = ys"

lemma not_less_Nil [simp]: "\<not> list_less x []"
  by (simp add: list_less_def)

lemma Nil_less_Cons [simp]: "list_less [] (a # x)"
  by (simp add: list_less_def)

lemma Cons_less_Cons [simp]: "list_less (a # x) (b # y) \<longleftrightarrow> a < b \<or> a = b \<and> list_less x y"
  by (simp add: list_less_def)

lemma le_Nil [simp]: "list_le x [] \<longleftrightarrow> x = []"
  unfolding list_le_def by (cases x) auto

lemma Nil_le_Cons [simp]: "list_le [] x"
  unfolding list_le_def by (cases x) auto

lemma Cons_le_Cons [simp]: "list_le (a # x) (b # y) \<longleftrightarrow> a < b \<or> a = b \<and> list_le x y"
  unfolding list_le_def by auto

lemma less_list_code [code]:
  "list_less xs [] \<longleftrightarrow> False"
  "list_less [] (x # xs) \<longleftrightarrow> True"
  "list_less (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> x = y \<and> list_less xs ys"
  by simp_all

instantiation  lexlist :: (ord) ord
begin

definition
  lexlist_less_def: "xs < ys \<longleftrightarrow> list_less (unlex xs) (unlex ys)"

definition
  lexlist_le_def: "(xs :: _ lexlist) \<le> ys \<longleftrightarrow> list_le (unlex xs) (unlex ys)"

instance ..

lemmas lexlist_ord_defs = lexlist_le_def lexlist_less_def list_le_def list_less_def

end

instance lexlist :: (order) order
proof
  fix xs :: "'a lexlist"
  show "xs \<le> xs" by (simp add: lexlist_le_def list_le_def)
next
  fix xs ys zs :: "'a lexlist"
  assume "xs \<le> ys" and "ys \<le> zs"
  then show "xs \<le> zs"
    apply (auto simp add: lexlist_ord_defs)
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "'a lexlist"
  assume "xs \<le> ys" and "ys \<le> xs"
  then show "xs = ys"
    apply (auto simp add: lexlist_ord_defs)
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI simp: unlex_inject)
    done
next
  fix xs ys :: "'a lexlist"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    apply (auto simp add: lexlist_ord_defs)
    defer
    apply (rule lexord_irreflexive [THEN notE])
    apply auto
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
qed

instance lexlist :: (linorder) linorder
proof
  fix xs ys :: "'a lexlist"
  have "(unlex xs, unlex ys) \<in> lexord {(u, v). u < v} \<or> unlex xs = unlex ys \<or> (unlex ys, unlex xs) \<in> lexord {(u, v). u < v}"
    by (rule lexord_linear) auto
  then show "xs \<le> ys \<or> ys \<le> xs"
    by (auto simp add: lexlist_ord_defs unlex_inject)
qed

end


theory locale_tute
  imports Main
begin

locale partial_order =
  fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubseteq>" 50)
  assumes refl [intro, simp]: "x \<sqsubseteq> x"
    and anti_sym [intro]: "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> x \<rbrakk> \<Longrightarrow> x = y"
    and trans [trans]: "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow>  x \<sqsubseteq> z"

print_locale! partial_order

thm partial_order_def

definition (in partial_order)
  less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubset>" 50)
  where "(x \<sqsubset> y) = (x \<sqsubseteq> y \<and> x \<noteq> y)"

lemma (in partial_order) less_le_trans [trans]:
  "\<lbrakk> x \<sqsubset> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow>  x \<sqsubset> z"
  unfolding less_def
  apply (auto intro: trans)
  done

end


(*
  Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory SLAI imports System_L1 begin

text \<open>System from Jan Lukasiewicz and Alfred Tarski (1930): Untersuchungen über den Aussagenkalkül\<close>

text \<open>Inspired by Shotaro Tanaka (1965): On Axiom Systems of Propositional Calculi. XIII\<close>

inductive LT (\<open>\<tturnstile>\<close>) where
  LT_MP: \<open>\<tturnstile> q\<close> if \<open>\<tturnstile> p\<close> and \<open>\<tturnstile> (p \<rightarrow> q)\<close> |
  LT_1:  \<open>\<tturnstile> (((p \<rightarrow> (q \<rightarrow> p))
              \<rightarrow> (((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u)))) \<rightarrow> v))
             \<rightarrow> (w \<rightarrow> v))\<close>

lemma LT_3: \<open>\<tturnstile> (p \<rightarrow> (q \<rightarrow> p))\<close>
  using LT_1 LT_MP by metis

lemma LT_4: \<open>\<tturnstile> ((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u))))\<close>
  using LT_1 LT_3 LT_MP by metis

lemma LT_5: \<open>\<tturnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_3 LT_4 LT_MP by metis

lemma LT_11: \<open>\<tturnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_3 LT_5 LT_MP by metis

lemma LT_13: \<open>\<tturnstile> (((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_3 LT_5 LT_11 LT_MP by metis

lemma LT_19: \<open>\<tturnstile> ((\<sim> p \<rightarrow> \<sim> q) \<rightarrow> (q \<rightarrow> p))\<close>
  using LT_3 LT_4 LT_5 LT_11 LT_13 LT_MP by metis

lemma LT_20: \<open>\<tturnstile> ((\<sim> p \<rightarrow> p) \<rightarrow> p)\<close>
  using LT_3 LT_5 LT_19 LT_MP by metis

lemma LT_21: \<open>\<tturnstile> (p \<rightarrow> (\<sim> p \<rightarrow> q))\<close>
  using LT_3 LT_5 LT_11 LT_13 LT_19 LT_MP by metis

theorem LT_iff_L1: \<open>\<tturnstile> p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have L1_LT_1:
    \<open>\<turnstile> (((p \<rightarrow> (q \<rightarrow> p))
          \<rightarrow> (((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u)))) \<rightarrow> v))
         \<rightarrow> (w \<rightarrow> v))\<close> for p q r s t u v w
    using L1_completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<tturnstile> p\<close>
    using that by (induct) (metis MP, metis L1_LT_1)
  show \<open>\<tturnstile> p\<close> if \<open>\<turnstile> p\<close>
    using that by (induct) (metis LT_MP, metis LT_11, metis LT_20, metis LT_21)
qed

theorem LT_soundness: \<open>\<tturnstile> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: LT.induct) auto

theorem LT_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<tturnstile> p\<close>
  using LT_iff_L1 by (simp add: L1_completeness)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<tturnstile> p\<close>
  unfolding valid_def using LT_soundness LT_completeness by blast

lemmas LT = LT.intros main

end


theory BExp imports AExp begin

datatype bexp  = Bc bool
               | Not bexp
               | And bexp bexp
               | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
  "bval (Bc v) s = v"
| "bval (Not b) s = (\<not> bval b s)"
| "bval (And b1 b2) s = (bval b1 s \<and> bval b2 s)"
| "bval (Less a1 a2) s = (aval a1 s < aval a2 s)"

value "bval (Less (V ''x'') (Plus (N 3) (V ''y'')))
      <''x'' := 3, ''y'' := 1>"

subsection "Constant Folding"

text "Optimising constructors:"

fun not :: "bexp \<Rightarrow> bexp" where
  "not (Bc True) = Bc False"
| "not (Bc False) = Bc True"
| "not b = Not b"

lemma bval_not [simp]:
    "bval (not b) s = (\<not> bval b s)"
apply (induction b rule: not.induct)
apply auto
done

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
  "and (Bc True) b = b"
| "and b (Bc True) = b"
| "and (Bc False) b = Bc False"
| "and b (Bc False) = Bc False"
| "and b1 b2 = And b1 b2"

lemma bval_and [simp]:
    "bval (and b1 b2) s = (bval b1 s \<and> bval b2 s)"
apply (induction b1 b2 rule: and.induct)
apply auto
done

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "less (N n1) (N n2) = Bc(n1 < n2)"
| "less a1 a2 = Less a1 a2"

text "Overall optimiser:"

(* Bottom-up *)
fun bsimp :: "bexp \<Rightarrow> bexp" where
  "bsimp (Bc v) = Bc v"
| "bsimp (Not b) = not (bsimp b)"
| "bsimp (And b1 b2) = and (bsimp b1) (bsimp b2)"
| "bsimp (Less a1 a2) = less (asimp a1) (asimp a2)"

value "bsimp (And (Less (N 0) (N 1)) b)"
value "bsimp (And (Less (N 1) (N 0)) (Bc True))"

theorem "bval (bsimp b) s = bval b s"
apply (induction b)
apply auto
done

end


(* Title: Refinement KAT
   Author: Peixin You
*)

section \<open>Refinement KAT\<close>

theory RC
  imports HL

begin

subsection \<open>Order Preservation of Conditionals and Loops\<close>

context kat
begin

lemma cond_iso:
  assumes "x \<le> x'"
  and "y \<le> y'"
shows "if p then x else y fi \<le> if p then x' else y' fi"
  by (simp add: assms add_iso cond_def mult_isol)

lemma while_iso:
  assumes "x \<le> y"
  shows "while p do x od \<le> while p do y od"
  by (simp add: assms mult_isol mult_isor star_iso while_def)

end

subsection \<open>Definition of refinement KAT\<close>

text \<open>A refinement KAT is a KAT expanded by Morgan's specification statement.\<close>

class rkat = kat +
  fixes Re :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes spec_def:  "(x \<le> Re p q) = Ho p x q"

begin

lemma R1: "Ho p (Re p q) q"
  using spec_def by blast

lemma R2: "Ho p x q \<Longrightarrow> x \<le> Re p q"
  by (simp add: spec_def)

lemma R_demmod: "(x \<le> Re p q) = (\<tau> p \<cdot> x \<le> x \<cdot> \<tau> q)"
  by (simp add: Ho_def spec_def)

subsection \<open>Propositional Refinement Calculus\<close>

lemma R_skip: "1 \<le> Re p p"
proof -
  have "Ho p 1 p"
    by (simp add: H_skip)
  thus ?thesis
    by (rule R2)
qed

lemma R_cons:
  assumes "\<tau> p \<le> \<tau> p'"
  and "\<tau> q' \<le> \<tau> q"
  shows "Re p' q' \<le> Re p q"
proof -
  have "Ho p' (Re p' q') q'"
    by (simp add: R1)
  hence "Ho p (Re p' q') q"
    using assms H_cons by simp
  thus ?thesis
    by (rule R2)
qed

lemma R_seq: "Re p r \<cdot> Re r q \<le> Re p q"
proof -
  have "Ho p (Re p r) r" and "Ho r (Re r q) q"
    by (simp add: R1)+
  hence "Ho p ((Re p r) \<cdot> (Re r q)) q"
    using H_seq by auto
  thus ?thesis
    by (rule R2)
qed

lemma R_cond: "if v then Re (\<tau> p \<cdot> \<tau> v) q else Re (\<tau> p \<cdot> \<alpha> v) q fi \<le> Re p q"
proof -
  have "Ho (\<tau> p \<cdot> \<tau> v) (Re (\<tau> p \<cdot> \<tau> v) q) q" and "Ho (\<tau> p \<cdot> \<alpha> v) (Re (\<tau> p \<cdot> \<alpha> v) q) q"
    by (simp add: R1)+
  hence "Ho p (if v then (Re (\<tau> p \<cdot> \<tau> v) q) else (Re (\<tau> p \<cdot> \<alpha> v) q) fi) q"
    by (simp add: H_cond_iff)
 thus ?thesis
    by (rule R2)
qed

lemma R_while: "while q do Re (\<tau> p \<cdot> \<tau> q) p od \<le> Re p (\<tau> p \<cdot> \<alpha> q)"
proof -
  have "Ho (\<tau> p \<cdot> \<tau> q) (Re (\<tau> p \<cdot> \<tau> q) p)  p"
    by (simp_all add: R1)
  hence "Ho p (while q do (Re (\<tau> p \<cdot> \<tau> q) p) od) (\<tau> p \<cdot> \<alpha> q)"
    by (simp add: H_while)
  thus ?thesis
    by (rule R2)
  qed

lemma R_zero_one: "x \<le> Re 0 1"
proof -
  have "Ho 0 x 1"
    by (metis Ho_def annil mult_1_right test_def test_mult_comp test_one zero_least)
  thus ?thesis
    by (rule R2)
qed

lemma R_one_zero: "Re 1 0 = 0"
proof -
  have "Ho 1 (Re 1 0) 0"
    by (simp add: R1)
  thus ?thesis
    by (metis Ho_def mult_1_left mult_1_right pcorrect_if1 t_a_var test_mult_comp test_one)
qed

lemma R_while_inv: "\<tau> p \<le> \<tau> i \<Longrightarrow>  \<alpha> t \<cdot> \<tau> i \<le> \<tau> q \<Longrightarrow> while t do Re (\<tau> t \<cdot> \<tau> i) i od \<le> Re p q"
  using R1 H_while_inv a_comm spec_def test_def while_inv_def by simp

end

subsection \<open>Models of Refinement KAT\<close>

definition rel_Re :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_Re P Q = \<Union>{R. rel_kat.Ho P R Q}"

interpretation rel_rkat: rkat "(\<union>)" "{}" Id "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl "\<alpha>\<^sub>r" rel_Re
  by (standard, auto simp: rel_Re_def rel_kat.Ho_def rel_atest_def rel_kat.test_def)

definition sta_Re :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" where
  "(sta_Re P Q) x = \<Union>{f x|f. sta_kat.Ho P f Q}"

interpretation sta_rkat: rkat "(+\<^sub>K)" "\<nu>" "\<eta>" "(\<circ>\<^sub>K)" "(\<sqsubseteq>)" "(\<sqsubset>)" kstar "\<alpha>\<^sub>s" sta_Re
  by (standard, unfold sta_Re_def sta_kat.Ho_def sta_kat.test_def sta_atest_def kcomp_iff kleq_iff) auto

subsection \<open>Specialised Refinement Laws\<close>

text \<open>First we consider the relational model.\<close>

abbreviation rR :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel" ("R\<^sub>r") where
   "R\<^sub>r P Q \<equiv> rel_Re \<lceil>P\<rceil>\<^sub>r \<lceil>Q\<rceil>\<^sub>r"

lemma rR_unfold: "R\<^sub>r P Q = \<Union>{R. \<forall>x y. P x \<longrightarrow> (x,y) \<in> R \<longrightarrow> Q y}"
  unfolding rel_Re_def rH_unfold by simp

lemma rR_cons1:
  assumes "\<forall>s. P s \<longrightarrow> P' s"
  shows "R\<^sub>r P' Q \<subseteq> R\<^sub>r P Q"
  unfolding rR_unfold
  apply (intro Sup_subset_mono)
  using assms by force

lemma rR_cons2:
  assumes "\<forall>s. Q' s \<longrightarrow> Q s"
  shows "R\<^sub>r P Q' \<subseteq> R\<^sub>r P Q"
  unfolding rR_unfold
  apply (intro Sup_subset_mono)
  using assms by force

lemma rR_cons:
  assumes "\<forall>s. P s \<longrightarrow> P' s"
  and "\<forall>s. Q' s \<longrightarrow> Q s"
  shows "R\<^sub>r P' Q' \<subseteq> R\<^sub>r P Q"
  unfolding rR_unfold
  apply (intro Sup_subset_mono)
  using assms by force

lemma rR_skip [simp]: "(Id \<subseteq> R\<^sub>r P Q) = (\<forall>s. P s \<longrightarrow> Q s)"
  apply (simp add: rR_unfold) by force

lemma rR_cond: "rif T then R\<^sub>r (\<lambda>s. P s \<and> T s) Q else R\<^sub>r (\<lambda>s. P s \<and> \<not>T s) Q fi \<subseteq> R\<^sub>r P Q"
  by (simp add: rel_rkat.R1 rel_rkat.R2)

lemma rR_cond_var:
  assumes "R \<subseteq> R\<^sub>r (\<lambda>s. P s \<and> T s) Q"
  and "S \<subseteq> R\<^sub>r (\<lambda>s. P s \<and> \<not>T s) Q"
  shows "rif T then R else S fi \<subseteq> R\<^sub>r P Q"
  using assms rH_cond rel_rkat.spec_def by blast

lemma rR_while: "rwhile Q do R\<^sub>r (\<lambda>s. P s \<and> Q s) P od \<subseteq> R\<^sub>r P (\<lambda>s. P s \<and> \<not> Q s)"
  by (simp add: rH_while rel_rkat.R1 rel_rkat.R2)

lemma rR_while_var:
  assumes "R \<subseteq> R\<^sub>r (\<lambda>s. P s \<and> Q s) P"
  shows "rwhile Q do R od \<subseteq> R\<^sub>r P (\<lambda>s. P s \<and> \<not> Q s)"
  using assms rH_while rel_rkat.spec_def by blast

text \<open>Next we consider the state transformer model.\<close>

abbreviation sR :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a sta" ("R\<^sub>s") where
   "R\<^sub>s P Q \<equiv> sta_Re \<lceil>P\<rceil>\<^sub>s \<lceil>Q\<rceil>\<^sub>s"

lemma sR_unfold: "(R\<^sub>s P Q) x = \<Union>{f x |f.  \<forall>y z. P y \<longrightarrow> z \<in> f y \<longrightarrow> Q z}"
  unfolding sta_Re_def sH_unfold by simp

lemma sR_cons1:
  assumes "\<forall>s. P s \<longrightarrow> P' s"
  shows "R\<^sub>s P' Q \<sqsubseteq> R\<^sub>s P Q"
  unfolding sR_unfold kleq_def
  apply clarsimp
  using assms by auto

lemma sR_cons2:
  assumes "\<forall>s. Q' s \<longrightarrow> Q s"
  shows "R\<^sub>s P Q' \<sqsubseteq> R\<^sub>s P Q"
  unfolding sR_unfold kleq_def
  apply clarsimp
  using assms by blast

lemma sR_cons:
  assumes "\<forall>s. P s \<longrightarrow> P' s"
  and "\<forall>s. Q' s \<longrightarrow> Q s"
  shows "R\<^sub>s P' Q' \<sqsubseteq> R\<^sub>s P Q"
  unfolding sR_unfold kleq_def
  apply clarsimp
  using assms by blast

lemma scond_iso:
  assumes "f \<sqsubseteq> f'"
  and "g \<sqsubseteq> g'"
  shows "sif P then f else g fi \<sqsubseteq> sif P then f' else g' fi"
  by (simp add: assms sta_kat.cond_iso)

lemma swhile_iso:
  assumes "f \<sqsubseteq> f'"
  shows "swhile P do f od \<sqsubseteq> swhile P do f' od"
  by (simp add: assms sta_kat.while_iso)

lemma sR_skip: "\<eta> \<sqsubseteq> R\<^sub>s P Q = (\<forall>s. P s \<longrightarrow> Q s)"
  by (simp add: sH_skip sta_rkat.spec_def)

lemma sR_cond: "sif T then R\<^sub>s (\<lambda>s. P s \<and> T s) Q else R\<^sub>s (\<lambda>s. P s \<and> \<not>T s) Q fi \<sqsubseteq> R\<^sub>s P Q"
  by (simp add: sta_rkat.R1 sta_rkat.R2)

lemma sR_cond_var:
  assumes "f \<sqsubseteq> R\<^sub>s (\<lambda>s. P s \<and> T s) Q"
  and "g \<sqsubseteq> R\<^sub>s (\<lambda>s. P s \<and> \<not>T s) Q"
shows "sif T then f else g fi \<sqsubseteq> R\<^sub>s P Q"
  using assms sH_cond sta_rkat.spec_def by blast

lemma sR_while: "swhile Q do R\<^sub>s (\<lambda>s. P s \<and> Q s) P od \<sqsubseteq> R\<^sub>s P (\<lambda>s. P s \<and> \<not> Q s)"
  by (simp add: sH_while sta_rkat.R1 sta_rkat.spec_def)

lemma sR_while_var:
  assumes "f \<sqsubseteq> R\<^sub>s (\<lambda>s. P s \<and> Q s) P"
  shows "swhile Q do f od \<sqsubseteq> R\<^sub>s P (\<lambda>s. P s \<and> \<not> Q s)"
  using assms sR_while sta_di.dual_order.trans swhile_iso by blast

subsection \<open>Assignment Laws\<close>

text \<open>The store model is from KAT\<close>

lemma rR_assign [simp]: "((v :=\<^sub>r e) \<subseteq> R\<^sub>r P Q) = (\<forall>s. P s \<longrightarrow> Q (set v e s))"
  by (simp add: rel_rkat.spec_def)

lemma rR_assignl:
  assumes "\<forall>s. P s \<longrightarrow> P' (set v e s)"
  shows "(v :=\<^sub>r e) ; (R\<^sub>r P' Q) \<subseteq> R\<^sub>r P Q"
proof -
    have "v :=\<^sub>r e \<subseteq> R\<^sub>r P P'"
    using assms by simp
  then show ?thesis
    by (meson order.trans rel_d.mult_isor rel_rkat.R_seq)
qed

lemma rR_assignr:
  assumes "\<forall>s. Q' s \<longrightarrow> Q (set v e s)"
  shows "(R\<^sub>r P Q') ; (v :=\<^sub>r e) \<subseteq> R\<^sub>r P Q"
proof -
 have "v :=\<^sub>r e \<subseteq> R\<^sub>r Q' Q"
    using assms by simp
  then show ?thesis
    by (meson rel_d.mult_isol rel_rkat.R_seq subset_trans)
qed

lemma sR_assign [simp]: "(\<forall>s. P s \<longrightarrow> Q (set v e s)) = ((v :=\<^sub>s e) \<sqsubseteq> R\<^sub>s P Q)"
  by (simp add: sta_rkat.spec_def)

lemma sR_assignr:
  assumes "\<forall>s. Q' s \<longrightarrow> Q (set v e s)"
  shows "(R\<^sub>s P Q') \<circ>\<^sub>K (v :=\<^sub>s e) \<sqsubseteq> R\<^sub>s P Q"
proof -
   have "v :=\<^sub>s e \<sqsubseteq> R\<^sub>s Q' Q"
    using assms by simp
  then show ?thesis
    using sta_kat.H_seq sta_rkat.spec_def by blast
qed

lemma sR_assignl:
  assumes "\<forall>s. P s \<longrightarrow> P' (set v e s)"
  shows "(v :=\<^sub>s e) \<circ>\<^sub>K (R\<^sub>s P' Q) \<sqsubseteq> R\<^sub>s P Q"
proof -
   have "v :=\<^sub>s e \<sqsubseteq> R\<^sub>s P P'"
    using assms by simp
  then show ?thesis
    using sta_kat.H_seq sta_rkat.spec_def by blast
qed

subsection \<open>Refinement Examples\<close>

text \<open>Variable Swap\<close>

lemma var_swap_ref1:
  "R\<^sub>r (\<lambda>s. s ''x'' = a \<and> s ''y'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)
   \<supseteq> (''z'' :=\<^sub>r (\<lambda>s. s ''x'')); R\<^sub>r (\<lambda>s. s ''z'' = a \<and> s ''y'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  by (rule rR_assignl) simp

lemma var_swap_ref2:
  "R\<^sub>r (\<lambda>s. s ''z'' = a \<and> s ''y'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)
   \<supseteq> (''x'' :=\<^sub>r (\<lambda>s. s ''y'')); R\<^sub>r (\<lambda>s. s ''z'' = a \<and> s ''x'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  by (rule rR_assignl) simp

lemma var_swap_ref3:
  "R\<^sub>r (\<lambda>s. s ''z'' = a \<and> s ''x'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)
   \<supseteq> (''y'' :=\<^sub>r (\<lambda>s. s ''z'')); R\<^sub>r (\<lambda>s. s ''x'' = b \<and> s ''y'' = a) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  by (rule rR_assignl) simp

lemma var_swap_ref:
  "R\<^sub>r (\<lambda>s. s ''x'' = a \<and> s ''y'' = b) (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)
   \<supseteq> (''z'' :=\<^sub>r (\<lambda>s. s ''x'')) ; (''x'' :=\<^sub>r (\<lambda>s. s ''y'')) ; (''y'' :=\<^sub>r (\<lambda>s. s ''z''))"
  by (simp add: rel_rkat.R2 rvarible_swap)

text \<open>Maximum\<close>

lemma max1:
  "R\<^sub>r (\<lambda>s::int store. s ''x'' \<ge> s ''y'') (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))
   \<supseteq> R\<^sub>r (\<lambda>s. s ''x'' \<ge> s ''y'') (\<lambda>s. s ''y'' \<le> s ''x'') ; (''z'' :=\<^sub>r (\<lambda>s. s ''x''))"
  by (smt fun_update_simp1 fun_update_simp2 rR_assignr)

lemma max11:
  "R\<^sub>r (\<lambda>s. s ''x'' \<ge> s ''y'') (\<lambda>s. s ''y'' \<le> s ''x'') ; (''z'' :=\<^sub>r (\<lambda>s. s ''x''))
  \<supseteq> ''z'' :=\<^sub>r (\<lambda>s. s ''x'')"
  using rel_rkat.R_skip by fastforce

lemma max2:
  "R\<^sub>r (\<lambda>s::int store. s ''x'' < s ''y'') (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))
   \<supseteq> R\<^sub>r (\<lambda>s. s ''x'' < s ''y'') (\<lambda>s. s ''x'' < s ''y'') ; (''z'' :=\<^sub>r (\<lambda>s. s ''y''))"
  by (smt fun_update_simp1 fun_update_simp2 rR_assignr)

lemma max21:
  "R\<^sub>r (\<lambda>s. s ''x'' < s ''y'') (\<lambda>s. s ''x'' < s ''y'') ; (''z'' :=\<^sub>r (\<lambda>s. s ''y''))
  \<supseteq> ''z'' :=\<^sub>r (\<lambda>s. s ''y'')"
  using rel_rkat.R_skip by fastforce

lemma max_cond:
"R\<^sub>r (\<lambda>s::int store. True) (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))
\<supseteq> rif (\<lambda>s. s ''x'' \<ge> s ''y'')
     then (R\<^sub>r (\<lambda>s. s ''x'' \<ge> s ''y'') (\<lambda>s. s ''z'' = max (s ''x'') (s ''y'')))
     else (R\<^sub>r (\<lambda>s. s ''x'' < s ''y'') (\<lambda>s. s ''z'' = max (s ''x'') (s ''y'')))
   fi"
  by (simp add: rR_cond_var rR_cons)

lemma maximum:
   "R\<^sub>r (\<lambda>s::int store. True) (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))
   \<supseteq> (rif (\<lambda>s. s ''x'' \<ge> s ''y'')
         then (''z'' :=\<^sub>r (\<lambda>s. s ''x''))
         else (''z'' :=\<^sub>r (\<lambda>s. s ''y''))
       fi)"
  using rel_rkat.R2 rmaximum by blast

text \<open>Integer Division\<close>

abbreviation "Idiv s \<equiv> s ''x'' = s ''q'' * s ''y'' + s ''r''"

abbreviation "Tdiv s \<equiv> s ''y'' \<le> s ''r''"

lemma div_init1: "R\<^sub>r (\<lambda>s::nat store. 0 < s ''y'') (\<lambda>s. Idiv s  \<and> \<not>Tdiv s) \<supseteq>
  (''r'' :=\<^sub>r (\<lambda>s. s ''x''));
  R\<^sub>r (\<lambda>s. s ''r'' = s ''x'' \<and> s ''x'' \<ge> 0) (\<lambda>s. Idiv s \<and> \<not>Tdiv s)"
  by (rule rR_assignl) simp

lemma div_init2: "R\<^sub>r (\<lambda>s::nat store. s ''r'' = s ''x'') (\<lambda>s. Idiv s \<and> \<not> Tdiv s) \<supseteq>
  (''q'' :=\<^sub>r (\<lambda>s. 0));
  R\<^sub>r (\<lambda>s. s ''r'' = s ''x'' \<and> s ''q'' = 0) (\<lambda>s. Idiv s \<and> \<not> Tdiv s)"
  by (rule rR_assignl) simp

lemma div_init3:
  "R\<^sub>r (\<lambda>s::nat store. s ''r'' = s ''x'' \<and> s ''q'' = 0) (\<lambda>s. Idiv s \<and> \<not> Tdiv s) \<supseteq>
  R\<^sub>r Idiv (\<lambda>s. Idiv s \<and> \<not> Tdiv s)"
  by (simp_all add: rR_cons)

lemma div_loop: "R\<^sub>r Idiv (\<lambda>s. Idiv s \<and> \<not> Tdiv s) \<supseteq>
  rwhile Tdiv do (R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) Idiv) od"
  by (simp add: rR_while)

lemma div_body1: "R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) Idiv \<supseteq>
  R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) (\<lambda>s::nat store. s ''x'' = s ''q'' * s ''y'' + (s ''r'' - s ''y'')) ;
  (''r'' :=\<^sub>r (\<lambda>s. s ''r'' - s ''y''))"
  by (simp add: rR_assignr)

lemma div_body2:
  "R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) (\<lambda>s::nat store. s ''x'' = s ''q'' * s ''y'' + (s ''r'' - s ''y'')) \<supseteq>
  R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) (\<lambda>s. Idiv s \<and>  Tdiv s) ; (''q'' :=\<^sub>r (\<lambda>s. s ''q'' + 1))"
  by  (simp add: rR_assignr)

lemma div_while: "rwhile Tdiv do R\<^sub>r (\<lambda>s. Idiv s \<and> Tdiv s) Idiv od \<supseteq>
  rwhile Tdiv do
    (''q'' :=\<^sub>r (\<lambda>f. f ''q'' + (1::nat)));
    (''r'' :=\<^sub>r (\<lambda>f. f ''r'' - f ''y''))
  od"
  apply (rule rel_kat.while_iso)
  using div_body1 div_body2 rel_rkat.R_skip by blast

lemma integer_division: "R\<^sub>r (\<lambda>s::nat store. 0 < s ''y'') (\<lambda>s. Idiv s \<and> \<not> Tdiv s) \<supseteq>
  (''r'' :=\<^sub>r (\<lambda>s. s ''x''));
  (''q'' :=\<^sub>r (\<lambda>s. 0));
  (rwhile Tdiv do
      (''q'' :=\<^sub>r (\<lambda>s::nat store. s ''q'' + 1));
      (''r'' :=\<^sub>r (\<lambda>s. s ''r'' - s ''y''))
  od)"
  using div_init1 div_init2 div_init3 div_loop div_while by force

end


(*
Title:  Allen's qualitative temporal calculus
Author:  Fadoua Ghourabi (fadouaghourabi@gmail.com)
Affiliation: Ochanomizu University, Japan
*)

theory disjoint_relations

imports
  allen

begin

section \<open>PD property\<close>
text \<open>The 13 time interval relations (i.e. e, b, m, s, f, d, ov and their inverse relations) are pairwise disjoint.\<close>

 (**e**)
lemma em (*[simp]*):"e \<inter> m = {}"
using e m  meets_irrefl
by (metis ComplI disjoint_eq_subset_Compl meets_wd subrelI)

lemma  eb (*[simp]*):"e \<inter> b = {}"
using b e meets_asym
by (metis ComplI disjoint_eq_subset_Compl subrelI)

lemma  eov (*[simp]*):"e \<inter> ov = {}"
apply (auto simp: e ov)
using elimmeets by blast

lemma  es (*[simp]*):"e \<inter> s = {}"
apply (auto simp:e s)
using elimmeets by blast

lemma  ef (*[simp]*):"e \<inter> f = {}"
using e f by (metis (no_types, lifting) ComplI disjoint_eq_subset_Compl meets_atrans subrelI)

lemma  ed (*[simp]*):"e \<inter> d = {}"
using e d by (metis (no_types, lifting) ComplI disjoint_eq_subset_Compl meets_atrans subrelI)

lemma  emi (*[simp]*):"e \<inter> m^-1 = {}"
using converseE em e
by (metis disjoint_iff_not_equal)

lemma  ebi (*[simp]*):"e \<inter> b^-1 = {}"
using converseE eb e
by (metis disjoint_iff_not_equal)

lemma  eovi (*[simp]*):"e \<inter> ov^-1 = {}"
using converseE eov e
by (metis disjoint_iff_not_equal)

lemma  esi (*[simp]*):"e \<inter> s^-1 = {}"
using converseE es e
by (metis disjoint_iff_not_equal)

lemma  efi (*[simp]*):"e \<inter> f^-1 = {}"
using converseE ef e
by (metis disjoint_iff_not_equal)

lemma edi (*[simp]*):"e \<inter> d^-1 = {}"
using converseE ed e
by (metis disjoint_iff_not_equal)

(**m**)
lemma  mb (*[simp]*):"m \<inter> b = {}"
using m b
apply auto
using elimmeets by blast

lemma  mov (*[simp]*): "m \<inter> ov = {}"
apply (auto simp:m ov)
by (meson M1 elimmeets)

lemma  ms (*[simp]*):"m \<inter> s = {}"
apply (auto simp:m s)
by (meson M1 elimmeets)

lemma  mf (*[simp]*):"m \<inter> f = {}"
apply (auto simp:m f)
using elimmeets by blast

lemma  md (*[simp]*):"m \<inter> d = {}"
apply (auto simp: m d)
using trans2 by blast

lemma  mi (*[simp]*):"m \<inter> m^-1 = {}"
apply (auto simp:m)
using converseE m meets_asym by blast

lemma  mbi (*[simp]*):"m \<inter> b^-1 = {}"
apply (auto simp:mb)
apply (auto simp: m b)
using nontrans2 by blast

lemma movi (*[simp]*):"m \<inter> ov^-1 = {}"
using m ov
apply auto
using trans2 by blast

lemma  msi (*[simp]*):"m \<inter> s^-1 = {}"
apply (auto simp:m s)
by (meson M1 elimmeets)

lemma  mfi (*[simp]*):"m \<inter> f^-1 = {}"
apply (auto simp:m f)
by (meson M1 elimmeets)

lemma  mdi (*[simp]*):"m \<inter> d^-1 = {}"
apply (auto simp:m d)
using trans2 by blast

(**b**)
lemma bov (*[simp]*):"b \<inter> ov = {}"
apply (auto simp:b ov)
by (meson M1 trans2)

lemma bs (*[simp]*):"b \<inter> s = {}"
apply (auto simp:b s)
by (meson M1 trans2)

lemma  bf (*[simp]*):"b \<inter> f = {}"
apply (auto simp: b f)
by (meson M1 trans2)

lemma bd (*[simp]*):"b \<inter> d = {}"
apply (auto simp:b d)
by (meson M1 nonmeets4)

lemma  bmi (*[simp]*):"b \<inter> m^-1 = {}"
using mbi by auto

lemma  bi (*[simp]*):"b \<inter> b^-1 = {}"
apply (auto simp:b)
using M5exist_var3 trans2 by blast

lemma bovi (*[simp]*):"b \<inter> ov^-1 = {}"
apply (auto simp:bov)
apply (auto simp:b ov)
by (meson M1 nontrans2)

lemma  bsi (*[simp]*):"b \<inter> s^-1 = {}"
using bs apply auto using b s apply auto
using trans2 by blast

lemma bfi (*[simp]*):"b \<inter> f^-1 = {}"
using bf apply auto using b f apply auto
using trans2 by blast

lemma  bdi (*[simp]*):"b \<inter> d^-1 = {}"
apply (auto simp:bd)
apply (auto simp:b d)
using trans2
using M1 nonmeets4 by blast

(**ov**)
lemma ovs (*[simp]*):"ov \<inter> s = {}"
apply (auto simp:ov s)
by (meson M1 meets_atrans)

lemma ovf (*[simp]*):"ov \<inter> f = {}"
apply (auto simp:ov f)
by (meson M1 meets_atrans)

lemma ovd (*[simp]*):"ov\<inter> d = {}"
apply (auto simp:ov d)
by (meson M1 trans2)

lemma ovmi (*[simp]*):"ov \<inter> m^-1 = {}"
using movi by auto

lemma  ovbi (*[simp]*):"ov \<inter> b^-1 = {}"
using bovi by blast

lemma ovi (*[simp]*):"ov \<inter> ov^-1 = {}"
apply (auto simp:ov)
by (meson M1 trans2)

lemma ovsi (*[simp]*):"ov \<inter> s^-1 = {}"
apply (auto simp:ov s)
by (meson M1 elimmeets)

lemma ovfi (*[simp]*):"ov \<inter> f^-1 = {}"
apply (auto simp:ov f)
by (meson M1 elimmeets)

lemma ovdi (*[simp]*):"ov \<inter> d^-1 = {}"
apply (auto simp:ov d)
by (meson M1 trans2)

(**s**)
lemma  sf (*[simp]*):"s \<inter> f = {}"
apply (auto simp:s f)
by (metis M4 elimmeets)

lemma sd (*[simp]*):"s \<inter> d = {}"
apply (auto simp:s d)
by (metis M1 meets_atrans)

lemma smi (*[simp]*):"s \<inter> m^-1 = {}"
using msi by auto

lemma  sbi (*[simp]*):"s \<inter> b^-1 = {}"
using bsi by blast

lemma  sovi (*[simp]*):"s \<inter> ov^-1 = {}"
using ovsi by auto

lemma  si (*[simp]*):"s \<inter> s^-1 = {}"
apply (auto simp:s)
by (meson M1 trans2)

lemma sfi (*[simp]*):"s \<inter> f^-1 = {}"
apply (auto simp:s f)
by (metis M4 elimmeets)

lemma sdi (*[simp]*):"s\<inter> d^-1 = {}"
apply (auto simp:s d)
by (meson M1 meets_atrans)

(**f**)

lemma fmi (*[simp]*):"f \<inter> m^-1 = {}"
using mfi by auto

lemma  fbi (*[simp]*):"f \<inter> b^-1 = {}"
using bfi converse_Int by auto

lemma fovi (*[simp]*):"f \<inter> ov^-1 = {}"
  using ovfi by auto

lemma fsi (*[simp]*):"f \<inter> s^-1 = {}"
using sfi by auto

lemma fi (*[simp]*):"f \<inter> f^-1 = {}"
apply (auto simp:f)
by (meson M1 trans2)

lemma fdi (*[simp]*):"f \<inter> d^-1 = {}"
apply (auto simp:f d)
by (meson M1 trans2)

(**d**)
lemma dmi (*[simp]*):"d \<inter> m^-1 = {}"
using mdi by auto

lemma  dbi (*[simp]*):"d \<inter> b^-1 = {}"
using bdi by blast

lemma dovi (*[simp]*):"d \<inter> ov^-1 = {}"
using ovdi by auto

lemma  dsi (*[simp]*):"d \<inter> s^-1 = {}"
using sdi by auto

lemma  dfi (*[simp]*):"d \<inter> f^-1 = {}"
apply (auto simp:d f)
by (meson M1 trans2)

lemma  di (*[simp]*):"d \<inter> d^-1 = {}"
apply (auto simp:d)
by (meson M1 trans2)

(**m^-1**)
lemma mibi (*[simp]*):"m^-1 \<inter> b^-1 = {}"
using mb by auto

lemma miovi (*[simp]*):"m^-1 \<inter> ov^-1 = {}"
using mov by auto

lemma misi (*[simp]*):"m^-1 \<inter> s^-1 = {}"
using ms by auto

lemma mifi (*[simp]*):"m^-1 \<inter> f^-1 = {}"
using mf by auto

lemma midi (*[simp]*):"m^-1 \<inter> d^-1 = {}"
using md by auto

(**b^-1**)
lemma  bid (*[simp]*):"b^-1 \<inter> d = {}"
by (simp add: dbi inf_sup_aci(1))

lemma  bimi (*[simp]*):"b^-1 \<inter> m^-1 = {}"
using mibi by auto

lemma  biovi (*[simp]*):"b^-1 \<inter> ov^-1 = {}"
using bov by blast

lemma  bisi (*[simp]*):"b^-1 \<inter> s^-1 = {}"
using bs by blast

lemma bifi (*[simp]*):"b^-1 \<inter> f^-1 = {}"
using bf by blast

lemma bidi (*[simp]*):"b^-1 \<inter> d^-1 = {}"
using bd by blast

(** ov^-1**)
lemma ovisi (*[simp]*):"ov^-1 \<inter> s^-1 = {}"
using ovs by blast

lemma ovifi (*[simp]*):"ov^-1 \<inter> f^-1 = {}"
using ovf by blast

lemma ovidi (*[simp]*):"ov^-1 \<inter> d^-1 = {}"
using ovd by blast

(** s^-1 **)
lemma sifi (*[simp]*):"s^-1 \<inter> f^-1 = {}"
using sf by blast

lemma sidi (*[simp]*):"s^-1 \<inter> d^-1 = {}"
using sd by blast

(** f^-1**)
lemma fidi (*[simp]*):"f^-1 \<inter> d^-1 = {}"
using fd by blast

lemma rdisj_sym:"A \<inter> B = {} \<Longrightarrow> B \<inter> A = {}"
by auto

subsection \<open>Intersection rules\<close>
named_theorems e_rules declare em[e_rules] and eb[e_rules] and eov[e_rules] and es[e_rules] and ef[e_rules] and ed[e_rules] and emi[e_rules] and ebi[e_rules] and eovi[e_rules]
and esi[e_rules] and efi[e_rules] and edi[e_rules]

named_theorems m_rules declare em[THEN rdisj_sym, m_rules] and mb [m_rules] and ms  [m_rules] and mov [m_rules] and mf[m_rules] and
md[m_rules] and mi [m_rules] and mbi [m_rules] and movi [m_rules] and msi [m_rules] and mfi [m_rules] and mdi [m_rules] and emi[m_rules]

named_theorems b_rules declare eb[THEN rdisj_sym, b_rules] and mb [THEN rdisj_sym, b_rules] and bs  [b_rules] and bov [b_rules] and bf[b_rules] and
bd[b_rules] and bmi [b_rules] and bi [b_rules] and bovi [b_rules] and bsi [b_rules] and bfi [b_rules] and bdi [b_rules] and ebi[b_rules]

named_theorems ov_rules declare eov[THEN rdisj_sym, ov_rules] and mov [THEN rdisj_sym, ov_rules] and ovs  [ov_rules] and bov [THEN rdisj_sym,ov_rules] and ovf[ov_rules] and
ovd[ov_rules] and ovmi [ov_rules] and  ovi [ov_rules] and ovsi [ov_rules] and ovfi [ov_rules] and ovdi [ov_rules] and eovi[ov_rules]

named_theorems s_rules declare es[THEN rdisj_sym, s_rules] and ms [THEN rdisj_sym, s_rules] and ovs  [THEN rdisj_sym, s_rules] and bs [THEN rdisj_sym,s_rules] and sf[s_rules] and
sd[s_rules] and smi [s_rules] and  sovi [s_rules] and si [s_rules] and sfi [s_rules] and sdi [s_rules]

named_theorems d_rules declare ed[THEN rdisj_sym, d_rules] and md [THEN rdisj_sym, d_rules] and sd  [THEN rdisj_sym, d_rules]  and fd[THEN rdisj_sym, d_rules] and
ovd[THEN rdisj_sym,d_rules] and dmi [d_rules] and  dovi [d_rules] and dsi [d_rules] and dfi [d_rules] and di [d_rules]

named_theorems f_rules declare ef[THEN rdisj_sym, f_rules] and mf [THEN rdisj_sym, f_rules] and sf  [THEN rdisj_sym, f_rules] and ovf [THEN rdisj_sym,f_rules] and fd[f_rules] and
 fmi [f_rules] and  fovi [f_rules] and fsi [f_rules] and fi [f_rules] and fdi [f_rules]

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Distinct Proposition"

theory Distinct_Prop  (* part of non-AFP Word_Lib *)
imports
  Many_More
  "HOL-Library.Prefix_Order"
begin

primrec
  distinct_prop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool)"
where
  "distinct_prop P [] = True"
| "distinct_prop P (x # xs) = ((\<forall>y\<in>set xs. P x y) \<and> distinct_prop P xs)"

primrec
  distinct_sets :: "'a set list \<Rightarrow> bool"
where
  "distinct_sets [] = True"
| "distinct_sets (x#xs) = (x \<inter> \<Union> (set xs) = {} \<and> distinct_sets xs)"

lemma distinct_prop_map:
  "distinct_prop P (map f xs) = distinct_prop (\<lambda>x y. P (f x) (f y)) xs"
  by (induct xs) auto

lemma distinct_prop_append:
  "distinct_prop P (xs @ ys) =
    (distinct_prop P xs \<and> distinct_prop P ys \<and> (\<forall>x \<in> set xs. \<forall>y \<in> set ys. P x y))"
  by (induct xs arbitrary: ys) (auto simp: conj_comms ball_Un)

lemma distinct_prop_distinct:
  "\<lbrakk> distinct xs; \<And>x y. \<lbrakk> x \<in> set xs; y \<in> set xs; x \<noteq> y \<rbrakk> \<Longrightarrow> P x y \<rbrakk> \<Longrightarrow> distinct_prop P xs"
  by (induct xs) auto

lemma distinct_prop_True [simp]:
  "distinct_prop (\<lambda>x y. True) xs"
  by (induct xs, auto)

lemma distinct_prefix:
  "\<lbrakk> distinct xs; ys \<le> xs \<rbrakk> \<Longrightarrow> distinct ys"
  apply (induct xs arbitrary: ys; clarsimp)
  apply (case_tac ys; clarsimp)
  by (fastforce simp: less_eq_list_def dest: set_mono_prefix)

lemma distinct_sets_prop:
  "distinct_sets xs = distinct_prop (\<lambda>x y. x \<inter> y = {}) xs"
  by (induct xs) auto

lemma distinct_take_strg:
  "distinct xs \<longrightarrow> distinct (take n xs)"
  by simp

lemma distinct_prop_prefixE:
  "\<lbrakk> distinct_prop P ys; prefix xs ys \<rbrakk> \<Longrightarrow> distinct_prop P xs"
  apply (induct xs arbitrary: ys; clarsimp)
  apply (case_tac ys; clarsimp)
  by (fastforce dest: set_mono_prefix)

lemma distinct_sets_union_sub:
  "\<lbrakk>x \<in> A; distinct_sets [A,B]\<rbrakk> \<Longrightarrow> A \<union> B - {x} = A - {x} \<union> B"
  by (auto simp: distinct_sets_def)

lemma distinct_sets_append:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets xs \<and> distinct_sets ys"
  apply (subst distinct_sets_prop)+
  apply (subst (asm) distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_append1:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets xs"
  by (drule distinct_sets_append, simp)

lemma distinct_sets_append2:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets ys"
  by (drule distinct_sets_append, simp)

lemma distinct_sets_append_Cons:
  "distinct_sets (xs @ a # ys) \<Longrightarrow> distinct_sets (xs @ ys)"
  apply (subst distinct_sets_prop)+
  apply (subst (asm) distinct_sets_prop)
  apply (subst distinct_prop_append)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_append_Cons_disjoint:
  "distinct_sets (xs @ a # ys) \<Longrightarrow>  a \<inter> \<Union> (set xs) = {} "
  apply (subst (asm) distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply (subst Int_commute)
  apply (subst Union_disjoint)
  apply clarsimp
  done

lemma distinct_prop_take:
  "\<lbrakk>distinct_prop P xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_prop P (take i xs)"
  by (metis take_is_prefix distinct_prop_prefixE)

lemma distinct_sets_take:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (take i xs)"
  by (simp add: distinct_sets_prop distinct_prop_take)

lemma distinct_prop_take_Suc:
  "\<lbrakk>distinct_prop P xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_prop P (take (Suc i) xs)"
  by (metis distinct_prop_take not_less take_all)

lemma distinct_sets_take_Suc:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (take (Suc i) xs)"
  by (simp add: distinct_sets_prop distinct_prop_take_Suc)

lemma distinct_prop_rev:
  "distinct_prop P (rev xs) = distinct_prop (\<lambda>y x. P x y) xs"
  by (induct xs) (auto simp: distinct_prop_append)

lemma distinct_sets_rev [simp]:
  "distinct_sets (rev xs) = distinct_sets xs"
  apply (unfold distinct_sets_prop)
  apply (subst distinct_prop_rev)
  apply (subst Int_commute)
  apply clarsimp
  done

lemma distinct_sets_drop:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (drop i xs)"
  apply (cases "i=0", simp)
  apply (subst distinct_sets_rev [symmetric])
  apply (subst rev_drop)
  apply (subst distinct_sets_take, simp_all)
  done

lemma distinct_sets_drop_Suc:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (drop (Suc i) xs)"
  apply (subst distinct_sets_rev [symmetric])
  apply (subst rev_drop)
  apply (subst distinct_sets_take, simp_all)
  done

lemma distinct_sets_take_nth:
  "\<lbrakk>distinct_sets xs; i < length xs; x \<in> set (take i xs)\<rbrakk> \<Longrightarrow> x \<inter> xs ! i = {}"
  apply (drule (1) distinct_sets_take_Suc)
  apply (subst (asm) take_Suc_conv_app_nth, assumption)
  apply (unfold distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_drop_nth:
  "\<lbrakk>distinct_sets xs; i < length xs; x \<in> set (drop (Suc i) xs)\<rbrakk> \<Longrightarrow> x \<inter> xs ! i = {}"
  apply (drule (1) distinct_sets_drop)
  apply (subst (asm) drop_Suc_nth, assumption)
  apply fastforce
  done

lemma distinct_sets_append_distinct:
  "\<lbrakk>x \<in> set xs; y \<in> set ys; distinct_sets (xs @ ys)\<rbrakk> \<Longrightarrow> x \<inter> y = {}"
  unfolding distinct_sets_prop by (clarsimp simp: distinct_prop_append)

lemma distinct_sets_update:
 "\<lbrakk>a \<subseteq> xs ! i; distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (xs[i := a])"
  apply (subst distinct_sets_prop)
  apply (subst (asm) distinct_sets_prop)
  apply (subst upd_conv_take_nth_drop, simp)
  apply (subst distinct_prop_append)
  apply (intro conjI)
    apply (erule (1) distinct_prop_take)
   apply (rule conjI|clarsimp)+
    apply (fold distinct_sets_prop)
    apply (drule (1) distinct_sets_drop)
    apply (subst (asm) drop_Suc_nth, assumption)
    apply fastforce
   apply (drule (1) distinct_sets_drop)
   apply (subst (asm) drop_Suc_nth, assumption)
   apply clarsimp
  apply clarsimp
  apply (rule conjI)
   apply (drule (2) distinct_sets_take_nth)
   apply blast
  apply clarsimp
  apply (thin_tac "P \<subseteq> Q" for P Q)
  apply (subst (asm) id_take_nth_drop, assumption)
  apply (drule distinct_sets_append_Cons)
  apply (erule (2) distinct_sets_append_distinct)
  done

lemma distinct_sets_map_update:
  "\<lbrakk>distinct_sets (map f xs); i < length xs; f a \<subseteq> f(xs ! i)\<rbrakk>
  \<Longrightarrow> distinct_sets (map f (xs[i := a]))"
  by (metis distinct_sets_update length_map map_update nth_map)

lemma Union_list_update:
  "\<lbrakk>i < length xs; distinct_sets (map f xs)\<rbrakk>
  \<Longrightarrow> (\<Union>x\<in>set (xs [i := a]). f x) = (\<Union>x\<in>set xs. f x) - f (xs ! i) \<union> f a"
  apply (induct xs arbitrary: i; clarsimp)
  apply (case_tac i; (clarsimp, fastforce))
  done

lemma fst_enumerate:
  "i < length xs \<Longrightarrow> fst (enumerate n xs ! i) = i + n"
  by (metis add.commute fst_conv nth_enumerate_eq)

lemma snd_enumerate:
  "i < length xs \<Longrightarrow> snd (enumerate n xs ! i) = xs ! i"
  by (metis nth_enumerate_eq snd_conv)

lemma enumerate_member:
  assumes "i < length xs"
  shows "(n + i, xs ! i) \<in> set (enumerate n xs)"
proof -
  have pair_unpack: "\<And>a b x. ((a, b) = x) = (a = fst x \<and> b = snd x)" by fastforce
  from assms have "(n + i, xs ! i) = enumerate n xs ! i"
    by (auto simp: fst_enumerate snd_enumerate pair_unpack)
  with assms show ?thesis by simp
qed

lemma distinct_prop_nth:
  "\<lbrakk> distinct_prop P ls; n < n'; n' < length ls \<rbrakk> \<Longrightarrow> P (ls ! n) (ls ! n')"
  apply (induct ls arbitrary: n n'; simp)
  apply (case_tac n'; simp)
  apply (case_tac n; simp)
  done

end


theory Chapter2Defs
imports Main
begin

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

lemma add_02[simp] : "add m 0 = m"
  apply(induction m)
  apply(auto)
  done

lemma suc_add [simp]: "Suc (add m n) = add m (Suc n)"
  apply(induction m)
   apply(auto)
  done

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun mirror:: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node l a r) = Node (mirror r) a (mirror l)"

end

github-repos/isabelle/mrtkp9993-Isabelle-HOL-Examples/Isabelle-HOL-Examples-37a31d2aefce20eb5c49d358c1ea236f5e693458/Programming and Proving in Isabelle-Hol Exercise Solutions/Chapter2Defs.thy


(*  Title:      HOL/Probability/Projective_Limit.thy
    Author:     Fabian Immler, TU München
*)

section \<open>Projective Limit\<close>

theory Projective_Limit
imports
  Fin_Map
  Infinite_Product_Measure
  "~~/src/HOL/Library/Diagonal_Subsequence"
begin

subsection \<open>Sequences of Finite Maps in Compact Sets\<close>

locale finmap_seqs_into_compact =
  fixes K::"nat \<Rightarrow> (nat \<Rightarrow>\<^sub>F 'a::metric_space) set" and f::"nat \<Rightarrow> (nat \<Rightarrow>\<^sub>F 'a)" and M
  assumes compact: "\<And>n. compact (K n)"
  assumes f_in_K: "\<And>n. K n \<noteq> {}"
  assumes domain_K: "\<And>n. k \<in> K n \<Longrightarrow> domain k = domain (f n)"
  assumes proj_in_K:
    "\<And>t n m. m \<ge> n \<Longrightarrow> t \<in> domain (f n) \<Longrightarrow> (f m)\<^sub>F t \<in> (\<lambda>k. (k)\<^sub>F t) ` K n"
begin

lemma proj_in_K': "(\<exists>n. \<forall>m \<ge> n. (f m)\<^sub>F t \<in> (\<lambda>k. (k)\<^sub>F t) ` K n)"
  using proj_in_K f_in_K
proof cases
  obtain k where "k \<in> K (Suc 0)" using f_in_K by auto
  assume "\<forall>n. t \<notin> domain (f n)"
  thus ?thesis
    by (auto intro!: exI[where x=1] image_eqI[OF _ \<open>k \<in> K (Suc 0)\<close>]
      simp: domain_K[OF \<open>k \<in> K (Suc 0)\<close>])
qed blast

lemma proj_in_KE:
  obtains n where "\<And>m. m \<ge> n \<Longrightarrow> (f m)\<^sub>F t \<in> (\<lambda>k. (k)\<^sub>F t) ` K n"
  using proj_in_K' by blast

lemma compact_projset:
  shows "compact ((\<lambda>k. (k)\<^sub>F i) ` K n)"
  using continuous_proj compact by (rule compact_continuous_image)

end

lemma compactE':
  fixes S :: "'a :: metric_space set"
  assumes "compact S" "\<forall>n\<ge>m. f n \<in> S"
  obtains l r where "l \<in> S" "subseq r" "((f \<circ> r) \<longlongrightarrow> l) sequentially"
proof atomize_elim
  have "subseq (op + m)" by (simp add: subseq_def)
  have "\<forall>n. (f o (\<lambda>i. m + i)) n \<in> S" using assms by auto
  from seq_compactE[OF \<open>compact S\<close>[unfolded compact_eq_seq_compact_metric] this] guess l r .
  hence "l \<in> S" "subseq ((\<lambda>i. m + i) o r) \<and> (f \<circ> ((\<lambda>i. m + i) o r)) \<longlonglongrightarrow> l"
    using subseq_o[OF \<open>subseq (op + m)\<close> \<open>subseq r\<close>] by (auto simp: o_def)
  thus "\<exists>l r. l \<in> S \<and> subseq r \<and> (f \<circ> r) \<longlonglongrightarrow> l" by blast
qed

sublocale finmap_seqs_into_compact \<subseteq> subseqs "\<lambda>n s. (\<exists>l. (\<lambda>i. ((f o s) i)\<^sub>F n) \<longlonglongrightarrow> l)"
proof
  fix n s
  assume "subseq s"
  from proj_in_KE[of n] guess n0 . note n0 = this
  have "\<forall>i \<ge> n0. ((f \<circ> s) i)\<^sub>F n \<in> (\<lambda>k. (k)\<^sub>F n) ` K n0"
  proof safe
    fix i assume "n0 \<le> i"
    also have "\<dots> \<le> s i" by (rule seq_suble) fact
    finally have "n0 \<le> s i" .
    with n0 show "((f \<circ> s) i)\<^sub>F n \<in> (\<lambda>k. (k)\<^sub>F n) ` K n0 "
      by auto
  qed
  from compactE'[OF compact_projset this] guess ls rs .
  thus "\<exists>r'. subseq r' \<and> (\<exists>l. (\<lambda>i. ((f \<circ> (s \<circ> r')) i)\<^sub>F n) \<longlonglongrightarrow> l)" by (auto simp: o_def)
qed

lemma (in finmap_seqs_into_compact) diagonal_tendsto: "\<exists>l. (\<lambda>i. (f (diagseq i))\<^sub>F n) \<longlonglongrightarrow> l"
proof -
  obtain l where "(\<lambda>i. ((f o (diagseq o op + (Suc n))) i)\<^sub>F n) \<longlonglongrightarrow> l"
  proof (atomize_elim, rule diagseq_holds)
    fix r s n
    assume "subseq r"
    assume "\<exists>l. (\<lambda>i. ((f \<circ> s) i)\<^sub>F n) \<longlonglongrightarrow> l"
    then obtain l where "((\<lambda>i. (f i)\<^sub>F n) o s) \<longlonglongrightarrow> l"
      by (auto simp: o_def)
    hence "((\<lambda>i. (f i)\<^sub>F n) o s o r) \<longlonglongrightarrow> l" using \<open>subseq r\<close>
      by (rule LIMSEQ_subseq_LIMSEQ)
    thus "\<exists>l. (\<lambda>i. ((f \<circ> (s \<circ> r)) i)\<^sub>F n) \<longlonglongrightarrow> l" by (auto simp add: o_def)
  qed
  hence "(\<lambda>i. ((f (diagseq (i + Suc n))))\<^sub>F n) \<longlonglongrightarrow> l" by (simp add: ac_simps)
  hence "(\<lambda>i. (f (diagseq i))\<^sub>F n) \<longlonglongrightarrow> l" by (rule LIMSEQ_offset)
  thus ?thesis ..
qed

subsection \<open>Daniell-Kolmogorov Theorem\<close>

text \<open>Existence of Projective Limit\<close>

locale polish_projective = projective_family I P "\<lambda>_. borel::'a::polish_space measure"
  for I::"'i set" and P
begin

lemma emeasure_lim_emb:
  assumes X: "J \<subseteq> I" "finite J" "X \<in> sets (\<Pi>\<^sub>M i\<in>J. borel)"
  shows "lim (emb I J X) = P J X"
proof (rule emeasure_lim)
  write mu_G ("\<mu>G")
  interpret generator: algebra "space (PiM I (\<lambda>i. borel))" generator
    by (rule algebra_generator)

  fix J and B :: "nat \<Rightarrow> ('i \<Rightarrow> 'a) set"
  assume J: "\<And>n. finite (J n)" "\<And>n. J n \<subseteq> I" "\<And>n. B n \<in> sets (\<Pi>\<^sub>M i\<in>J n. borel)" "incseq J"
    and B: "decseq (\<lambda>n. emb I (J n) (B n))"
    and "0 < (INF i. P (J i) (B i))" (is "0 < ?a")
  moreover have "?a \<le> 1"
    using J by (auto intro!: INF_lower2[of 0] prob_space_P[THEN prob_space.measure_le_1])
  ultimately obtain r where r: "?a = ennreal r" "0 < r" "r \<le> 1"
    by (cases "?a") (auto simp: top_unique)
  define Z where "Z n = emb I (J n) (B n)" for n
  have Z_mono: "n \<le> m \<Longrightarrow> Z m \<subseteq> Z n" for n m
    unfolding Z_def using B[THEN antimonoD, of n m] .
  have J_mono: "\<And>n m. n \<le> m \<Longrightarrow> J n \<subseteq> J m"
    using \<open>incseq J\<close> by (force simp: incseq_def)
  note [simp] = \<open>\<And>n. finite (J n)\<close>
  interpret prob_space "P (J i)" for i using J prob_space_P by simp

  have P_eq[simp]:
      "sets (P (J i)) = sets (\<Pi>\<^sub>M i\<in>J i. borel)" "space (P (J i)) = space (\<Pi>\<^sub>M i\<in>J i. borel)" for i
    using J by (auto simp: sets_P space_P)

  have "Z i \<in> generator" for i
    unfolding Z_def by (auto intro!: generator.intros J)

  have countable_UN_J: "countable (\<Union>n. J n)" by (simp add: countable_finite)
  define Utn where "Utn = to_nat_on (\<Union>n. J n)"
  interpret function_to_finmap "J n" Utn "from_nat_into (\<Union>n. J n)" for n
    by unfold_locales (auto simp: Utn_def intro: from_nat_into_to_nat_on[OF countable_UN_J])
  have inj_on_Utn: "inj_on Utn (\<Union>n. J n)"
    unfolding Utn_def using countable_UN_J by (rule inj_on_to_nat_on)
  hence inj_on_Utn_J: "\<And>n. inj_on Utn (J n)" by (rule subset_inj_on) auto
  define P' where "P' n = mapmeasure n (P (J n)) (\<lambda>_. borel)" for n
  interpret P': prob_space "P' n" for n
    unfolding P'_def mapmeasure_def using J
    by (auto intro!: prob_space_distr fm_measurable simp: measurable_cong_sets[OF sets_P])

  let ?SUP = "\<lambda>n. SUP K : {K. K \<subseteq> fm n ` (B n) \<and> compact K}. emeasure (P' n) K"
  { fix n
    have "emeasure (P (J n)) (B n) = emeasure (P' n) (fm n ` (B n))"
      using J by (auto simp: P'_def mapmeasure_PiM space_P sets_P)
    also
    have "\<dots> = ?SUP n"
    proof (rule inner_regular)
      show "sets (P' n) = sets borel" by (simp add: borel_eq_PiF_borel P'_def)
    next
      show "fm n ` B n \<in> sets borel"
        unfolding borel_eq_PiF_borel by (auto simp: P'_def fm_image_measurable_finite sets_P J(3))
    qed simp
    finally have *: "emeasure (P (J n)) (B n) = ?SUP n" .
    have "?SUP n \<noteq> \<infinity>"
      unfolding *[symmetric] by simp
    note * this
  } note R = this
  have "\<forall>n. \<exists>K. emeasure (P (J n)) (B n) - emeasure (P' n) K \<le> 2 powr (-n) * ?a \<and> compact K \<and> K \<subseteq> fm n ` B n"
  proof
    fix n show "\<exists>K. emeasure (P (J n)) (B n) - emeasure (P' n) K \<le> ennreal (2 powr - real n) * ?a \<and>
        compact K \<and> K \<subseteq> fm n ` B n"
      unfolding R[of n]
    proof (rule ccontr)
      assume H: "\<nexists>K'. ?SUP n - emeasure (P' n) K' \<le> ennreal (2 powr - real n)  * ?a \<and>
        compact K' \<and> K' \<subseteq> fm n ` B n"
      have "?SUP n + 0 < ?SUP n + 2 powr (-n) * ?a"
        using R[of n] unfolding ennreal_add_left_cancel_less ennreal_zero_less_mult_iff
        by (auto intro: \<open>0 < ?a\<close>)
      also have "\<dots> = (SUP K:{K. K \<subseteq> fm n ` B n \<and> compact K}. emeasure (P' n) K + 2 powr (-n) * ?a)"
        by (rule ennreal_SUP_add_left[symmetric]) auto
      also have "\<dots> \<le> ?SUP n"
      proof (intro SUP_least)
        fix K assume "K \<in> {K. K \<subseteq> fm n ` B n \<and> compact K}"
        with H have "2 powr (-n) * ?a < ?SUP n - emeasure (P' n) K"
          by auto
        then show "emeasure (P' n) K + (2 powr (-n)) * ?a \<le> ?SUP n"
          by (subst (asm) less_diff_eq_ennreal) (auto simp: less_top[symmetric] R(1)[symmetric] ac_simps)
      qed
      finally show False by simp
    qed
  qed
  then obtain K' where K':
    "\<And>n. emeasure (P (J n)) (B n) - emeasure (P' n) (K' n) \<le> ennreal (2 powr - real n) * ?a"
    "\<And>n. compact (K' n)" "\<And>n. K' n \<subseteq> fm n ` B n"
    unfolding choice_iff by blast
  define K where "K n = fm n -` K' n \<inter> space (Pi\<^sub>M (J n) (\<lambda>_. borel))" for n
  have K_sets: "\<And>n. K n \<in> sets (Pi\<^sub>M (J n) (\<lambda>_. borel))"
    unfolding K_def
    using compact_imp_closed[OF \<open>compact (K' _)\<close>]
    by (intro measurable_sets[OF fm_measurable, of _ "Collect finite"])
       (auto simp: borel_eq_PiF_borel[symmetric])
  have K_B: "\<And>n. K n \<subseteq> B n"
  proof
    fix x n assume "x \<in> K n"
    then have fm_in: "fm n x \<in> fm n ` B n"
      using K' by (force simp: K_def)
    show "x \<in> B n"
      using \<open>x \<in> K n\<close> K_sets sets.sets_into_space J(1,2,3)[of n] inj_on_image_mem_iff[OF inj_on_fm]
    by (metis (no_types) Int_iff K_def fm_in space_borel)
  qed
  define Z' where "Z' n = emb I (J n) (K n)" for n
  have Z': "\<And>n. Z' n \<subseteq> Z n"
    unfolding Z'_def Z_def
  proof (rule prod_emb_mono, safe)
    fix n x assume "x \<in> K n"
    hence "fm n x \<in> K' n" "x \<in> space (Pi\<^sub>M (J n) (\<lambda>_. borel))"
      by (simp_all add: K_def space_P)
    note this(1)
    also have "K' n \<subseteq> fm n ` B n" by (simp add: K')
    finally have "fm n x \<in> fm n ` B n" .
    thus "x \<in> B n"
    proof safe
      fix y assume y: "y \<in> B n"
      hence "y \<in> space (Pi\<^sub>M (J n) (\<lambda>_. borel))" using J sets.sets_into_space[of "B n" "P (J n)"]
        by (auto simp add: space_P sets_P)
      assume "fm n x = fm n y"
      note inj_onD[OF inj_on_fm[OF space_borel],
        OF \<open>fm n x = fm n y\<close> \<open>x \<in> space _\<close> \<open>y \<in> space _\<close>]
      with y show "x \<in> B n" by simp
    qed
  qed
  have "\<And>n. Z' n \<in> generator" using J K'(2) unfolding Z'_def
    by (auto intro!: generator.intros measurable_sets[OF fm_measurable[of _ "Collect finite"]]
             simp: K_def borel_eq_PiF_borel[symmetric] compact_imp_closed)
  define Y where "Y n = (\<Inter>i\<in>{1..n}. Z' i)" for n
  hence "\<And>n k. Y (n + k) \<subseteq> Y n" by (induct_tac k) (auto simp: Y_def)
  hence Y_mono: "\<And>n m. n \<le> m \<Longrightarrow> Y m \<subseteq> Y n" by (auto simp: le_iff_add)
  have Y_Z': "\<And>n. n \<ge> 1 \<Longrightarrow> Y n \<subseteq> Z' n" by (auto simp: Y_def)
  hence Y_Z: "\<And>n. n \<ge> 1 \<Longrightarrow> Y n \<subseteq> Z n" using Z' by auto

  have Y_notempty: "\<And>n. n \<ge> 1 \<Longrightarrow> (Y n) \<noteq> {}"
  proof -
    fix n::nat assume "n \<ge> 1" hence "Y n \<subseteq> Z n" by fact
    have "Y n = (\<Inter>i\<in>{1..n}. emb I (J n) (emb (J n) (J i) (K i)))" using J J_mono
      by (auto simp: Y_def Z'_def)
    also have "\<dots> = prod_emb I (\<lambda>_. borel) (J n) (\<Inter>i\<in>{1..n}. emb (J n) (J i) (K i))"
      using \<open>n \<ge> 1\<close>
      by (subst prod_emb_INT) auto
    finally
    have Y_emb:
      "Y n = prod_emb I (\<lambda>_. borel) (J n) (\<Inter>i\<in>{1..n}. prod_emb (J n) (\<lambda>_. borel) (J i) (K i))" .
    hence "Y n \<in> generator" using J J_mono K_sets \<open>n \<ge> 1\<close>
      by (auto simp del: prod_emb_INT intro!: generator.intros)
    have *: "\<mu>G (Z n) = P (J n) (B n)"
      unfolding Z_def using J by (intro mu_G_spec) auto
    then have "\<mu>G (Z n) \<noteq> \<infinity>" by auto
    note *
    moreover have *: "\<mu>G (Y n) = P (J n) (\<Inter>i\<in>{Suc 0..n}. prod_emb (J n) (\<lambda>_. borel) (J i) (K i))"
      unfolding Y_emb using J J_mono K_sets \<open>n \<ge> 1\<close> by (subst mu_G_spec) auto
    then have "\<mu>G (Y n) \<noteq> \<infinity>" by auto
    note *
    moreover have "\<mu>G (Z n - Y n) =
        P (J n) (B n - (\<Inter>i\<in>{Suc 0..n}. prod_emb (J n) (\<lambda>_. borel) (J i) (K i)))"
      unfolding Z_def Y_emb prod_emb_Diff[symmetric] using J J_mono K_sets \<open>n \<ge> 1\<close>
      by (subst mu_G_spec) (auto intro!: sets.Diff)
    ultimately
    have "\<mu>G (Z n) - \<mu>G (Y n) = \<mu>G (Z n - Y n)"
      using J J_mono K_sets \<open>n \<ge> 1\<close>
      by (simp only: emeasure_eq_measure Z_def)
         (auto dest!: bspec[where x=n] intro!: measure_Diff[symmetric] set_mp[OF K_B]
               intro!: arg_cong[where f=ennreal]
               simp: extensional_restrict emeasure_eq_measure prod_emb_iff sets_P space_P
                     ennreal_minus measure_nonneg)
    also have subs: "Z n - Y n \<subseteq> (\<Union>i\<in>{1..n}. (Z i - Z' i))"
      using \<open>n \<ge> 1\<close> unfolding Y_def UN_extend_simps(7) by (intro UN_mono Diff_mono Z_mono order_refl) auto
    have "Z n - Y n \<in> generator" "(\<Union>i\<in>{1..n}. (Z i - Z' i)) \<in> generator"
      using \<open>Z' _ \<in> generator\<close> \<open>Z _ \<in> generator\<close> \<open>Y _ \<in> generator\<close> by auto
    hence "\<mu>G (Z n - Y n) \<le> \<mu>G (\<Union>i\<in>{1..n}. (Z i - Z' i))"
      using subs generator.additive_increasing[OF positive_mu_G additive_mu_G]
      unfolding increasing_def by auto
    also have "\<dots> \<le> (\<Sum> i\<in>{1..n}. \<mu>G (Z i - Z' i))" using \<open>Z _ \<in> generator\<close> \<open>Z' _ \<in> generator\<close>
      by (intro generator.subadditive[OF positive_mu_G additive_mu_G]) auto
    also have "\<dots> \<le> (\<Sum> i\<in>{1..n}. 2 powr -real i * ?a)"
    proof (rule sum_mono)
      fix i assume "i \<in> {1..n}" hence "i \<le> n" by simp
      have "\<mu>G (Z i - Z' i) = \<mu>G (prod_emb I (\<lambda>_. borel) (J i) (B i - K i))"
        unfolding Z'_def Z_def by simp
      also have "\<dots> = P (J i) (B i - K i)"
        using J K_sets by (subst mu_G_spec) auto
      also have "\<dots> = P (J i) (B i) - P (J i) (K i)"
        using K_sets J \<open>K _ \<subseteq> B _\<close> by (simp add: emeasure_Diff)
      also have "\<dots> = P (J i) (B i) - P' i (K' i)"
        unfolding K_def P'_def
        by (auto simp: mapmeasure_PiF borel_eq_PiF_borel[symmetric]
          compact_imp_closed[OF \<open>compact (K' _)\<close>] space_PiM PiE_def)
      also have "\<dots> \<le> ennreal (2 powr - real i) * ?a" using K'(1)[of i] .
      finally show "\<mu>G (Z i - Z' i) \<le> (2 powr - real i) * ?a" .
    qed
    also have "\<dots> = ennreal ((\<Sum> i\<in>{1..n}. (2 powr -enn2real i)) * enn2real ?a)"
      using r by (simp add: sum_distrib_right ennreal_mult[symmetric])
    also have "\<dots> < ennreal (1 * enn2real ?a)"
    proof (intro ennreal_lessI mult_strict_right_mono)
      have "(\<Sum>i = 1..n. 2 powr - real i) = (\<Sum>i = 1..<Suc n. (1/2) ^ i)"
        by (rule sum.cong) (auto simp: powr_realpow powr_divide power_divide powr_minus_divide)
      also have "{1..<Suc n} = {..<Suc n} - {0}" by auto
      also have "sum (op ^ (1 / 2::real)) ({..<Suc n} - {0}) =
        sum (op ^ (1 / 2)) ({..<Suc n}) - 1" by (auto simp: sum_diff1)
      also have "\<dots> < 1" by (subst geometric_sum) auto
      finally show "(\<Sum>i = 1..n. 2 powr - enn2real i) < 1" by simp
    qed (auto simp: r enn2real_positive_iff)
    also have "\<dots> = ?a" by (auto simp: r)
    also have "\<dots> \<le> \<mu>G (Z n)"
      using J by (auto intro: INF_lower simp: Z_def mu_G_spec)
    finally have "\<mu>G (Z n) - \<mu>G (Y n) < \<mu>G (Z n)" .
    hence R: "\<mu>G (Z n) < \<mu>G (Z n) + \<mu>G (Y n)"
      using \<open>\<mu>G (Y n) \<noteq> \<infinity>\<close> by (auto simp: zero_less_iff_neq_zero)
    then have "\<mu>G (Y n) > 0"
      by simp
    thus "Y n \<noteq> {}" using positive_mu_G by (auto simp add: positive_def)
  qed
  hence "\<forall>n\<in>{1..}. \<exists>y. y \<in> Y n" by auto
  then obtain y where y: "\<And>n. n \<ge> 1 \<Longrightarrow> y n \<in> Y n" unfolding bchoice_iff by force
  {
    fix t and n m::nat
    assume "1 \<le> n" "n \<le> m" hence "1 \<le> m" by simp
    from Y_mono[OF \<open>m \<ge> n\<close>] y[OF \<open>1 \<le> m\<close>] have "y m \<in> Y n" by auto
    also have "\<dots> \<subseteq> Z' n" using Y_Z'[OF \<open>1 \<le> n\<close>] .
    finally
    have "fm n (restrict (y m) (J n)) \<in> K' n"
      unfolding Z'_def K_def prod_emb_iff by (simp add: Z'_def K_def prod_emb_iff)
    moreover have "finmap_of (J n) (restrict (y m) (J n)) = finmap_of (J n) (y m)"
      using J by (simp add: fm_def)
    ultimately have "fm n (y m) \<in> K' n" by simp
  } note fm_in_K' = this
  interpret finmap_seqs_into_compact "\<lambda>n. K' (Suc n)" "\<lambda>k. fm (Suc k) (y (Suc k))" borel
  proof
    fix n show "compact (K' n)" by fact
  next
    fix n
    from Y_mono[of n "Suc n"] y[of "Suc n"] have "y (Suc n) \<in> Y (Suc n)" by auto
    also have "\<dots> \<subseteq> Z' (Suc n)" using Y_Z' by auto
    finally
    have "fm (Suc n) (restrict (y (Suc n)) (J (Suc n))) \<in> K' (Suc n)"
      unfolding Z'_def K_def prod_emb_iff by (simp add: Z'_def K_def prod_emb_iff)
    thus "K' (Suc n) \<noteq> {}" by auto
    fix k
    assume "k \<in> K' (Suc n)"
    with K'[of "Suc n"] sets.sets_into_space have "k \<in> fm (Suc n) ` B (Suc n)" by auto
    then obtain b where "k = fm (Suc n) b" by auto
    thus "domain k = domain (fm (Suc n) (y (Suc n)))"
      by (simp_all add: fm_def)
  next
    fix t and n m::nat
    assume "n \<le> m" hence "Suc n \<le> Suc m" by simp
    assume "t \<in> domain (fm (Suc n) (y (Suc n)))"
    then obtain j where j: "t = Utn j" "j \<in> J (Suc n)" by auto
    hence "j \<in> J (Suc m)" using J_mono[OF \<open>Suc n \<le> Suc m\<close>] by auto
    have img: "fm (Suc n) (y (Suc m)) \<in> K' (Suc n)" using \<open>n \<le> m\<close>
      by (intro fm_in_K') simp_all
    show "(fm (Suc m) (y (Suc m)))\<^sub>F t \<in> (\<lambda>k. (k)\<^sub>F t) ` K' (Suc n)"
      apply (rule image_eqI[OF _ img])
      using \<open>j \<in> J (Suc n)\<close> \<open>j \<in> J (Suc m)\<close>
      unfolding j by (subst proj_fm, auto)+
  qed
  have "\<forall>t. \<exists>z. (\<lambda>i. (fm (Suc (diagseq i)) (y (Suc (diagseq i))))\<^sub>F t) \<longlonglongrightarrow> z"
    using diagonal_tendsto ..
  then obtain z where z:
    "\<And>t. (\<lambda>i. (fm (Suc (diagseq i)) (y (Suc (diagseq i))))\<^sub>F t) \<longlonglongrightarrow> z t"
    unfolding choice_iff by blast
  {
    fix n :: nat assume "n \<ge> 1"
    have "\<And>i. domain (fm n (y (Suc (diagseq i)))) = domain (finmap_of (Utn ` J n) z)"
      by simp
    moreover
    {
      fix t
      assume t: "t \<in> domain (finmap_of (Utn ` J n) z)"
      hence "t \<in> Utn ` J n" by simp
      then obtain j where j: "t = Utn j" "j \<in> J n" by auto
      have "(\<lambda>i. (fm n (y (Suc (diagseq i))))\<^sub>F t) \<longlonglongrightarrow> z t"
        apply (subst (2) tendsto_iff, subst eventually_sequentially)
      proof safe
        fix e :: real assume "0 < e"
        { fix i and x :: "'i \<Rightarrow> 'a" assume i: "i \<ge> n"
          assume "t \<in> domain (fm n x)"
          hence "t \<in> domain (fm i x)" using J_mono[OF \<open>i \<ge> n\<close>] by auto
          with i have "(fm i x)\<^sub>F t = (fm n x)\<^sub>F t"
            using j by (auto simp: proj_fm dest!: inj_onD[OF inj_on_Utn])
        } note index_shift = this
        have I: "\<And>i. i \<ge> n \<Longrightarrow> Suc (diagseq i) \<ge> n"
          apply (rule le_SucI)
          apply (rule order_trans) apply simp
          apply (rule seq_suble[OF subseq_diagseq])
          done
        from z
        have "\<exists>N. \<forall>i\<ge>N. dist ((fm (Suc (diagseq i)) (y (Suc (diagseq i))))\<^sub>F t) (z t) < e"
          unfolding tendsto_iff eventually_sequentially using \<open>0 < e\<close> by auto
        then obtain N where N: "\<And>i. i \<ge> N \<Longrightarrow>
          dist ((fm (Suc (diagseq i)) (y (Suc (diagseq i))))\<^sub>F t) (z t) < e" by auto
        show "\<exists>N. \<forall>na\<ge>N. dist ((fm n (y (Suc (diagseq na))))\<^sub>F t) (z t) < e "
        proof (rule exI[where x="max N n"], safe)
          fix na assume "max N n \<le> na"
          hence  "dist ((fm n (y (Suc (diagseq na))))\<^sub>F t) (z t) =
                  dist ((fm (Suc (diagseq na)) (y (Suc (diagseq na))))\<^sub>F t) (z t)" using t
            by (subst index_shift[OF I]) auto
          also have "\<dots> < e" using \<open>max N n \<le> na\<close> by (intro N) simp
          finally show "dist ((fm n (y (Suc (diagseq na))))\<^sub>F t) (z t) < e" .
        qed
      qed
      hence "(\<lambda>i. (fm n (y (Suc (diagseq i))))\<^sub>F t) \<longlonglongrightarrow> (finmap_of (Utn ` J n) z)\<^sub>F t"
        by (simp add: tendsto_intros)
    } ultimately
    have "(\<lambda>i. fm n (y (Suc (diagseq i)))) \<longlonglongrightarrow> finmap_of (Utn ` J n) z"
      by (rule tendsto_finmap)
    hence "((\<lambda>i. fm n (y (Suc (diagseq i)))) o (\<lambda>i. i + n)) \<longlonglongrightarrow> finmap_of (Utn ` J n) z"
      by (rule LIMSEQ_subseq_LIMSEQ) (simp add: subseq_def)
    moreover
    have "(\<forall>i. ((\<lambda>i. fm n (y (Suc (diagseq i)))) o (\<lambda>i. i + n)) i \<in> K' n)"
      apply (auto simp add: o_def intro!: fm_in_K' \<open>1 \<le> n\<close> le_SucI)
      apply (rule le_trans)
      apply (rule le_add2)
      using seq_suble[OF subseq_diagseq]
      apply auto
      done
    moreover
    from \<open>compact (K' n)\<close> have "closed (K' n)" by (rule compact_imp_closed)
    ultimately
    have "finmap_of (Utn ` J n) z \<in> K' n"
      unfolding closed_sequential_limits by blast
    also have "finmap_of (Utn ` J n) z  = fm n (\<lambda>i. z (Utn i))"
      unfolding finmap_eq_iff
    proof clarsimp
      fix i assume i: "i \<in> J n"
      hence "from_nat_into (\<Union>n. J n) (Utn i) = i"
        unfolding Utn_def
        by (subst from_nat_into_to_nat_on[OF countable_UN_J]) auto
      with i show "z (Utn i) = (fm n (\<lambda>i. z (Utn i)))\<^sub>F (Utn i)"
        by (simp add: finmap_eq_iff fm_def compose_def)
    qed
    finally have "fm n (\<lambda>i. z (Utn i)) \<in> K' n" .
    moreover
    let ?J = "\<Union>n. J n"
    have "(?J \<inter> J n) = J n" by auto
    ultimately have "restrict (\<lambda>i. z (Utn i)) (?J \<inter> J n) \<in> K n"
      unfolding K_def by (auto simp: space_P space_PiM)
    hence "restrict (\<lambda>i. z (Utn i)) ?J \<in> Z' n" unfolding Z'_def
      using J by (auto simp: prod_emb_def PiE_def extensional_def)
    also have "\<dots> \<subseteq> Z n" using Z' by simp
    finally have "restrict (\<lambda>i. z (Utn i)) ?J \<in> Z n" .
  } note in_Z = this
  hence "(\<Inter>i\<in>{1..}. Z i) \<noteq> {}" by auto
  thus "(\<Inter>i. Z i) \<noteq> {}"
    using INT_decseq_offset[OF antimonoI[OF Z_mono]] by simp
qed fact+

lemma measure_lim_emb:
  "J \<subseteq> I \<Longrightarrow> finite J \<Longrightarrow> X \<in> sets (\<Pi>\<^sub>M i\<in>J. borel) \<Longrightarrow> measure lim (emb I J X) = measure (P J) X"
  unfolding measure_def by (subst emeasure_lim_emb) auto

end

hide_const (open) PiF
hide_const (open) Pi\<^sub>F
hide_const (open) Pi'
hide_const (open) finmap_of
hide_const (open) proj
hide_const (open) domain
hide_const (open) basis_finmap

sublocale polish_projective \<subseteq> P: prob_space lim
proof
  have *: "emb I {} {\<lambda>x. undefined} = space (\<Pi>\<^sub>M i\<in>I. borel)"
    by (auto simp: prod_emb_def space_PiM)
  interpret prob_space "P {}"
    using prob_space_P by simp
  show "emeasure lim (space lim) = 1"
    using emeasure_lim_emb[of "{}" "{\<lambda>x. undefined}"] emeasure_space_1
    by (simp add: * PiM_empty space_P)
qed

locale polish_product_prob_space =
  product_prob_space "\<lambda>_. borel::('a::polish_space) measure" I for I::"'i set"

sublocale polish_product_prob_space \<subseteq> P: polish_projective I "\<lambda>J. PiM J (\<lambda>_. borel::('a) measure)"
  ..

lemma (in polish_product_prob_space) limP_eq_PiM: "lim = PiM I (\<lambda>_. borel)"
  by (rule PiM_eq) (auto simp: emeasure_PiM emeasure_lim_emb)

end