\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>Approximations\<close>
theory Approximations
imports Chain
begin

paragraph \<open>Summary\<close>
text \<open>This theory contains many approximations of terms involving flows, inflows, outflows,
capacities,... These approximations will be used to prove that terms are not 0 by relating
them to smaller terms that are known to be greater than 0.\<close>

paragraph \<open>Major Definitions\<close>
text \<open>
-@{term segment_fg}: analogous definition to segment to describe path segments of convoluted
  paths in flow graphs
- @{term len_segment_fg}: extends@{term segment_fg} by imposing an upper bound on the path segments
- @{term alt_cap_fg}: capacity function to be used along convoluted paths
- @{term alt_cap_hd_fg}: same as @{term alt_cap_fg} but determines current subgraph based on head instead of subset
  relation\<close>

abbreviation "segment_fg h ys \<equiv> set ys \<subseteq> dom_fg h \<and> ys \<noteq> []"
abbreviation "len_segment_fg h ys \<equiv> set ys \<subseteq> dom_fg h \<and> ys \<noteq> [] \<and> length ys \<le> card (dom_fg h)"
abbreviation "alt_cap_fg h1 h2 xs y \<equiv> (
  if set xs \<subseteq> dom_fg h1 then cap_fg h1 (hd (xs @ [y])) y else
  if set xs \<subseteq> dom_fg h2 then cap_fg h2 (hd (xs @ [y])) y else
  0)"
abbreviation "alt_cap_hd_fg h1 h2 x y \<equiv> (
  if x \<in> dom_fg h1 then cap_fg h1 x y else
  if x \<in> dom_fg h2 then cap_fg h2 x y else
  0)"

lemma alt_cap_hd_sym: "dom_fg h1 \<inter> dom_fg h2 = {} \<Longrightarrow> alt_cap_hd_fg h1 h2 x y = alt_cap_hd_fg h2 h1 x y"
  by auto

lemma alt_cap_hd_fg_sym':
  shows "dom_fg h1 \<inter> dom_fg h2 = {} \<Longrightarrow> alt_cap_hd_fg h1 h2 = alt_cap_hd_fg h2 h1"
  by (intro ext, auto)

section \<open>Unrolling the flow equation\<close>

text \<open>@{cite \<open>lem. 6\<close> krishna19b}: expand the flow equation into sums over finitely many paths.
  Later we will be able to prove that the second big-sum (the one involving flow f) is 0 in certain
  contexts, therefore, we will be able to straight-forwardly calculate the flow given a graph and
  inflow (because this representation of the flow equation then is no longer recursively defined!).\<close>

lemma unroll_flow_eq:
  assumes "l \<ge> 1" "flow_eq2' N e f i" "\<forall>x y. e x y \<in> E" "End_closed E" "n \<in> N" "finite N"
    "(\<lambda>_. 0) \<in> E"
  shows "f n = i n + (\<Sum>ns \<in> l_lists N l. (chain e ns n) (i (hd ns)))
                   + (\<Sum>ns \<in> k_lists N l. (chain e ns n) (f (hd ns)))"
  using assms
proof (induction l rule: nat_induct_at_least)
  case base
  have "l_lists N (Suc 0) = {}" unfolding l_lists_def by auto
  moreover have "k_lists N (Suc 0) = {[l] | l. l \<in> N}" unfolding k_lists_def
  proof (standard,goal_cases)
    case 1
    then show ?case by (auto, case_tac x, auto)
  next
    case 2 then show ?case by auto
  qed
  moreover have "f n = i n + (\<Sum>n'\<in>N. e n' n (f n'))"
    using base unfolding flow_eq2'_def flow_eq'_def by simp
  ultimately show ?case
    using base by (auto intro: sum.reindex_cong[symmetric,where l="\<lambda>x. [x]"] inj_onI)
next
  case (Suc l)
  have *: "(\<lambda>n. i n + (\<Sum>n'\<in>N. e n' n (f n'))) = f on N"
    using Suc unfolding flow_eq2'_def flow_eq'_def by simp

  have **: "(\<Sum>ns\<in>k_lists N l. chain e ns n (f (hd ns))) =
            (\<Sum>ns\<in>k_lists N l. chain e ns n (i (hd ns) + (\<Sum>n'\<in>N. e n' (hd ns) (f n'))))"
    unfolding k_lists_def
    using * Suc
    by (auto simp: set_hd_in)

  have ***: "(\<Sum>ns\<in>k_lists N l. chain e ns n (i (hd ns)   + (\<Sum>n'\<in>N. e n' (hd ns) (f n')))) =
             (\<Sum>ns\<in>k_lists N l. chain e ns n (i (hd ns))) + (\<Sum>ns\<in>k_lists N l. chain e ns n (\<Sum>n'\<in>N. e n' (hd ns) (f n')))"
  proof -
    have "(\<Sum>ns\<in>k_lists N l. chain e ns n (i (hd ns) + (\<Sum>n'\<in>N. e n' (hd ns) (f n')))) =
          (\<Sum>ns\<in>k_lists N l. chain e ns n (i (hd ns)) + chain e ns n (\<Sum>n'\<in>N. e n' (hd ns) (f n')))"
      apply (rule sum.cong[OF _ endo_sum_closed], simp)
      apply (rule endo_chain_closed_nonempty)
      using Suc unfolding k_lists_def by (auto simp add: id_def)
    then show ?thesis
      by (simp add: sum.distrib)
  qed

  have "f n = i n + (\<Sum>ns\<in>l_lists N l. chain e ns n (i (hd ns)))
                          + (\<Sum>ns\<in>k_lists N l. chain e ns n (f (hd ns)))"
    using Suc by simp
  also have "... = i n + (\<Sum>ns\<in>l_lists N l. chain e ns n (i (hd ns)))
                       + (\<Sum>ns\<in>k_lists N l. chain e ns n (i (hd ns)))
                       + (\<Sum>ns\<in>k_lists N l. chain e ns n (\<Sum>n'\<in>N. e n' (hd ns) (f n')))"
    using ** *** by (simp add: algebra_simps)
  also have "... = i n + (\<Sum>ns\<in>l_lists N (Suc l). chain e ns n (i (hd ns)))
                       + (\<Sum>ns\<in>k_lists N l. chain e ns n (\<Sum>n'\<in>N. e n' (hd ns) (f n')))"
    using l_lists_k_lists_union[of l N] sum.union_disjoint[symmetric, of "l_lists N l" _
          "\<lambda>ns. chain e ns n (i (hd ns))"] l_lists_k_lists_disjoint[of l N]
          Suc l_lists_finite[of N l] k_lists_finite[of N l]
    by (auto simp: algebra_simps)
  also have "... = i n + (\<Sum>ns\<in>l_lists N (Suc l). chain e ns n (i (hd ns)))
                       + (\<Sum>ns\<in>k_lists N l. \<Sum>n'\<in>N. chain e ns n (e n' (hd ns) (f n')))"
    apply (simp, rule sum.cong, simp)
    using assms
    apply (auto elim!: endo_iterated_sum_closed[where E=E]
           intro!: endo_chain_closed_nonempty simp: k_lists_def)
    using Suc.hyps not_one_le_zero by blast
  also have "... = i n + (\<Sum>ns\<in>l_lists N (Suc l). chain e ns n (i (hd ns)))
                       + (\<Sum>ns\<in>k_lists N l. \<Sum>n'\<in>N. chain e (n'#ns) n (f n'))"
    apply (simp, rule sum.cong, simp, rule sum.cong, simp)
    subgoal for ns n
      using Suc apply (cases ns, auto) using k_lists_nonempty[of l ns N] by simp
    done
  also have "... = i n + (\<Sum>ns\<in>l_lists N (Suc l). chain e ns n (i (hd ns)))
                       + (\<Sum>(ns,n')\<in>k_lists N l \<times> N. chain e (n'#ns) n (f n'))"
    by (auto simp: sum.cartesian_product)
  also have "... = i n + (\<Sum>ns\<in>l_lists N (Suc l). chain e ns n (i (hd ns)))
                       + (\<Sum>ns\<in>k_lists N (Suc l). chain e ns n (f (hd ns)))"
    using k_lists_x_Suc[of l N] Suc
    apply (auto split: prod.splits)
    apply (rule sum.reindex_cong[symmetric, of "\<lambda>(ns,n). n#ns"])
      apply (auto intro: inj_onI)
    subgoal for ns
  proof -
    assume "ns \<in> k_lists N (Suc l)"
    then have *: "length (tl ns) = l" "hd ns \<in> N" "set (tl ns) \<subseteq> N" "ns \<noteq> []"
      unfolding k_lists_def apply (auto simp: set_hd_in)
      by (metis Suc.hyps \<open>ns \<in> k_lists N (Suc l)\<close> k_lists_nonempty(2) le_SucI list.set_sel subsetD)
    then have "tl ns \<in> k_lists N l" unfolding k_lists_def by simp
    then have "(hd ns)#(tl ns) \<in> (\<lambda>x. case x of (ns, n) \<Rightarrow> n # ns) ` (k_lists N l \<times> N)"
      using *(2) by auto
    then show "ns \<in> (\<lambda>x. case x of (ns, n) \<Rightarrow> n # ns) ` (k_lists N l \<times> N)"
      using *(4) by simp
  qed
  done
  finally show ?case .
qed

text \<open>Adapter lemma to @{thm unroll_flow_eq} for @{const flow_eq} of @{const flow_eq2'}\<close>

lemma unroll_flow_eq':
  assumes "l \<ge> 1" "flow_eq (fg N e f) i" "\<forall>x y. e x y \<in> E"
    "End_closed E" "n \<in> N" "finite N" "(\<lambda>_. 0) \<in> E"
  shows "f n = i n + (\<Sum>ns \<in> l_lists N l. (chain e ns n) (i (hd ns)))
                   + (\<Sum>ns \<in> k_lists N l. (chain e ns n) (f (hd ns)))"
  using assms
  apply transfer
  apply (auto split: if_splits)
  apply (rule unroll_flow_eq)
  by (auto simp: flow_eq2'_def)

section \<open>Simple Approximations between Nodes\<close>

text \<open>For each node its inflow is less equal its flow.\<close>

lemma inf_fg_le_flow_fg:
  fixes h :: "('n,'m :: pos_cancel_comm_monoid_add) fg"
  assumes "h \<noteq> bot" "n \<in> dom_fg h"
  shows "inf_fg h n \<le> flow_fg h n"
proof -
  have "flow_fg h n = inf_fg h n + (\<Sum>n'\<in>dom_fg h. edge_fg h n' n (flow_fg h n'))"
    using flow_eq_ne_bot[of h] assms by simp
  then show ?thesis
    using le_iff_add by blast
qed

text \<open>The inflow to a subgraph is greater equal the inflow to its supergraph (because it
additionally receives inflow from its sibling subgraphs when considered on its own)\<close>

lemma inf_fg_le_inf_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h1 + h2 \<noteq> bot" "x \<in> dom_fg h1" "\<forall>x y. edge_fg h1 x y \<in> E"
  shows "inf_fg (h1 + h2) x \<le> inf_fg h1 x"
proof -
  have "inf_fg h1 x = inf_fg (h1 + h2) x + outf_fg h2 x"
    using flow_eq_to_sum[of h1 h2] assms by simp
  then show ?thesis
    by (simp add: le_iff_add)
qed

text \<open>Same as @{thm inf_fg_le_inf_fg} but for second summand.\<close>

lemma inf_fg_le_inf_fg2:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h1 + h2 \<noteq> bot" "x \<in> dom_fg h2" "\<forall>x y. edge_fg h2 x y \<in> E"
  shows "inf_fg (h1 + h2) x \<le> inf_fg h2 x"
  using inf_fg_le_inf_fg[of h2 h1 x E] assms by (simp add: algebra_simps)

text \<open>The flow to outside nodes along single edges is less equal the total outflow.\<close>

lemma edge_fg_flow_fg_le_outf_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "x \<in> dom_fg h" "y \<in> -dom_fg h" "\<forall>x y. edge_fg h x y \<in> E"
  shows "edge_fg h x y (flow_fg h x) \<le> outf_fg h y"
proof -
  have "edge_fg h x y (flow_fg h x) \<le> (\<Sum>n'\<in>dom_fg h. edge_fg h n' y (flow_fg h n'))"
    apply (rule sum_insert_pos_monoid) using assms by auto
  also have "... = outf_fg h y"
    apply (rule outf_fg_unfold[symmetric])
    using assms by auto
  finally show ?thesis .
qed

text \<open>The outflow from h1 to a node in h2  is less equal h2's inflow to that node\<close>

lemma outf_fg_le_inf_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "h = h1 + h2" "x \<in> dom_fg h2" "\<forall>x y. edge_fg h1 x y \<in> E"
  shows "outf_fg h1 x \<le> inf_fg h2 x"
proof -
  have "inf_fg h2 x = inf_fg h x + outf_fg h1 x"
    by (metis add.commute assms flow_eq_to_sum)
  then show ?thesis
    by (simp add: add_increasing)
qed

section \<open>Approximations of Chains\<close>

text \<open>chain2 can be approximated by capacities that contain the chain.\<close>

lemma chain2_le_cap'':
  fixes E :: "('b \<Rightarrow> 'b :: pos_cancel_comm_monoid_add) set"
  assumes "set xs \<subseteq> N" "length xs < k" "x \<in> N" "finite N" "\<forall>x y. e x y \<in> E" "End_closed E"
  shows "chain2 e x xs y z \<le> cap' k N e x y z"
proof -
  have "cap' k N e x y z = \<delta> x y z + (\<Sum>ns\<in>l_lists' N k. chain2 e x ns y) z"
    using cap'_unrolled_closed[of e E N x k y] assms by simp
  then have **: "cap' k N e x y z = \<delta> x y z + (\<Sum>ns\<in>l_lists' N k. chain2 e x ns y z)"
    by (subst (asm) plus_fun_apply_iterated[OF l_lists'_finite[OF \<open>finite N\<close>]], simp)
  have *: "xs \<in> l_lists' N k"
    using assms unfolding l_lists'_def by simp
  have "chain2 e x xs y z \<le> (\<Sum>ns\<in>l_lists' N k. chain2 e x ns y z)"
    by (fact sum_insert_pos_monoid[OF l_lists'_finite[OF \<open>finite N\<close>] *])
  also have "... \<le> \<delta> x y z + (\<Sum>ns\<in>l_lists' N k. chain2 e x ns y z)"
    by (simp add: add_increasing)
  finally show ?thesis
    using ** unfolding plus_fun_def by simp
qed

text \<open>chain can be approximated by capacities that contain the chain.\<close>

lemma chain_le_cap':
  fixes e :: "'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b :: pos_cancel_comm_monoid_add"
  assumes "set xs \<subseteq> N" "xs \<noteq> []" "length xs \<le> k" "finite N" "\<forall>x y. e x y \<in> E" "x \<le> x'"
    "End_closed E" "(\<lambda>_. 0) \<in> E" "id \<in> E"
  shows "chain e xs y x \<le> cap' k N e (hd (xs @ [y])) y x'"
proof -
  have "chain e xs y x = chain2 e (hd xs) (tl xs) y x"
    using chain_chain2 assms by metis
  also have "... \<le> cap' k N e (hd xs) y x"
    apply (rule chain2_le_cap''[of "tl xs" N k "hd xs" e E y x])
    using assms apply simp_all
      apply (simp add: list.set_sel(2) subset_iff)
     apply (metis diff_Suc_less le_neq_implies_less length_greater_0_conv less_imp_diff_less)
    by auto
  also have "... \<le> cap' k N e (hd xs) y x'"
    apply (rule pos_endo_mono'_closed[OF \<open>x \<le> x'\<close>])
    using assms by (auto elim: endo_cap')
  finally show ?thesis
    using assms by simp
qed

lemma chain_flow_fg_le_flow_fg:
  fixes E :: "('m \<Rightarrow> 'm :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "End_closed E" "\<forall>x y. edge_fg h x y \<in> E" "y \<in> dom_fg h" "set xs \<subseteq> dom_fg h"
    "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "chain (edge_fg h) xs y (flow_fg h (hd (xs @ [y]))) \<le> flow_fg h y"
proof (cases xs)
case Nil
  then show ?thesis by simp
next
  case (Cons a xs)
  then have *: "flow_fg h y =
    inf_fg h y + (\<Sum>ns\<in>l_lists (dom_fg h) (length (a # xs)). chain (edge_fg h) ns y (inf_fg h (hd ns)))
               + (\<Sum>ns\<in>k_lists (dom_fg h) (length (a # xs)). chain (edge_fg h) ns y (flow_fg h (hd ns)))"
    using unroll_flow_eq[of "length (a # xs)" "dom_fg h" "edge_fg h" "flow_fg h" "inf_fg h" E y] assms
      nbot_fg_to_flow_eq2'[of h] by simp
  have "chain (edge_fg h) (a # xs) y (flow_fg h (hd (a # xs))) \<le> (\<Sum>ns\<in>k_lists (dom_fg h) (length (a # xs)). chain (edge_fg h) ns y (flow_fg h (hd ns)))"
    apply (rule sum_insert_pos_monoid[OF k_lists_finite[OF dom_fg_finite], of "a # xs" h "length (a # xs)"])
    using assms Cons unfolding k_lists_def
    by blast
  also have "... \<le> flow_fg h y"
    using * by (simp add: add_increasing)
  finally show ?thesis
    using Cons by simp
qed

lemma cap'_superset_iterations:
  fixes E :: "('b \<Rightarrow> 'b :: pos_cancel_comm_monoid_add) set"
  assumes "finite N'" "N \<subseteq> N'" "k \<le> k'" "End_closed E" "\<forall>x y. e x y \<in> E" "x \<in> N"
  shows "cap' k N e x y z \<le> cap' k' N' e x y z"
  using assms
proof (induction N' rule: finite_induct)
  case empty
  then show ?case by simp
next
  case (insert a F)
  have fin: "finite N"
    using assms finite_subset by blast
  have fin2: "finite (insert a F)"
    using insert by simp

  have "cap' k N e x y z = (\<delta> x y + (\<Sum>ns \<in> l_lists' N k. chain2 e x ns y)) z"
    apply (subst cap'_unrolled_closed) using assms fin by auto
  also have "... = \<delta> x y z + (\<Sum>ns \<in> l_lists' N k. chain2 e x ns y) z"
    by simp
  also have "... = \<delta> x y z + (\<Sum>ns \<in> l_lists' N k. chain2 e x ns y z)"
    by (subst plus_fun_apply_iterated[OF l_lists'_finite[OF fin]], simp)
  also have "... \<le> \<delta> x y z + (\<Sum>ns \<in> l_lists' (insert a F) k'. chain2 e x ns y z)"
    by (rule add_left_mono[OF sum_mono2[OF l_lists'_finite[OF fin2] l_lists'_mono[OF \<open>N \<subseteq> insert a F\<close> \<open>k \<le> k'\<close>]]], simp)
  also have "... = \<delta> x y z + (\<Sum>ns \<in> l_lists' (insert a F) k'. chain2 e x ns y) z"
    using plus_fun_apply_iterated[OF l_lists'_finite[OF fin2]] by metis
  also have "... = cap' k' (insert a F) e x y z"
    apply (subst cap'_unrolled_closed) using insert fin2 by auto
  finally show ?case by simp
qed

lemma cap_superset:
  fixes E :: "('b \<Rightarrow> 'b :: pos_cancel_comm_monoid_add) set"
  assumes "finite N'" "N \<subseteq> N'" "k \<le> k'" "End_closed E" "\<forall>x y. e x y \<in> E" "x \<in> N"
  shows "cap N e x y \<le> cap N' e x y"
  using assms
  by (meson cap'_superset_iterations card_mono le_funI)

lemma alternating_chains'_mono:
  assumes "alternating P Q xss"
      "\<And>xs y x x'. P xs \<Longrightarrow> x \<le> x' \<Longrightarrow> f xs y x \<le> g xs y x'"
      "\<And>xs y x x'. Q xs \<Longrightarrow> x \<le> x' \<Longrightarrow> f xs y x \<le> g xs y x'" "u \<le> v"
  shows "chains' f xss y u \<le> chains' g xss y v"
  using assms
proof (induction xss arbitrary: P Q f g u v)
  case Nil
  then show ?case by simp
next
  case (Cons xs xss)
  then show ?case
    by (cases xss, auto)
qed

lemma chain_inf_fg_le_flow_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "End_closed E" "\<forall>x y. edge_fg h x y \<in> E"
    "set xs \<subseteq> dom_fg h" "y \<in> dom_fg h" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "chain (edge_fg h) xs y (inf_fg h (hd (xs @ [y]))) \<le> flow_fg h y"
proof (cases "length xs \<ge> 1")
  case True
  have kl: "xs \<in> k_lists (dom_fg h) (length xs)"
    unfolding k_lists_def using assms by simp

  have *: "flow_eq2' (dom_fg h) (edge_fg h) (flow_fg h) (inf_fg h)"
    using \<open>h \<noteq> bot\<close> nbot_fg_to_flow_eq2' by metis

  let ?f = "\<Sum>ns\<in>l_lists (dom_fg h) (length xs). chain (edge_fg h) ns y (inf_fg h (hd ns))"
  let ?g = "\<Sum>ns\<in>k_lists (dom_fg h) (length xs). chain (edge_fg h) ns y (flow_fg h (hd ns))"

  have flw: "flow_fg h y = inf_fg h y + ?f + ?g"
    apply (rule unroll_flow_eq[of "length xs" "dom_fg h" "edge_fg h" "flow_fg h" "inf_fg h" E y])
    using assms * True by auto

  have "chain (edge_fg h) xs y (inf_fg h (hd (xs @ [y]))) \<le> chain (edge_fg h) xs y (flow_fg h (hd (xs @ [y])))"
    apply (rule chain_mono[OF inf_fg_le_flow_fg]) using assms by (simp_all add: set_hd_in)
  also have "... \<le> (\<Sum>ns\<in>k_lists (dom_fg h) (length xs). chain (edge_fg h) ns y (flow_fg h (hd (ns @ [y]))))"
    by (fact sum_insert_pos_monoid[OF k_lists_finite[OF dom_fg_finite] kl])
  also have "... = ?g"
    apply (rule sum.cong, simp)
    using assms True unfolding k_lists_def
    by (auto simp: hd_append assms)
  also have "... \<le> (inf_fg h y + ?f) + ?g"
    by (simp add: add_increasing)
  finally show ?thesis
    using flw by simp
next
  case False
  then have "xs = []" by (metis One_nat_def Suc_leI length_greater_0_conv)
  then show ?thesis using inf_fg_le_flow_fg assms by simp
qed

lemma chain_inf_fg_le_flow_fg':
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "End_closed E" "\<forall>x y. edge_fg h x y \<in> E" "y \<in> dom_fg h" "k \<ge> 1" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "inf_fg h y + (\<Sum>xs \<in> l_lists (dom_fg h) k. chain (edge_fg h) xs y (inf_fg h (hd (xs @ [y])))) \<le> flow_fg h y"
proof -
  have *: "flow_eq2' (dom_fg h) (edge_fg h) (flow_fg h) (inf_fg h)"
    using \<open>h \<noteq> bot\<close> nbot_fg_to_flow_eq2' by metis

  let ?f = "\<Sum>ns\<in>l_lists (dom_fg h) k. chain (edge_fg h) ns y (inf_fg h (hd ns))"
  let ?f' = "\<Sum>ns\<in>l_lists (dom_fg h) k. chain (edge_fg h) ns y (inf_fg h (hd (ns @ [y])))"
  let ?g = "\<Sum>ns\<in>k_lists (dom_fg h) k. chain (edge_fg h) ns y (flow_fg h (hd ns))"
  let ?h = "inf_fg h y"

  have flw: "flow_fg h y = ?h + ?f + ?g"
    apply (rule unroll_flow_eq[of k "dom_fg h" "edge_fg h" "flow_fg h" "inf_fg h" E y])
    using assms * by auto

  have "?h + ?f' = ?h + ?f"
    apply (subst sum.cong, simp)
    using assms unfolding l_lists_def
    by (auto simp: hd_append assms)
  also have "...\<le> ?h + ?f + ?g"
    using le_iff_add by blast
  finally show ?thesis
    using flw by auto
qed

lemma chain_inf_fg_le_inf_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "End_closed E" "\<forall>x y. edge_fg h1 x y \<in> E" "set xs \<subseteq> dom_fg h1"
    "y \<in> dom_fg h2" "h = h1 + h2" "xs \<noteq> []" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "chain (edge_fg h1) xs y (inf_fg h1 (hd (xs @ [y]))) \<le> inf_fg h2 y"
  using assms
proof (induction xs rule: induct_list012) (* cases actually... *)
  case 1
  then show ?case by simp
next
  case (2 x)
  have "edge_fg h1 x y (inf_fg h1 x) \<le> edge_fg h1 x y (flow_fg h1 x)"
    apply (rule pos_endo_mono'_closed[OF inf_fg_le_flow_fg, where E=E]) using 2 by auto
  also have "... \<le> outf_fg h1 y"
    apply (rule edge_fg_flow_fg_le_outf_fg) using assms 2 apply auto
    by (simp_all add: dom_fg_plus_fg_iff)
  also have "... \<le> inf_fg h2 y"
    apply (rule outf_fg_le_inf_fg) using assms 2 by auto
  finally show ?case by simp
next
  case (3 x y' zs)

  let ?xs = "x # y' # zs"
  let ?e1 = "edge_fg h1"
  let ?i1 = "inf_fg h1"
  let ?f1 = "flow_fg h1"

  have "chain ?e1 ?xs y (?i1 (hd (butlast ?xs @ [last ?xs]))) = ?e1 (last ?xs) y (chain ?e1 (butlast ?xs) (last ?xs) (?i1 (hd ((butlast ?xs) @ [last ?xs]))))"
    by (rule chain_append1, simp)
  also have "... \<le> ?e1 (last ?xs) y (?f1 (last ?xs))"
    apply (rule pos_endo_mono'_closed[OF chain_inf_fg_le_flow_fg, of h1 E "butlast ?xs" "last ?xs" "?e1 (last ?xs) y" E])
    using 3 unfolding id_def by (auto, simp add: in_set_butlastD subset_code(1))
  also have "... \<le> outf_fg h1 y"
    apply (rule edge_fg_flow_fg_le_outf_fg) using assms 3 apply auto
    by (simp_all add: dom_fg_plus_fg_iff)
  also have "... \<le> inf_fg h2 y"
    apply (rule outf_fg_le_inf_fg) using assms 3 by auto
  finally show ?case
    by simp
qed

lemma cap'_unrolled_closed':
  assumes "finite N" "x \<in> N" "End_closed E" "\<forall>x y. e x y \<in> E" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "cap' k N e x y = \<delta> x y + (\<Sum>ns \<in> l_lists' N k. chain e (x # ns) y)"
proof -
  have "cap' k N e x y = \<delta> x y + (\<Sum>ns\<in>l_lists' N k. chain2 e x ns y)"
    using cap'_unrolled_closed[of e E N x k y] assms
    unfolding \<delta>_def
    by auto
  then show ?thesis
    by (simp, subst sum.cong[OF _ chain2_chain'], simp_all)
qed

lemma Cons_l_lists'_le_l_lists: "x \<in> N \<Longrightarrow> (Cons x) ` l_lists' N k \<subseteq> l_lists N (k + 1)"
  unfolding l_lists_def l_lists'_def image_def
  by auto

lemma cap'_inf_le_flow_eq:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "flow_eq2' N e f i" "\<forall>x y. e x y \<in> E" "End_closed E" "k \<ge> 1" "finite N" "x \<in> N" "y \<in> N"
    "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "cap' k N e x y (i x) \<le> f y"
proof -
  have S: "f y = i y + (\<Sum>ns\<in>l_lists N (k + 1). chain e ns y (i (hd ns))) + (\<Sum>ns\<in>k_lists N (k + 1). chain e ns y (f (hd ns)))"
    using unroll_flow_eq[of "k + 1" N e f i E y] assms by simp

  have "cap' k N e x y (i x) = \<delta> x y (i x) + (\<Sum>ns\<in>l_lists' N k. chain e (x # ns) y (i x))"
    using cap'_unrolled_closed'[of N x E e k y] assms
    unfolding \<delta>_def
    apply auto
    using plus_fun_apply_iterated[OF l_lists'_finite[where X=N and l=k]] by metis
  also have "... = \<delta> x y (i x) + (\<Sum>ns\<in>(Cons x) ` l_lists' N k. chain e ns y (i (hd ns)))"
    apply (simp, rule sum.reindex_cong[where l=tl])
    unfolding l_lists'_def
      apply (auto intro: inj_onI)
    unfolding image_def by fastforce
  also have "... \<le> i y + (\<Sum>ns\<in>(Cons x) ` l_lists' N k. chain e ns y (i (hd ns)))"
    unfolding \<delta>_def by (simp add: add_right_mono)
  also have "... \<le> i y + (\<Sum>ns\<in>l_lists N (k + 1). chain e ns y (i (hd ns)))"
    apply (rule add_left_mono[OF sum_mono2[OF l_lists_finite[OF \<open>finite N\<close>] Cons_l_lists'_le_l_lists]])
    using assms by auto
  also have "... \<le> f y"
    using S le_iff_add by blast
  finally show ?thesis .
qed

lemma cap'_inf_fg_le_flow_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "\<forall>x y. edge_fg h x y \<in> E" "End_closed E" "x \<in> dom_fg h"
    "y \<in> dom_fg h" "k \<ge> 1" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "cap' k (dom_fg h) (edge_fg h) x y (inf_fg h x) \<le> flow_fg h y"
proof -
  have T: "flow_eq2' (dom_fg h) (edge_fg h) (flow_fg h) (inf_fg h)"
    using assms nbot_fg_to_flow_eq2' by blast
  show ?thesis
    apply (rule cap'_inf_le_flow_eq[OF T, of E])
    using assms by simp_all
qed

lemma cap_fg_inf_fg_le_flow_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "\<forall>x y. edge_fg h x y \<in> E" "End_closed E" "x \<in> dom_fg h"
    "y \<in> dom_fg h" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "cap_fg h x y (inf_fg h x) \<le> flow_fg h y"
  apply (rule cap'_inf_fg_le_flow_fg[where E=E], simp_all add: assms)
  by (metis Suc_leI assms(5) card_gt_0_iff dom_fg_finite equals0D)

lemma l_lists_to_double_sum:
  assumes "finite X" "k \<ge> 1"
  shows "(\<Sum>xs \<in> l_lists X (k + 1). f xs) = (\<Sum>x \<in> X. f [x] + (\<Sum>xs \<in> l_lists X k. f (xs @ [x])))"
proof -
  have *: "l_lists {} (k + 1) = {}"
    unfolding l_lists_def by simp

  let ?X1 = "{ns @ [n] |ns n. (ns, n) \<in> l_lists X k \<times> X}"
  let ?X0 = "{[n'] |n'. n' \<in> X}"

  have eq: "?X1 = {n # ns | ns n. (ns, n) \<in> l_lists X k \<times> X}"
    unfolding l_lists_def
    apply auto
    subgoal for ns n
      apply (rule exI[where x="tl ns @ [n]"])
      apply (rule exI[where x="hd ns"])
      apply auto
        apply (metis Suc_le_lessD length_greater_0_conv list.exhaust_sel)
       apply (metis Suc_le_lessD in_mono length_greater_0_conv list.set_sel(2))
      by (simp add: set_hd_in)
    subgoal for ns n
      apply (rule exI[where x="butlast (n # ns)"])
      apply (rule exI[where x="last ns"])
      apply auto
      by (simp add: in_mono in_set_butlastD)
    done

  have "?X1 = (\<lambda>(xs,x). xs @ [x]) ` (l_lists X k \<times> X)"
    unfolding l_lists_def
    by auto
  then have F1: "finite ?X1"
    using finite_imageI[OF finite_cartesian_product[OF l_lists_finite[OF \<open>finite X\<close>, of k] \<open>finite X\<close>], of "\<lambda>(xs,x). xs @ [x]"]
    unfolding l_lists_def
    by simp
  have "?X0 = (\<lambda>x. [x]) ` X"
    by auto
  then have F0: "finite ?X0"
    using finite_imageI[OF \<open>finite X\<close>]
    by auto

  have "\<forall>xs \<in> ?X0. length xs = 1"
    by auto
  moreover have "\<forall>xs \<in> ?X1. length xs \<ge> 2"
    unfolding l_lists_def by auto
  ultimately have D: "?X1 \<inter> ?X0 = {}"
    by fastforce

  have "(\<Sum>xs \<in> l_lists X (k + 1). f xs) = (\<Sum>xs \<in> ?X1 \<union> ?X0. f xs)"
    using assms l_lists_x_Suc[of k X] eq by simp
  also have "... = (\<Sum> xs \<in> ?X1. f xs) + (\<Sum>xs \<in> ?X0. f xs)"
    by (rule sum.union_disjoint[OF F1 F0 D])
  also have "... = (\<Sum>(x,xs) \<in> X \<times> l_lists X k. f  (xs @ [x])) + (\<Sum>xs \<in> ?X0. f xs)"
    apply (subst sum.reindex_cong[where l="\<lambda>(x,xs). xs @ [x]" and B="X \<times> l_lists X k"])
    by (auto intro: inj_onI)
  also have "... = (\<Sum>x \<in> X. \<Sum>xs \<in> l_lists X k. f (xs @ [x])) + (\<Sum>xs \<in> ?X0. f xs)"
    by (subst sum.cartesian_product, simp)
  also have "... = (\<Sum>x \<in> X. \<Sum>xs \<in> l_lists X k. f (xs @ [x])) + (\<Sum>x \<in> X. f [x])"
    apply (subst sum.reindex_cong[where l="\<lambda>x. [x]" and A="?X0" and B=X])
    by (auto intro: inj_onI)
  also have "... = (\<Sum>x \<in> X. f [x] + (\<Sum>xs \<in> l_lists X k. f (xs @ [x])))"
    by (metis (no_types, lifting) add.commute sum.cong sum.distrib)
  finally show ?thesis .
qed

lemma cap_fg_inf_fg_le_outf_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "x \<in> dom_fg h" "y \<in> -dom_fg h" "End_closed E"
    "\<forall>x y. edge_fg h x y \<in> E" "dom_fg h \<noteq> {}" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "cap_fg h x y (inf_fg h x) \<le> outf_fg h y"
proof -
  have D1: "card (dom_fg h) \<ge> 1"
    using assms by (simp add: Suc_leI card_gt_0_iff)
  then obtain k where *[simp]: "k + 1 = card (dom_fg h)"
    using le_add_diff_inverse2 by blast

  have "cap_fg h x y (inf_fg h x) = (\<Sum>xs\<in>l_lists' (dom_fg h) (card (dom_fg h)). chain2 (edge_fg h) x xs y (inf_fg h x))"
    using cap_unrolled_closed[of "edge_fg h" E "dom_fg h" x y] assms plus_fun_apply_iterated[OF l_lists'_finite[OF dom_fg_finite]] *
    unfolding \<delta>_def
    by auto
  also have "... = (\<Sum>xs\<in>l_lists' (dom_fg h) (card (dom_fg h)). chain (edge_fg h) (x # xs) y (inf_fg h x))"
    by (subst sum.cong[OF _ chain2_chain], simp_all)
  also have "... = (\<Sum>xs\<in>Cons x ` l_lists' (dom_fg h) (card (dom_fg h)). chain (edge_fg h) xs y (inf_fg h (hd xs)))"
    apply (rule sum.reindex_cong[where l=tl])
    unfolding l_lists'_def
      apply (auto intro: inj_onI)
    unfolding image_def by fastforce
  also have "... \<le> (\<Sum>xs\<in>l_lists (dom_fg h) (card (dom_fg h) + 1). chain (edge_fg h) xs y (inf_fg h (hd xs)))"
    apply (rule sum_mono2[OF l_lists_finite[OF dom_fg_finite] Cons_l_lists'_le_l_lists])
    using assms by auto
  also have "... = (\<Sum>x \<in> dom_fg h. edge_fg h x y (inf_fg h x) + (\<Sum>xs \<in> l_lists (dom_fg h) (card (dom_fg h)). chain (edge_fg h) (xs @ [x]) y (inf_fg h (hd (xs @ [x])))))"
    by (subst l_lists_to_double_sum[OF dom_fg_finite D1], simp)
  also have "... = (\<Sum>x \<in> dom_fg h. edge_fg h x y (inf_fg h x) + (\<Sum>xs \<in> l_lists (dom_fg h) (card (dom_fg h)). edge_fg h x y (chain (edge_fg h) xs x (inf_fg h (hd (xs @ [x]))))))"
    by (metis (no_types, lifting) chain.simps(2) chain_append_nonempty hd_append2 impossible_Cons le_numeral_extra(3) list.sel(1) list.size(3) sum.cong)
  also have "... = (\<Sum>x \<in> dom_fg h. edge_fg h x y (inf_fg h x + (\<Sum>xs \<in> l_lists (dom_fg h) (card (dom_fg h)). chain (edge_fg h) xs x (inf_fg h (hd (xs @ [x]))))))"
    apply (rule sum.cong, simp)
    subgoal for x
      apply (subst fun_dist_right''[symmetric, OF l_lists_finite[OF dom_fg_finite], where g="edge_fg h x y" and E=E])
      using assms apply simp_all
      by (rule endo_sum_closed[symmetric, where E=E], simp_all add: assms)
    done
  also have "... \<le> (\<Sum>x \<in> dom_fg h. edge_fg h x y (flow_fg h x))"
    apply (rule sum_mono)
    subgoal for x
      apply (rule pos_endo_mono'_closed[OF chain_inf_fg_le_flow_fg'[of h E x "card (dom_fg h)"]])
      using assms D1 by auto
    done
  also have "... = outf_fg h y"
    apply (rule outf_fg_unfold[symmetric])
    using assms by auto
  finally show ?thesis .
qed

lemma cap'_fg_inf_fg_fg_le_inf_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "h = h1 + h2" "xs \<noteq> []" "\<forall>x y. edge_fg h x y \<in> E" "End_closed E"
    "\<forall>x y. edge_fg h1 x y \<in> E" "\<forall>x y. edge_fg h2 x y \<in> E" "id \<in> E" "(\<lambda>_. 0) \<in> E"
     "id \<in> E" "set xs \<subseteq> dom_fg h1" "y \<in> dom_fg h2"
   shows "cap_fg h1 (hd xs) y (inf_fg h1 (hd xs)) \<le> inf_fg h2 y"
proof -
  have "cap_fg h1 (hd xs) y (inf_fg h1 (hd xs)) \<le> outf_fg h1 y"
    apply (rule cap_fg_inf_fg_le_outf_fg)
    using assms apply auto
    using plus_fg_dom_disj by fastforce
  also have "... \<le> inf_fg h2 y"
    apply (rule outf_fg_le_inf_fg[of h])
    using assms by auto
  finally show ?thesis .
qed

lemma cap'_fg_inf_fg_fg_le_inf_fg2:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "h = h1 + h2" "xs \<noteq> []" "\<forall>x y. edge_fg h x y \<in> E" "End_closed E"
    "\<forall>x y. edge_fg h1 x y \<in> E" "\<forall>x y. edge_fg h2 x y \<in> E"
     "id \<in> E" "set xs \<subseteq> dom_fg h1" "y \<in> dom_fg h2" "(\<lambda>_. 0) \<in> E"
   shows "cap_fg h1 (hd xs) y (inf_fg h (hd xs)) \<le> inf_fg h2 y"
proof -
  have "cap_fg h1 (hd xs) y (inf_fg (h1 + h2) (hd xs)) \<le> cap_fg h1 (hd xs) y (inf_fg h1 (hd xs))"
    apply (rule pos_endo_mono'_closed[OF inf_fg_le_inf_fg])
    using assms apply simp_all
    using hd_in_set apply blast
    using assms by (auto elim: endo_cap')
  also have "... \<le> inf_fg h2 y"
    apply (rule cap'_fg_inf_fg_fg_le_inf_fg)
    using assms by auto
  finally show ?thesis using assms by simp
qed

lemma alternating_chains'_cong:
  assumes "alternating' P Q xss ys" "\<And>xs y. P xs \<Longrightarrow> f xs y = g xs y" "\<And>xs y. Q xs \<Longrightarrow> f xs y = g xs y"
  shows "chains' f xss y a = chains' g xss y a"
  using assms by (induction xss arbitrary: a P Q rule: induct_list012, auto)

lemma alternating_chains_cong:
  assumes "alternating P Q xss" "\<And>xs y. P xs \<Longrightarrow> f xs y = g xs y" "\<And>xs y. Q xs \<Longrightarrow> f xs y = g xs y"
  shows "chains' f xss y a = chains' g xss y a"
  using assms by (induction xss arbitrary: a P Q rule: induct_list012, auto)

lemma chains'_cap_fg_inf_fg_le_inf_fg':
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "alternating' (P h1) (P h2) xss ys" "h \<noteq> bot" "h = h1 + h2" "xss \<noteq> []"
    "\<forall>x y. edge_fg h x y \<in> E" "End_closed E" "\<forall>x y. edge_fg h1 x y \<in> E"
    "\<forall>x y. edge_fg h2 x y \<in> E" "xss \<noteq> []" "\<forall>xs \<in> set xss. xs \<noteq> []"
    "\<And>xs. P h1 xs \<Longrightarrow> set xs \<subseteq> dom_fg h1" "\<And>xs. P h2 xs \<Longrightarrow> set xs \<subseteq> dom_fg h2"
    "id \<in> E" "hd ys \<in> dom_fg (alt h2 h1 xss)" "(\<lambda>_. 0) \<in> E"
  shows "chains' (alt_cap_fg h1 h2) xss (hd ys) (inf_fg h1 (hd (hd xss)))
    \<le> inf_fg (alt h2 h1 xss) (hd ys)"
  using assms
proof (induction xss rule: alternating'_induct'_symmetric[where a=h1 and b=h2])
  case (empty h1 h2)
  then show ?case by simp
next
  case (base h1 h2 xs)
  then show ?case
    apply simp
    apply (rule cap'_fg_inf_fg_fg_le_inf_fg[simplified, where h=h and E=E])
    using assms by simp_all
next
  case (step h1 h2 xs ys' zss)
  then have swp: "h2 + h1 = h1 + h2"
    by (simp add: algebra_simps)

  have eq: "\<And>xsa ya. xsa \<noteq> [] \<Longrightarrow> alt_cap_fg h1 h2 xsa ya = alt_cap_fg h2 h1 xsa ya"
    apply (case_tac "set xsa \<subseteq> dom_fg h1")
     apply (case_tac "set xsa \<subseteq> dom_fg h2")
      apply simp_all
    using plus_fg_dom_disj[of h1 h2] \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close>
    by (meson disjoint_iff_not_equal hd_in_set subset_code(1))

  from step show ?case
    apply simp
    apply (rule order_trans)
     apply (rule pos_endo_mono'_closed[OF cap'_fg_inf_fg_fg_le_inf_fg, simplified, where E=E])
    apply blast
    apply blast
    apply blast
    apply blast
    apply blast
    apply blast
    apply blast
    unfolding id_def apply blast
    apply (fold id_def)
         apply auto[1]
       apply (meson hd_in_set subsetD)
       apply (meson hd_in_set subsetD)
       apply (meson hd_in_set subsetD)
      apply (rule endo_chains')
        apply simp_all
     apply (intro conjI impI allI)
       apply (rule endo_cap', simp_all)
       apply (rule endo_cap', simp_all)
       apply (rule endo_cap', simp_all)
    apply (subst chains'_cong[where g="alt_cap_fg h2 h1"])
     apply (subgoal_tac "xsa \<noteq> []")
    using eq apply auto[1]
     apply auto[1]
    using step.IH[simplified swp] unfolding id_def by auto
qed

lemma cap'_fg_le_inf_fg_le_inf_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "h \<noteq> bot" "h = h1 + h2" "xs \<noteq> []" "\<forall>x y. edge_fg h x y \<in> E" "End_closed E"
    "\<forall>x y. edge_fg h1 x y \<in> E" "\<forall>x y. edge_fg h2 x y \<in> E" "id \<in> E"
    "set xs \<subseteq> dom_fg h1" "y \<in> dom_fg h2" "m \<le> inf_fg h1 (hd xs)" "(\<lambda>_. 0) \<in> E"
   shows "cap_fg h1 (hd xs) y m \<le> inf_fg h2 y"
proof -
  have "cap_fg h1 (hd xs) y m \<le> cap_fg h1 (hd xs) y (inf_fg h1 (hd xs))"
    apply (rule pos_endo_mono'_closed[OF \<open>m \<le> inf_fg h1 (hd xs)\<close>, where E=E])
     apply (rule endo_cap')
    using assms dom_fg_finite by blast+
  also have "... \<le> inf_fg h2 y"
    apply (rule cap'_fg_inf_fg_fg_le_inf_fg[where h=h and E=E])
    using assms by blast+
  finally show ?thesis .
qed

lemma alternating_inf_fg_flow_fg:
  fixes h1 h2 :: "('a,'b :: pos_cancel_comm_monoid_add) fg"
  assumes "h = h1 + h2" "h \<noteq> bot" "ys \<noteq> []"
  shows "alternating' (segment_fg h1) (segment_fg h2) xss ys \<Longrightarrow> inf_fg (alt h2 h1 xss) (hd ys) \<le> flow_fg h (hd ys)"
proof (induction xss rule: alternating'_induct'[where a=h1 and aa=h1 and b=h2 and bb=h2])
  case emptyP
  then show ?case
    using inf_fg_le_flow_fg[of h1 "hd ys"] flow_fg_plus_fg_on1'[of h1 h2 "hd ys"] plus_fg_ops_exist[of h1 h2] assms
    by force
next
  case emptyQ
  then show ?case
    using inf_fg_le_flow_fg[of h2 "hd ys"] flow_fg_plus_fg_on2'[of h1 h2 "hd ys"] plus_fg_ops_exist[of h1 h2] assms
    by force
next
  case (baseP xs)
  then show ?case
    using inf_fg_le_flow_fg[of h2 "hd ys"] flow_fg_plus_fg_on2'[of h1 h2 "hd ys"] plus_fg_ops_exist[of h1 h2] assms
    by force
next
  case (baseQ xs)
  then show ?case
    using inf_fg_le_flow_fg[of h1 "hd ys"] flow_fg_plus_fg_on1'[of h1 h2 "hd ys"] plus_fg_ops_exist[of h1 h2] assms
    by force
next
  case (stepP x y' zs)
  then show ?case by simp
next
  case (stepQ x y' zs)
  then show ?case by simp
qed

abbreviation "alt_chain h1 h2 \<equiv> \<lambda>xs y. if set xs \<subseteq> dom_fg h1 then chain (edge_fg h1) xs y else chain (edge_fg h2) xs y"

lemma chains'_chain_inf_fg_le_inf_fg:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "alternating' (segment_fg h1) (segment_fg h2) xss ys" "xss \<noteq> []" "h1 + h2 \<noteq> bot" "\<forall>x y. edge_fg h1 x y \<in> E"
    "End_closed E" "\<forall>x y. edge_fg h2 x y \<in> E" "(\<lambda>_. 0) \<in> E" "id \<in> E"
  shows "chains' (alt_chain h1 h2) xss (hd ys) (inf_fg h1 (hd (hd xss))) \<le> inf_fg (alt h2 h1 xss) (hd ys)"
  using assms
proof (induction xss rule: alternating'_induct'_symmetric'[where a=h1 and b=h2 and aa=h1 and bb=h2])
  case (empty a b)
  then show ?case by simp
next
  case (base h1 h2 h1 h2 xs)
  then show ?case apply simp
    using chain_inf_fg_le_inf_fg[of "h1 + h2" E h1 xs "hd ys" h2] base apply simp
    using hd_in_set by blast
next
  case (step h1 h2 h1 h2 xs ys' zss)

  have D: "dom_fg h1 \<inter> dom_fg h2 = {}" "dom_fg h1 \<noteq> {}" "dom_fg h2 \<noteq> {}"
    using step by auto
  then have S: "\<And>xs y. xs \<in> set (ys' # zss) \<Longrightarrow> (if set xs \<subseteq> dom_fg h1 then chain (edge_fg h1) xs y else chain (edge_fg h2) xs y) =
        (if set xs \<subseteq> dom_fg h2 then chain (edge_fg h2) xs y else chain (edge_fg h1) xs y)"
    using step apply auto
      apply (meson \<open>dom_fg h1 \<inter> dom_fg h2 = {}\<close> disjoint_iff_not_equal hd_in_set in_mono)
     apply (smt D alternating'_props disjoint_eq_subset_Compl inf.absorb_iff1 set_empty subset_trans)
    by (metis (no_types, lifting) alternating'_props in_mono)

  from step show ?case
    apply simp
    apply (rule order_trans[where y="chains' _ _ _ (inf_fg h2 (hd ys'))", OF pos_endo_mono'_closed[where f="chains' _ _ _" and E=E]])
    using  chain_inf_fg_le_inf_fg[of "h1 + h2" E h1 xs "hd ys'" h2] step hd_in_set apply (auto simp: algebra_simps)[1]
       apply blast
      apply (rule endo_chains'[OF \<open>End_closed E\<close>], auto simp: step intro!: endo_chain_closed)
    apply (subst chains'_cong[OF S], simp)
    by (simp add: algebra_simps step)
qed

lemma cap'_empty:
  shows "cap' k {} e x y = \<delta> x y"
  by (cases k, auto)

text \<open>an approximation with cap (sum k\_i) is too coarse, we need a slightly finer variant\<close>

lemma chains'_cap_inf_le_chain_sum:
  fixes h h1 h2 :: "('a,'b :: pos_cancel_comm_monoid_add) fg"
  assumes "alternating (segment_fg h1) (segment_fg h2) xss"
    "h \<noteq> bot" "h = h1 + h2" "xss \<noteq> []" "\<forall>xs \<in> set xss. xs \<noteq> []" "y \<in> dom_fg (alt h2 h1 xss)"
    "\<forall>xs \<in> set xss. set xs \<subseteq> dom_fg h" "dom_fg h \<noteq> {}" "\<forall>x y. edge_fg h x y \<in> E" "\<forall>x y. edge_fg h1 x y \<in> E" "\<forall>x y. edge_fg h2 x y \<in> E" "End_closed E"
    "id \<in> E" "(\<lambda>_. 0) \<in> E" "z \<le> inf_fg h1 (hd (hd xss))"
  shows "chains' (alt_cap_fg h1 h2) xss y z \<le> (\<Sum>xs \<in> l_lists' (dom_fg h) (card (dom_fg h) * length xss). chain (edge_fg h) ((hd (hd xss)) # xs) y z)"
  using assms
proof (induction xss arbitrary: y z rule: alternating_induct'_symmetric[where a=h1 and b=h2])
  case empty
  then show ?case by simp
next
  case (base h1 h2 xs)
  then have "y \<in> dom_fg h2" by simp
  moreover have "hd xs \<in> dom_fg h1" using base hd_in_set by blast
  ultimately have N: "hd xs \<noteq> y" using base plus_fg_dom_disj[of h1 h2] by blast

  from base show ?case apply simp
    apply (subst cap'_unrolled_closed[OF _ dom_fg_finite])
    apply blast
    using hd_in_set apply blast
      apply (simp_all add: \<delta>_def N)
    apply (subst plus_fun_apply_iterated[OF l_lists'_finite[OF dom_fg_finite]])
    apply (subst chain2_chain)
    apply (subst sum.cong, simp, rule chain_cong''[OF edge_fg_plus_fg_on1[of h1 h2], symmetric], simp)
    unfolding l_lists'_def apply simp
    using hd_in_set apply blast
    apply (rule order_trans[OF sum_mono2[OF l_lists'_finite[where X="dom_fg (h1 + h2)" and l="card (dom_fg (h1 + h2))", OF dom_fg_finite]]], simp)
    unfolding l_lists'_def
      apply (smt Collect_mono Un_upper1 add.right_neutral card_Un_Int card_empty dom_fg_finite less_add_same_cancel1 less_trans not_gr_zero plus_fg_dom_disj subset_trans)
    by simp_all
next
  case (step h1 h2 xs ys zss)

  have D: "dom_fg h1 \<inter> dom_fg h2 = {}"
    using step by simp

  have **: "h2 + h1 = h1 + h2"
    using step by (simp add: ac_simps)

  have E: "\<And>xs. xs \<noteq> [] \<Longrightarrow> set xs \<subseteq> dom_fg h1 \<Longrightarrow> set xs \<subseteq> dom_fg h2 \<Longrightarrow> False"
  proof (goal_cases)
    case (1 xs)
    then have "xs = []" using D
      by (meson disjoint_iff_not_equal hd_in_set subset_code(1))
    then show ?case using 1 by simp
  qed

  from step have "hd xs \<in> dom_fg h1" using hd_in_set by blast
  moreover have ysh2: "hd ys \<in> dom_fg h2" using hd_in_set step by blast
  ultimately have DD: "hd xs \<noteq> hd ys" using D by auto

  let ?l' = "\<lambda>xs. (dropWhile (\<lambda>x. x \<noteq> hd ys) xs, takeWhile (\<lambda>x. x \<noteq> hd ys) xs)"

  have inj: "inj ?l'" by (intro injI, metis Pair_inject takeWhile_dropWhile_id)

  have subs: "(Cons (hd ys) ` l_lists' (dom_fg h2 \<union> dom_fg h1) (card (dom_fg h2 \<union> dom_fg h1) + card (dom_fg h2 \<union> dom_fg h1) * length zss)) \<times> l_lists' (dom_fg h1) (card (dom_fg h1)) \<subseteq>
        ?l' ` l_lists' (dom_fg h1 \<union> dom_fg h2) (card (dom_fg h1 \<union> dom_fg h2) + (card (dom_fg h1 \<union> dom_fg h2) + card (dom_fg h1 \<union> dom_fg h2) * length zss))"
  proof -
    show ?thesis
      unfolding l_lists'_def
      using dom_fg_finite[of h1] dom_fg_finite[of h2] plus_fg_dom_disj[of h1 h2] \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close>
      unfolding image_def
      apply (auto simp: card_Un_disjoint algebra_simps \<open>hd ys \<in> dom_fg h2\<close>)
      subgoal for a b
        apply (rule exI[where x="a @ hd ys # b"], auto simp: \<open>hd ys \<in> dom_fg h2\<close>)
         apply (induction a, simp, simp)
        using D ysh2 apply blast
        apply (induction a, simp, simp)
        using D ysh2 by blast
      done
  qed

  from step show ?case
    apply simp
    apply (subst chains'_cong[where g="alt_cap_fg h2 h1"])
     apply clarsimp
    subgoal for xs a using E[of xs] by blast
    apply (rule order_trans[OF step.IH, simplified])
    using "**" apply presburger
    using "**" apply presburger
         apply blast
         apply blast
         apply blast
             apply blast
    using "**" apply presburger
         apply blast
         apply blast
         apply blast
         apply blast
    using "**" apply presburger
     apply (rule order_trans[OF pos_endo_mono'_closed[OF \<open>z \<le> inf_fg h1 (hd (hd (xs # ys # zss)))\<close>]])
    apply (rule endo_cap'[where E=E], simp_all add: id_def)
     apply (rule cap'_fg_inf_fg_fg_le_inf_fg[where h="h1 + h2" and E=E], simp_all add: id_def)
     apply (meson hd_in_set in_mono)
    apply (subst cap'_unrolled_closed[OF _ dom_fg_finite, where E=E])
    apply blast
       apply (meson hd_in_set in_mono)
      apply blast
    unfolding \<delta>_def using DD apply simp
    apply (subst (2) sum.cong, simp)
    apply (subst plus_fun_apply_iterated[OF l_lists'_finite[OF dom_fg_finite]])
     apply (rule fun_dist_right''[OF l_lists'_finite[OF dom_fg_finite], where E=E])
      apply (rule endo_chain_closed)
    subgoal premises prems for x using \<open>\<forall>x y. edge_fg (h1 + h2) x y \<in> E\<close> by (simp add: algebra_simps)
       apply blast
      apply (simp add: id_def)
    apply blast
    apply (subst chain2_chain)
    apply (subst sum.cong[OF _ sum.cong], simp, simp)
     apply (subst (2) chain_cong''[OF edge_fg_plus_fg_on2[of h2], symmetric])
    subgoal premises prems using \<open>h \<noteq> bot\<close> \<open>h = h1 + h2\<close> by (simp add: algebra_simps)
      subgoal unfolding l_lists'_def apply simp by (meson hd_in_set in_mono)
       apply (subst chain_append'[symmetric, where ys="hd ys # _", simplified], simp)
      apply (subst (2) sum.reindex_cong[symmetric, where l="Cons (hd ys)"])
         apply (intro inj_onI, simp, simp, simp)
      apply (subst sum.cartesian_product)
      apply (rule order_trans[OF sum_reindex_cong_mono[OF subs inj]])
         apply (auto split: prod.splits)[1]
      apply (rule l_lists'_finite[OF finite_UnI[OF dom_fg_finite dom_fg_finite]])
       apply simp
      using "**" by fastforce
qed

lemma cap_le_cap:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "a \<le> a'" "h = h1 + h2" "h \<noteq> bot" "End_closed E" "\<forall>x y. edge_fg (h1 + h2) x y \<in> E"
    "\<forall>x y. edge_fg h1 x y \<in> E" "x \<in> dom_fg h1" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "cap_fg h1 x y a \<le> cap_fg h x y a'"
proof -
  let ?N1 = "dom_fg h1" let ?e1 = "edge_fg h1"
  let ?N = "dom_fg (h1 + h2)" let ?e = "edge_fg (h1 + h2)"

  have "x \<in> dom_fg (h1 + h2)"
    using assms by simp

  have "cap_fg h1 x y a = \<delta> x y a + (\<Sum>ns\<in>l_lists' ?N1 (card ?N1). chain2 ?e1 x ns y) a"
    using cap'_unrolled_closed[OF _ dom_fg_finite \<open>x \<in> dom_fg h1\<close> \<open>End_closed E\<close>] assms by simp
  also have "... = \<delta> x y a + (\<Sum>ns\<in>l_lists' ?N1 (card ?N1). chain ?e1 (x # ns) y a)"
    by (subst plus_fun_apply_iterated[OF l_lists'_finite[OF dom_fg_finite]], subst chain2_chain, simp)
  also have "... = \<delta> x y a + (\<Sum>ns\<in>l_lists' ?N1 (card ?N1). chain ?e (x # ns) y a)"
    apply (simp, rule sum.cong)
     apply (simp, subst chain_cong'[OF edge_fg_plus_fg_on1])
    using assms unfolding l_lists'_def by simp_all
  also have "... \<le> \<delta> x y a + (\<Sum>ns\<in>l_lists' ?N (card ?N). chain ?e (x # ns) y a)"
    apply (rule add_left_mono[OF sum_mono2[OF l_lists'_finite[OF dom_fg_finite]]])
    unfolding l_lists'_def using assms card_mono[OF dom_fg_finite dom_fg_plus_fg_subs1] apply fastforce
    by simp
  also have "... \<le> \<delta> x y a + (\<Sum>ns\<in>l_lists' ?N (card ?N). chain2 ?e x  ns y) a"
    by (subst plus_fun_apply_iterated[OF l_lists'_finite[OF dom_fg_finite]], subst chain2_chain, simp)
  also have "... = cap_fg (h1 + h2) x y a"
    using cap'_unrolled_closed[OF _ dom_fg_finite \<open>x \<in> dom_fg (h1 + h2)\<close> \<open>End_closed E\<close>] assms by simp
  also have "... \<le> cap_fg (h1 + h2) x y a'"
    apply (rule pos_endo_mono'_closed[OF \<open>a \<le> a'\<close>, where E=E])
     apply (rule endo_cap')
    using assms by simp_all
  finally show ?thesis using assms by simp
qed

lemma fold_endo_closed:
  assumes "set fs \<subseteq> E" "f \<in> E" "End_closed E"
  shows "fold (o) fs f \<in> E"
  using assms
proof (induction fs arbitrary: f)
case Nil
  then show ?case by simp
next
  case (Cons g fs)
  then have "(\<lambda>a. g (f a)) \<in> E"
    unfolding endo_def End_closed_def comp_def
    by simp
  then show ?case
    using Cons
    unfolding End_closed_def endo_def comp_def
    by simp
qed

lemma chains_le_fold:
  fixes f :: "'n list \<Rightarrow> ('m \<Rightarrow> 'm :: pos_cancel_comm_monoid_add)"
  assumes "\<forall>ms \<in> set mss. chain e ms m \<le> f ms" "\<forall>ms \<in> set mss. hd ms = m"
    "\<forall>x y. e x y \<in> E" "\<forall>x. f x \<in> E" "End_closed E" "\<forall>ms \<in> set mss. ms \<noteq> []"
  shows "chains e mss m \<le> fold (o) (map f mss) id"
  using assms
proof (induction mss rule: induct_list012)
  case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 x y zs)
  have "chains e (y # zs) (hd x) \<circ> chain e x (hd y) \<le> fold (\<circ>) (map f zs) (f y) \<circ> f x"
    apply (rule pos_endo_mono_closed)
        apply (subst "3"(4), simp)
    using 3 apply fastforce
    using 3(2,3) apply simp
    using endo_chains_closed_nonempty [of e E "y # zs" "hd x"] 3 apply simp
    using endo_chains_closed_nonempty [of e E "y # zs" "hd x"] 3 apply simp
    apply (rule fold_endo_closed)
    using 3 by auto
  also have "... = fold (\<circ>) (map f zs) (f y \<circ> f x)"
    using fold_cons[of "map f zs" "f y" "f x"] by simp
  finally show ?case
    by (auto simp: comp_def 3, fold comp_def, simp)
qed

end


section \<open> Reactive Healthiness Conditions \<close>

theory utp_rea_healths
  imports utp_rea_core "UTP-Designs.utp_des_healths"
begin

subsection \<open> R1: Events cannot be undone \<close>

definition R1 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
R1_def [pred]: "R1 (P) = (P \<and> (tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e)"

expr_constructor R1

lemma R1_idem: "R1(R1(P)) = R1(P)"
  by pred_auto

lemma R1_Idempotent [closure]: "Idempotent R1"
  by (simp add: Idempotent_def R1_idem)

lemma R1_mono: "P \<sqsubseteq> Q \<Longrightarrow> R1(P) \<sqsubseteq> R1(Q)"
  by pred_auto

lemma R1_Monotonic: "Monotonic R1"
  by (simp add: mono_def R1_mono)
     (pred_auto)

lemma R1_Continuous: "Continuous R1"
  by (simp add: Continuous_def, pred_auto)

(*
Can use find_theorems to look for applicable theorems
find_theorems "(\<bowtie>)" "(\<bowtie>\<^sub>S)" *)

lemma R1_unrest:
  assumes "mwb_lens x" "x \<bowtie> (ns_alpha fst\<^sub>L tr)" "x \<bowtie> (ns_alpha snd\<^sub>L tr)" "$x \<sharp> P"
  shows "$x \<sharp> (R1 P)"
proof -
  have "$x \<sharp> tr\<^sup><"
    using assms(2) by (simp add: unrest_ssubst var_alpha_combine usubst_eval scene_indep_sym)
  moreover have "$x \<sharp> tr\<^sup>>"
    using assms(3) by (simp add: unrest_ssubst var_alpha_combine usubst_eval scene_indep_sym)
  ultimately show ?thesis
    using assms by pred_auto
qed

lemma R1_false: "R1(false) = false"
  by pred_auto

lemma R1_conj: "R1(P \<and> Q) = (R1(P) \<and> R1(Q))"
  by pred_auto

lemma conj_R1_closed_1 [closure]: "P is R1 \<Longrightarrow> (P \<and> Q) is R1"
  by (pred_auto, blast)

lemma conj_R1_closed_2 [closure]: "Q is R1 \<Longrightarrow> (P \<and> Q) is R1"
  by (simp add: Healthy_def, pred_auto)

lemma R1_disj: "R1(P \<or> Q) = (R1(P) \<or> R1(Q))"
  by pred_auto

lemma disj_R1_closed [closure]: "\<lbrakk> P is R1; Q is R1 \<rbrakk> \<Longrightarrow> (P \<or> Q) is R1"
  by (simp add: Healthy_def R1_def; pred_auto; blast)

lemma R1_impl: "R1(P \<longrightarrow> Q) = ((\<not> R1(\<not> P)) \<longrightarrow> R1(Q))"
  by (simp add: R1_def; pred_auto)

lemma R1_inf: "R1(P \<sqinter> Q) = (R1(P) \<sqinter> R1(Q))"
  by pred_auto

lemma R1_USUP:
  "R1 (\<Sqinter>i \<in> A. P i) = (\<Sqinter> i \<in> A. R1 (P i))"
  by (simp add: fun_eq_iff R1_def conj_pred_def)

lemma R1_Sup [closure]: "\<lbrakk> \<And> P. P \<in> A \<Longrightarrow> P is R1; A \<noteq> {} \<rbrakk> \<Longrightarrow> \<Sqinter> A is R1"
  using R1_Continuous by (auto simp add: Continuous_def Healthy_def)

lemma R1_UINF:
  assumes "A \<noteq> {}"
  shows "R1(\<Squnion> i \<in> A. P(i)) = (\<Squnion> i \<in> A. R1(P(i)))"
  by (pred_auto assms: assms)

lemma R1_UINF_ind:
  "R1(\<Squnion> i. P(i)) = (\<Squnion> i. R1(P(i)))"
  by pred_auto

lemma UINF_ind_R1_closed [closure]:
  "\<lbrakk> \<And> i. P(i) is R1 \<rbrakk> \<Longrightarrow> (\<Sqinter> i. P(i)) is R1"
  by (pred_auto; blast)

lemma UINF_R1_closed [closure]:
  "\<lbrakk> \<And> i. P i is R1 \<rbrakk> \<Longrightarrow> (\<Sqinter> i \<in> A. P i) is R1"
  by (simp add: Healthy_def; pred_auto; blast)

lemma tr_ext_conj_R1 [closure]:
  "(tr\<^sup>> = tr\<^sup>< @ e)\<^sub>e \<and> P is R1"
  by (pred_auto add: Prefix_Order.prefixI)

lemma tr_id_conj_R1 [closure]:
  "(tr\<^sup>> = tr\<^sup><)\<^sub>e \<and> P is R1"
  by pred_auto

lemma R1_extend_conj: "R1(P \<and> Q) = (R1(P) \<and> Q)"
  by pred_auto

lemma R1_extend_conj': "R1(P \<and> Q) = (P \<and> R1(Q))"
  by pred_auto

lemma R1_cond: "R1(P \<triangleleft> b \<triangleright> Q) = (R1(P) \<triangleleft> b \<triangleright> R1(Q))"
  by pred_auto

lemma R1_cond': "R1(P \<triangleleft> b \<triangleright> Q) = (R1(P) \<triangleleft> R1(b) \<triangleright> R1(Q))"
  by pred_auto

lemma R1_negate_R1: "R1(\<not> R1(P)) = R1(\<not> P)"
  by pred_auto

lemma R1_wait_true [usubst]: "(R1 P)\<^sub>t = R1(P)\<^sub>t"
  by pred_auto

lemma R1_wait_false [usubst]: "(R1 P) \<^sub>f = R1(P) \<^sub>f"
  by pred_auto

lemma R1_wait'_true [usubst]: "(R1 P)\<lbrakk>True/wait\<^sup>>\<rbrakk> = R1(P\<lbrakk>True/wait\<^sup>>\<rbrakk>)"
  by pred_auto

term "P\<lbrakk>False/wait\<^sup>>\<rbrakk>"
(* term "[wait\<^sup>> \<leadsto> false] \<dagger> P" *)

lemma R1_wait'_false [usubst]: "(R1 P)\<lbrakk>False/wait\<^sup>>\<rbrakk> = R1(P\<lbrakk>False/wait\<^sup>>\<rbrakk>)"
  by pred_auto

lemma R1_wait_false_closed [closure]: "P is R1 \<Longrightarrow> P\<lbrakk>False/wait\<^sup><\<rbrakk> is R1"
  by pred_auto

lemma R1_wait'_false_closed [closure]: "P is R1 \<Longrightarrow> P\<lbrakk>False/wait\<^sup>>\<rbrakk> is R1"
  by pred_auto

lemma R1_skip: "R1(II) = II"
  by pred_auto

lemma skip_is_R1 [closure]: "II is R1"
  by (simp add: Healthy_def R1_skip)

lemma subst_R1:
  assumes "$tr\<^sup>< \<sharp>\<^sub>s \<sigma>" "$tr\<^sup>> \<sharp>\<^sub>s \<sigma>"
  shows   "\<sigma> \<dagger> (R1 P) = R1(\<sigma> \<dagger> P)"
proof -
  have "\<langle>\<sigma>\<rangle>\<^sub>s (tr ;\<^sub>L fst\<^sub>L) = var (tr ;\<^sub>L fst\<^sub>L)"
    using assms(1)
    by (simp add: comp_vwb_lens ns_alpha_def usubst_apply_unrest)
  moreover have "\<langle>\<sigma>\<rangle>\<^sub>s (tr ;\<^sub>L snd\<^sub>L) = var (tr ;\<^sub>L snd\<^sub>L)"
    using assms(2)
    by (simp add: comp_vwb_lens ns_alpha_def usubst_apply_unrest)
  ultimately show ?thesis
    by pred_auto
qed

lemma subst_R1_closed [closure]: "\<lbrakk> $tr\<^sup>< \<sharp>\<^sub>s \<sigma>; $tr\<^sup>> \<sharp>\<^sub>s \<sigma>; P is R1 \<rbrakk> \<Longrightarrow> \<sigma> \<dagger> P is R1"
  by (metis Healthy_def subst_R1)

lemma R1_by_refinement:
  "P is R1 \<longleftrightarrow> ((tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e \<sqsubseteq> P)"
  by (pred_auto, blast+)

lemma R1_trace_extension [closure]:
  "(tr\<^sup>> \<ge> tr\<^sup>< @ e)\<^sub>e is R1"
  by (simp add: Healthy_def; pred_auto)

lemma tr_le_trans:
  "((tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e ;; (tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e) = (tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e"
  by (pred_auto; metis order_refl)

lemma R1_seqr:
  "R1(R1(P) ;; R1(Q)) = (R1(P) ;; R1(Q))"
  by pred_auto

lemma R1_seqr_closure [closure]:
  assumes "(P ::('t::trace, '\<alpha>, '\<beta>) rel_rp) is R1"
          "(Q ::('t::trace, '\<beta>, '\<gamma>) rel_rp) is R1"
  shows "(P ;; Q) is R1"
proof -
  have 1: "(tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e \<sqsubseteq> P"
    using assms by (simp add: R1_by_refinement)
  have 2: "(tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e \<sqsubseteq> Q"
    using assms by (simp add: R1_by_refinement)
  have "(((tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e :: ('t::trace, '\<alpha>, '\<beta>) rel_rp);;(tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e) \<sqsubseteq> (P;;Q)" (is "?l \<sqsubseteq> ?r")
    using 1 2 by (simp add: seqr_mono)
  moreover have "?l = (tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e"
    using tr_le_trans by blast
  ultimately show ?thesis
    by (simp add: R1_by_refinement)
qed

lemma R1_power [closure]: "P is R1 \<Longrightarrow> P\<^bold>^n is R1"
  by (induct n, simp_all add: upred_semiring.power_Suc closure)

lemma R1_true_comp [simp]: "(R1(true) ;; R1(true)) = R1(true)"
  by (pred_auto; metis order_refl rea_vars.select_convs(2))

(*
lemma R1_ok'_true: "(R1(P))\<^sup>t = R1(P\<^sup>t)"
  by pred_auto

lemma R1_ok'_false: "(R1(P))\<^sup>f = R1(P\<^sup>f)"
  by pred_auto
*)

lemma R1_ok_true: "(R1(P))\<lbrakk>True/ok\<^sup><\<rbrakk> = R1(P\<lbrakk>True/ok\<^sup><\<rbrakk>)"
  by pred_auto

lemma R1_ok_false: "(R1(P))\<lbrakk>False/ok\<^sup><\<rbrakk> = R1(P\<lbrakk>False/ok\<^sup><\<rbrakk>)"
  by pred_auto

lemma seqr_R1_true_right: "((P ;; R1(true)) \<or> P) = (P ;; (tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e)"
  by (pred_auto)

lemma conj_R1_true_right: "(P;;R1(true) \<and> Q;;R1(true)) ;; R1(true) = (P;;R1(true) \<and> Q;;R1(true))"
  apply (pred_auto)
  using dual_order.trans apply blast
  using dual_order.trans apply blast
  by (metis order_refl)

(* Why is this a lemma given the assumptions are not needed? *)
lemma R1_extend_conj_unrest: "\<lbrakk> $tr\<^sup>< \<sharp> Q; $tr\<^sup>> \<sharp> Q \<rbrakk> \<Longrightarrow> R1 (P \<and> Q) = (R1 P \<and> Q)"
  by (rule R1_extend_conj)

lemma R1_extend_conj_unrest': "\<lbrakk> $tr\<^sup>< \<sharp> Q; $tr\<^sup>> \<sharp> Q \<rbrakk> \<Longrightarrow> R1 (P \<and> Q) = (P \<and> R1 Q)"
  by (rule R1_extend_conj')

lemma R1_tr'_eq_tr: "R1(tr\<^sup>> = tr\<^sup><)\<^sub>e = (tr\<^sup>> = tr\<^sup><)\<^sub>e"
  by (pred_auto)

lemma R1_tr_less_tr': "R1(tr\<^sup>< < tr\<^sup>>)\<^sub>e = (tr\<^sup>< < tr\<^sup>>)\<^sub>e"
  by (pred_auto)

lemma tr_strict_prefix_R1_closed [closure]: "(tr\<^sup>< < tr\<^sup>>)\<^sub>e is R1"
  by (simp add: Healthy_def; pred_auto)

lemma R1_H2_commute: "R1(H2(P)) = H2(R1(P))"
  by (simp add: H2_split R1_def usubst, rel_auto)

subsection \<open> R2: No dependence upon trace history \<close>

text \<open> There are various ways of expressing $R2$, which are enumerated below. \<close>

definition R2a :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" where
[pred]: "R2a (P) = (\<Sqinter> s. P\<lbrakk>\<guillemotleft>s\<guillemotright>,(\<guillemotleft>s\<guillemotright>+(tr\<^sup>>-tr\<^sup><))/tr\<^sup><,tr\<^sup>>\<rbrakk>)"

definition R2a' :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" where
[pred]: "R2a' P = (R2a(P) \<triangleleft> R1(true) \<triangleright> P)"

definition R2s :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t,'\<alpha>,'\<beta>) rel_rp" where
[pred]: "R2s (P) = P\<lbrakk>0, (tr\<^sup>>-tr\<^sup><) / tr\<^sup><, tr\<^sup>>\<rbrakk>"

definition R2 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[pred]: "R2(P) = R1(R2s(P))"

definition R2c :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[pred]: "R2c(P) = (R2s(P) \<triangleleft> R1(true) \<triangleright> P)"

lemma R2c_expand_R1: "R2c(P) = (R2s(P) \<triangleleft> tr\<^sup>< \<le> tr\<^sup>> \<triangleright> P)"
  by (simp add: R2c_def R1_def)

expr_constructor R2a R2a' R2s R2 R2c

text \<open> @{term R2a} and @{term R2s} are the standard definitions from the UTP book~\cite{Hoare&98}.
  An issue with these forms is that their definition depends upon @{term R1} also being
  satisfied~\cite{Foster17b}, since otherwise the trace minus operator is not well defined.
  We overcome this with our own version, @{term R2c}, which applies @{term R2s} if @{term R1} holds,
  and otherwise has no effect. This latter healthiness condition can therefore be reasoned about
  independently of @{term R1}, which is useful in some circumstances. \<close>

lemma unrest_ok_R2s [unrest]:
  assumes "$ok\<^sup>< \<sharp> P"
  shows "$ok\<^sup>< \<sharp> R2s(P)"
proof -
  have "$ok\<^sup>< \<sharp> ([tr\<^sup>< \<leadsto> 0, tr\<^sup>> \<leadsto> ($tr)\<^sup>> - ($tr)\<^sup><] \<dagger> P)"
    using assms by pred_auto
  thus ?thesis
    by (simp add: R2s_def SEXP_def)
qed

lemma unrest_ok'_R2s [unrest]:
  assumes "$ok\<^sup>> \<sharp> P"
  shows "$ok\<^sup>> \<sharp> R2s(P)"
proof -
  have "$ok\<^sup>> \<sharp> ([tr\<^sup>< \<leadsto> 0, tr\<^sup>> \<leadsto> ($tr)\<^sup>> - ($tr)\<^sup><] \<dagger> P)"
    using assms by pred_auto
  thus ?thesis
    by (simp add: R2s_def SEXP_def)
qed

lemma cond_and: "(P \<triangleleft> b \<triangleright> Q) = ((P \<and> b) \<or> (Q \<and> \<not>b))"
  by (pred_auto)

lemma cond_and_R: "(P \<triangleleft> b \<triangleright> Q) = ((P \<and> (b)\<^sub>e) \<or> (Q \<and> \<not>(b)\<^sub>e))"
  by (pred_auto)

lemma unrest_ok_R2c [unrest]:
  assumes "$ok\<^sup>< \<sharp> P"
  shows "$ok\<^sup>< \<sharp> R2c(P)"
proof -
  have 1: "$ok\<^sup>< \<sharp> R1 true" and 2: "$ok\<^sup>< \<sharp> \<not> R1 true"
    using assms by pred_auto+
  thus ?thesis
    by (simp add: R2c_def cond_and unrest_pred 1 2 assms unrest_ok_R2s)
qed

(* TODO: this should have a better proof *)
lemma R2s_unrest [unrest]: "\<lbrakk> vwb_lens x; x \<bowtie> (tr ;\<^sub>L fst\<^sub>L); x \<bowtie> (tr ;\<^sub>L snd\<^sub>L); $x \<sharp> P \<rbrakk> \<Longrightarrow> $x \<sharp> R2s(P)"
  apply (simp add: R2s_def unrest usubst lens_indep_sym)
  by (smt (z3) SEXP_def aext_var lens_indep.lens_put_comm lens_indep.lens_put_irr2 ns_alpha_def subst_SEXP subst_id_def subst_upd_def subst_var unrest_lens vwb_lens_mwb)

lemma unrest_ok'_R2c [unrest]:
  assumes "$ok\<^sup>> \<sharp> P"
  shows "$ok\<^sup>> \<sharp> R2c(P)"
proof -
  have 1: "$ok\<^sup>> \<sharp> R1 true" and 2: "$ok\<^sup>> \<sharp> \<not> R1 true"
    using assms by pred_auto+
  thus ?thesis
    by (simp add: R2c_def cond_and unrest_pred 1 2 assms unrest_ok'_R2s)
qed

(* TODO: why can't the following set of lemmas be proved using simp e.g.
     by (simp add: R2_def R1_def R2s_def usubst unrest)
         as in old UTP

   ANSWER: Substitution has changed to a much shallower process, employing
    lambda applications. This means it's much more efficient, but also we have
    a bit less control over it. This particularly surfaces when performing subsitutions
    on terms containing expression variables as below. My fix was to (1) remove the e-brackets
    from the definition of @{const R2s}, as they are not necessary, and (2) to make
    a few improvements to substitution in shallow expressions.
*)

lemma R2s_subst_wait_true [usubst]:
  "(R2s(P))\<lbrakk>True/wait\<^sup><\<rbrakk> = R2s(P\<lbrakk>True/wait\<^sup><\<rbrakk>)"
  by (simp add: R2_def R1_def R2s_def usubst unrest)
     (subst_eval)

lemma R2s_subst_wait'_true [usubst]:
  "(R2s(P))\<lbrakk>True/wait\<^sup>>\<rbrakk> = R2s(P\<lbrakk>True/wait\<^sup>>\<rbrakk>)"
  by (simp add: R2_def R1_def R2s_def usubst unrest)
     (subst_eval)

lemma R2_subst_wait_true [usubst]:
  "(R2(P))\<lbrakk>True/wait\<^sup><\<rbrakk> = R2(P\<lbrakk>True/wait\<^sup><\<rbrakk>)"
  by (simp add: R2_def R1_def R2s_def usubst unrest)
     (subst_eval)

lemma R2_subst_wait'_true [usubst]:
  "(R2(P))\<lbrakk>True/wait\<^sup>>\<rbrakk> = R2(P\<lbrakk>True/wait\<^sup>>\<rbrakk>)"
  by (simp add: R2_def R1_def R2s_def usubst unrest)
     (subst_eval)

lemma R2_subst_wait_false [usubst]:
  "(R2(P))\<lbrakk>False/wait\<^sup><\<rbrakk> = R2(P\<lbrakk>False/wait\<^sup><\<rbrakk>)"
  by (simp add: R1_def R2_def R2s_def usubst unrest)
     (subst_eval)

lemma R2_subst_wait'_false [usubst]:
  "(R2(P))\<lbrakk>False/wait\<^sup>>\<rbrakk> = R2(P\<lbrakk>False/wait\<^sup>>\<rbrakk>)"
  by (simp add: R1_def R2_def R2s_def usubst unrest)
     (subst_eval)

lemma R2c_R2s_absorb: "R2c(R2s(P)) = R2s(P)"
  by (pred_auto)

lemma R2a_R2s: "R2a(R2s(P)) = R2s(P)"
  by (pred_auto)

lemma R2s_R2a: "R2s(R2a(P)) = R2a(P)"
  by (pred_auto)

lemma R2a_equiv_R2s: "P is R2a \<longleftrightarrow> P is R2s"
  by (metis Healthy_def' R2a_R2s R2s_R2a)

lemma R2a_idem: "R2a(R2a(P)) = R2a(P)"
  by (pred_auto)

lemma R2a'_idem: "R2a'(R2a'(P)) = R2a'(P)"
  by (pred_auto)

lemma R2a_mono: "P \<sqsubseteq> Q \<Longrightarrow> R2a(P) \<sqsubseteq> R2a(Q)"
  by (pred_auto, blast)

lemma R2a'_mono: "P \<sqsubseteq> Q \<Longrightarrow> R2a'(P) \<sqsubseteq> R2a'(Q)"
  by (pred_auto; blast)

lemma R2a'_weakening: "R2a'(P) \<sqsubseteq> P"
  by(pred_auto, metis diff_add_cancel_left')

lemma R2s_idem: "R2s(R2s(P)) = R2s(P)"
  by (pred_auto)

lemma R2_idem: "R2(R2(P)) = R2(P)"
  by (pred_auto)

lemma R2_mono: "P \<sqsubseteq> Q \<Longrightarrow> R2(P) \<sqsubseteq> R2(Q)"
  by (pred_auto)

lemma R2_implies_R1 [closure]: "P is R2 \<Longrightarrow> P is R1"
  by (pred_auto, blast)

lemma R2_implies_R2c [closure]: "P is R2 \<Longrightarrow> P is R2c"
  by (pred_auto; blast)

lemma R2c_Continuous: "Continuous R2c"
  by pred_auto

lemma R2c_lit: "R2c(\<guillemotleft>x\<guillemotright>)\<^sub>e = (\<guillemotleft>x\<guillemotright>)\<^sub>e"
  by pred_auto

lemma tr_strict_prefix_R2c_closed [closure]: "(tr\<^sup>< < tr\<^sup>>)\<^sub>e is R2c"
  by pred_auto

lemma R2s_conj: "R2s(P \<and> Q) = (R2s(P) \<and> R2s(Q))"
  by pred_auto

lemma R2_conj: "R2(P \<and> Q) = (R2(P) \<and> R2(Q))"
  by pred_auto

lemma R2s_disj: "R2s(P \<or> Q) = (R2s(P) \<or> R2s(Q))"
  by pred_auto

lemma R2s_USUP:
  "R2s(\<Sqinter> i \<in> A. P(i)) = (\<Sqinter> i \<in> A. R2s(P(i)))"
  by pred_auto

lemma R2c_USUP:
  "R2c(\<Sqinter> i \<in> A. P(i)) = (\<Sqinter> i \<in> A. R2c(P(i)))"
  by pred_auto

lemma R2s_UINF:
  "R2s(\<Squnion> i \<in> A. P(i)) = (\<Squnion> i \<in> A. R2s(P(i)))"
  by pred_auto

lemma R2c_UINF:
  "R2c(\<Squnion> i \<in> A. P(i)) = (\<Squnion> i \<in> A. R2c(P(i)))"
  by pred_auto

lemma R2_disj: "R2(P \<or> Q) = (R2(P) \<or> R2(Q))"
  by pred_auto

lemma R2s_not: "R2s(\<not> P) = (\<not> R2s(P))"
  by pred_auto

lemma R2s_condr: "R2s(P \<triangleleft> b \<triangleright> Q) = (R2s(P) \<triangleleft> R2s(b) \<triangleright> R2s(Q))"
  by pred_auto

lemma R2_condr: "R2(P \<triangleleft> b \<triangleright> Q) = (R2(P) \<triangleleft> R2(b) \<triangleright> R2(Q))"
  by pred_auto

lemma R2_condr': "R2(P \<triangleleft> b \<triangleright> Q) = (R2(P) \<triangleleft> R2s(b) \<triangleright> R2(Q))"
  by pred_auto

lemma R2s_ok: "R2s(ok\<^sup><) = ok\<^sup><"
  by pred_auto

lemma R2s_ok': "R2s(ok\<^sup>>) = ok\<^sup>>"
  by pred_auto

lemma R2s_wait: "R2s(wait\<^sup><) = wait\<^sup><"
  by pred_auto

lemma R2s_wait': "R2s(wait\<^sup>>) = wait\<^sup>>"
  by pred_auto

lemma R2s_true: "R2s(true) = true"
  by pred_auto

lemma R2s_false: "R2s(false) = false"
  by pred_auto

lemma true_is_R2s:
  "true is R2s"
  by (simp add: Healthy_def R2s_true)

lemma R2s_lift_rea: "R2s(\<lceil>P\<rceil>\<^sub>R) = \<lceil>P\<rceil>\<^sub>R"
  by pred_auto

lemma R2c_lift_rea: "R2c(\<lceil>P\<rceil>\<^sub>R) = \<lceil>P\<rceil>\<^sub>R"
  by pred_auto

lemma R2c_true: "R2c(true) = true"
  by pred_auto

lemma R2c_false: "R2c(false) = false"
  by pred_auto

lemma R2c_and: "R2c(P \<and> Q) = (R2c(P) \<and> R2c(Q))"
  by pred_auto

lemma conj_R2c_closed [closure]: "\<lbrakk> P is R2c; Q is R2c \<rbrakk> \<Longrightarrow> (P \<and> Q) is R2c"
  by (simp add: Healthy_def R2c_and)

lemma R2c_disj: "R2c(P \<or> Q) = (R2c(P) \<or> R2c(Q))"
  by pred_auto

lemma R2c_inf: "R2c(P \<sqinter> Q) = (R2c(P) \<sqinter> R2c(Q))"
  by pred_auto

lemma R2c_not: "R2c(\<not> P) = (\<not> R2c(P))"
  by pred_auto

lemma R2c_ok: "R2c(ok\<^sup><) = (ok\<^sup><)"
  by pred_auto

lemma R2c_ok': "R2c(ok\<^sup>>) = (ok\<^sup>>)"
  by pred_auto

lemma R2c_wait: "R2c(wait\<^sup><) = wait\<^sup><"
  by pred_auto

lemma R2c_wait': "R2c(wait\<^sup>>) = wait\<^sup>>"
  by pred_auto

lemma R2c_wait'_true [usubst]: "(R2c P)\<lbrakk>True/wait\<^sup>>\<rbrakk> = R2c(P\<lbrakk>True/wait\<^sup>>\<rbrakk>)"
  by pred_auto

lemma R2c_wait'_false [usubst]: "(R2c P)\<lbrakk>False/wait\<^sup>>\<rbrakk> = R2c(P\<lbrakk>False/wait\<^sup>>\<rbrakk>)"
  by pred_auto

lemma R2c_tr'_minus_tr: "R2c(tr\<^sup>> = tr\<^sup><)\<^sub>e = (tr\<^sup>> = tr\<^sup><)\<^sub>e"
  apply (pred_auto) using minus_zero_eq by blast

lemma R2_tr'_minus_tr: "R2(tr\<^sup>> = tr\<^sup><)\<^sub>e = (tr\<^sup>> = tr\<^sup><)\<^sub>e"
  apply (pred_auto) using minus_zero_eq by blast

lemma R2c_tr_le_tr': "R2c(tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e = (tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e"
  by pred_auto

lemma R2c_tr'_ge_tr: "R2c(tr\<^sup>> \<ge> tr\<^sup><)\<^sub>e = (tr\<^sup>> \<ge> tr\<^sup><)\<^sub>e"
  by pred_auto

lemma R2c_tr_less_tr': "R2c(tr\<^sup>< < tr\<^sup>>)\<^sub>e = (tr\<^sup>< < tr\<^sup>>)\<^sub>e"
  by pred_auto

lemma R2c_condr: "R2c(P \<triangleleft> b \<triangleright> Q) = (R2c(P) \<triangleleft> R2c(b) \<triangleright> R2c(Q))"
  by pred_auto

lemma shAll_meet: "(\<Squnion> x. (\<guillemotleft>f\<guillemotright> \<guillemotleft>x\<guillemotright>)\<^sub>e) = (\<forall> x. \<guillemotleft>f\<guillemotright> x)\<^sub>e"
  by pred_auto

(*
lemma shAll_meet2: "(\<Squnion> x. f (P \<guillemotleft>x\<guillemotright>)\<^sub>e) = (\<forall> x. (\<guillemotleft>f\<guillemotright> P) x)\<^sub>e"
  apply pred_auto
  oops
  (* sledgehammer *)
*)

ML \<open>
  @{term "(R2c(P x))\<^sub>e"}
\<close>

lemma shAll_meet3: "(\<Squnion> x. (\<guillemotleft>f\<guillemotright> (P \<guillemotleft>x\<guillemotright>))\<^sub>e) = (\<forall> x. \<guillemotleft>f\<guillemotright> (P x))\<^sub>e"
  by pred_auto

(* Cannot quite make the equivalence work
lemma R2c_shAll: "R2c (\<forall> x. P x)\<^sub>e = (\<forall> x. R2c(P x))\<^sub>e"
  apply(pred_auto)
proof -
  have "R2c (\<forall> x. P x)\<^sub>e = R2c (\<Squnion> x. (P \<guillemotleft>x\<guillemotright>)\<^sub>e)"
    by pred_auto
  also have "\<dots> = (\<Squnion> x. R2c(P \<guillemotleft>x\<guillemotright>)\<^sub>e)"
    using R2c_UINF by blast
  also have "\<dots> = (\<forall> x. R2c(P x))\<^sub>e"
    apply pred_simp
    oops
qed
*)

lemma R2c_impl: "R2c(P \<longrightarrow> Q) = (R2c(P) \<longrightarrow> R2c(Q))"
proof -
  have "R2c(P \<longrightarrow> Q) = R2c(\<not> P \<or> Q)"
    by (simp add: impl_neg_disj)
  also have "\<dots> = (\<not> (R2c P) \<or> R2c Q)"
    by (simp add: R2c_disj R2c_not)
  also have "\<dots> = (R2c(P) \<longrightarrow> R2c(Q))"
    by (simp add: impl_neg_disj)
  finally show ?thesis .
qed

(* Need an implementation of alphabet restriction e.g. *)

text \<open> We implement a poor man's version of alphabet restriction that hides a variable within
  a relation. \<close>

definition rel_var_res :: "'\<alpha> hrel \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel" (infix "\<restriction>\<^sub>\<alpha>" 80) where
[rel]: "P \<restriction>\<^sub>\<alpha> x = (\<Sqinter> y z. (P\<lbrakk> \<guillemotleft>y\<guillemotright>,\<guillemotleft>z\<guillemotright>/x\<^sup><,x\<^sup>> \<rbrakk>))"

expr_constructor rel_var_res

lemma unrest_in_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x\<^sup>< \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def)
     (pred_auto)

lemma unrest_out_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x\<^sup>> \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def)
     (pred_auto)

(*
lemma skip_r_unfold:
  "vwb_lens x \<Longrightarrow> II = ((tr\<^sup>> = tr\<^sup><)\<^sub>e \<and> II\<restriction>\<^sub>\<alpha>x)"
  apply (simp add: rel_var_res_def)
  oops
*)

lemma R2c_skip_tr: "R2c(II\<restriction>\<^sub>\<alpha>tr) = II\<restriction>\<^sub>\<alpha>tr"
  by (simp add: rel_var_res_def; pred_auto)

lemma R2c_skip_r: "R2c(II) = II"
  by (pred_auto, metis add.right_neutral diff_add_cancel_left')

lemma R1_R2c_commute: "R1(R2c(P)) = R2c(R1(P))"
  by pred_auto

lemma R1_R2c_is_R2: "R1(R2c(P)) = R2(P)"
  by pred_auto

lemma R1_R2s_R2c: "R1(R2s(P)) = R1(R2c(P))"
  by pred_auto

lemma R1_R2s_tr_wait:
  "R1 (R2s (((tr\<^sup>> = tr\<^sup><) \<and> wait\<^sup>>)\<^sub>e)) = ((tr\<^sup>> = tr\<^sup><) \<and> wait\<^sup>>)\<^sub>e"
  apply pred_auto using minus_zero_eq by blast

lemma R1_R2s_tr'_eq_tr:
  "R1 (R2s (tr\<^sup>> = tr\<^sup><)\<^sub>e) = (tr\<^sup>> = tr\<^sup><)\<^sub>e"
  apply pred_auto using minus_zero_eq by blast

(* Need to figure out how to prove (3) or a better proof *)
(*
lemma R1_R2s_tr'_extend_tr:
  assumes "$tr\<^sup>< \<sharp> v" "$tr\<^sup>> \<sharp> v"
  shows "R1 (R2s (tr\<^sup>> = tr\<^sup>< @ (v :: 'a list list))\<^sub>e) = (tr\<^sup>> = tr\<^sup>< @ v)\<^sub>e"
proof (simp add: R1_def R2s_def)
  have 1: "mwb_lens tr"
    using tr_vwb_lens vwb_lens_mwb by blast
  have "[tr\<^sup>< \<leadsto> 0, tr\<^sup>> \<leadsto> ($tr)\<^sup>> - ($tr)\<^sup><] \<dagger> (($tr)\<^sup>> = $tr\<^sup>< @ v)\<^sub>e = (($tr)\<^sup>> - ($tr)\<^sup>< = 0 @ v)\<^sub>e"
    using assms 1 apply(subst_eval)
    oops
  have "(($tr)\<^sup>> = ($tr)\<^sup>< @ v)\<^sub>e = (($tr)\<^sup>> - ($tr)\<^sup>< = v \<and> $tr\<^sup>< \<le> $tr\<^sup>>)\<^sub>e"
    apply(pred_auto)
    apply (metis append_minus)
    by (simp add: Prefix_Order.prefixI)

  have "(([tr\<^sup>< \<leadsto> 0, tr\<^sup>> \<leadsto> ($tr)\<^sup>> - ($tr)\<^sup><] \<dagger> ($tr\<^sup>> = $tr\<^sup>< @ v \<and> ($tr)\<^sup>< \<le> ($tr)\<^sup>>)\<^sub>e))
      = (($tr\<^sup>> - $tr\<^sup>< = 0 @ v \<and> ($tr)\<^sup>< \<le> ($tr)\<^sup>>)\<^sub>e)"

qed
*)

lemma R2_tr_prefix: "R2(tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e = (tr\<^sup>< \<le> tr\<^sup>>)\<^sub>e"
  by pred_auto

lemma R2_form:
  "R2(P) = (\<exists> tt\<^sub>0. P\<lbrakk>0,\<guillemotleft>tt\<^sub>0\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> \<and> (tr\<^sup>> = tr\<^sup>< + \<guillemotleft>tt\<^sub>0\<guillemotright>))\<^sub>e"
  by(pred_auto; metis diff_add_cancel_left')

lemma R2_subst_tr:
  assumes "P is R2"
  shows "[tr\<^sup>< \<leadsto> tr\<^sub>0, tr\<^sup>> \<leadsto> tr\<^sub>0 + t] \<dagger> P = [tr\<^sup>< \<leadsto> 0, tr\<^sup>> \<leadsto> t] \<dagger> P"
proof -
  have "[tr\<^sup>< \<leadsto> tr\<^sub>0, tr\<^sup>> \<leadsto> tr\<^sub>0 + t] \<dagger> R2 P = [tr\<^sup>< \<leadsto> 0, tr\<^sup>> \<leadsto> t] \<dagger> R2 P"
    by (simp add: R2_def R1_def R2s_def; pred_auto)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma R2_seqr_form:
  shows "(R2(P) ;; R2(Q)) =
         (\<Sqinter> tt\<^sub>1 tt\<^sub>2. ((P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>)
                    \<and> (tr\<^sup>> = tr\<^sup>< + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e))"
proof -
  have "(R2(P) ;; R2(Q)) = (\<Sqinter> tr\<^sub>0. (R2(P))\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup>>\<rbrakk> ;; (R2(Q))\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup><\<rbrakk>)"
    by (subst seqr_middle[of tr], simp_all)
  also have "\<dots> =
       (\<Sqinter> tr\<^sub>0 tt\<^sub>1 tt\<^sub>2. ((P\<lbrakk>0, \<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> \<and> (\<guillemotleft>tr\<^sub>0\<guillemotright> = tr\<^sup>< + \<guillemotleft>tt\<^sub>1\<guillemotright>)\<^sub>e) ;;
                        (Q\<lbrakk>0, \<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> \<and> (tr\<^sup>> = \<guillemotleft>tr\<^sub>0\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e)))"
    by (simp add: R2_form, pred_auto; blast)
  also have "\<dots> =
       (\<Sqinter> tr\<^sub>0 tt\<^sub>1 tt\<^sub>2. (((\<guillemotleft>tr\<^sub>0\<guillemotright> = tr\<^sup>< + \<guillemotleft>tt\<^sub>1\<guillemotright>)\<^sub>e \<and> P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>) ;;
                        (Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> \<and> (tr\<^sup>> = \<guillemotleft>tr\<^sub>0\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e)))"
    by pred_auto
  also have "\<dots> =
       (\<Sqinter> tr\<^sub>0 tt\<^sub>1 tt\<^sub>2. (P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>)
                     \<and> (\<guillemotleft>tr\<^sub>0\<guillemotright> = tr\<^sup>< + \<guillemotleft>tt\<^sub>1\<guillemotright>)\<^sub>e \<and> (tr\<^sup>> = \<guillemotleft>tr\<^sub>0\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e)"
    by (pred_auto; blast)
  also have "\<dots> =
       (\<Sqinter> tt\<^sub>1 tt\<^sub>2. (P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>)
                 \<and> (\<Sqinter> tr\<^sub>0. (\<guillemotleft>tr\<^sub>0\<guillemotright> = tr\<^sup>< + \<guillemotleft>tt\<^sub>1\<guillemotright>)\<^sub>e \<and> (tr\<^sup>> = \<guillemotleft>tr\<^sub>0\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e))"
    by pred_auto
  also have "\<dots> =
             (\<Sqinter> tt\<^sub>1 tt\<^sub>2. (P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>)
                 \<and> (tr\<^sup>> = tr\<^sup>< + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e)"
    by pred_auto
  finally show ?thesis .
qed

lemma R2_seqr_form':
  assumes "P is R2" "Q is R2"
  shows "P ;; Q =
         (\<Sqinter> tt\<^sub>1 tt\<^sub>2. (P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>)
                   \<and> (tr\<^sup>> = tr\<^sup>< + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e)"
  using R2_seqr_form[of P Q] by (simp add: Healthy_if assms)

(* Not sure if this version of the lemma is still useful
lemma R2_seqr_form'':
  assumes "P is R2" "Q is R2"
  shows "P ;; Q =
         (\<^bold>\<exists> (tt\<^sub>1, tt\<^sub>2) \<bullet> ((P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/$tr,$tr\<acute>\<rbrakk>) ;; (Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/$tr,$tr\<acute>\<rbrakk>))
                         \<and> ($tr\<acute> =\<^sub>u $tr + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>))"
  by (subst R2_seqr_form', simp_all add: assms, rel_auto)
*)

lemma R2_tr_middle:
  assumes "P is R2" "Q is R2"
  shows "(\<Sqinter> tr\<^sub>0. (P\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup><\<rbrakk>) \<and> (\<guillemotleft>tr\<^sub>0\<guillemotright> \<le> tr\<^sup>>)\<^sub>e) = (P ;; Q)"
proof -
  have "(P ;; Q) = (\<Sqinter> tr\<^sub>0. (P\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup><\<rbrakk>))"
    by (simp add: seqr_middle)
  also have "... = (\<Sqinter> tr\<^sub>0. ((R2 P)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup>>\<rbrakk> ;; (R2 Q)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup><\<rbrakk>))"
    by (simp add: assms Healthy_if)
  also have "... = (\<Sqinter> tr\<^sub>0. ((R2 P)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup>>\<rbrakk> ;; (R2 Q)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup><\<rbrakk>) \<and> (\<guillemotleft>tr\<^sub>0\<guillemotright> \<le> tr\<^sup>>)\<^sub>e)"
    by pred_auto
  also have "... = (\<Sqinter> tr\<^sub>0. (P\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/tr\<^sup><\<rbrakk>) \<and> (\<guillemotleft>tr\<^sub>0\<guillemotright> \<le> tr\<^sup>>)\<^sub>e)"
    by (simp add: assms Healthy_if)
  finally show ?thesis ..
qed

lemma tr_contribution_sum: "\<And> tt\<^sub>1 tt\<^sub>2. (((tr\<^sup>> - tr\<^sup>< = \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright> \<and> tr\<^sup>> \<ge> tr\<^sup><)\<^sub>e :: ('t::trace,'\<alpha>,'\<gamma>) rel_rp)
                                     = (tr\<^sup>> = tr\<^sup>< + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e)"
  apply (pred_auto)
  apply (metis add.assoc diff_add_cancel_left')
  apply (simp add: add.assoc)
  apply (meson le_add order_trans)
  done

lemma R2_seqr_distribute:
  fixes P :: "('t::trace,'\<alpha>,'\<beta>) rel_rp" and Q :: "('t,'\<beta>,'\<gamma>) rel_rp"
  shows "R2(R2(P) ;; R2(Q)) = (R2(P) ;; R2(Q))"
proof -
  have "R2(R2(P) ;; R2(Q)) =
    ((\<Sqinter> tt\<^sub>1 tt\<^sub>2. (P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>)\<lbrakk>(tr\<^sup>> - tr\<^sup><)/tr\<^sup>>\<rbrakk>
      \<and> (tr\<^sup>> - tr\<^sup>< = \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e) \<and> (tr\<^sup>> \<ge> tr\<^sup><)\<^sub>e)"
    by (simp add: R2_seqr_form; pred_auto)
  also have "\<dots> =
    ((\<Sqinter> tt\<^sub>1 tt\<^sub>2. (P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>)\<lbrakk>(\<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)/tr\<^sup>>\<rbrakk>
      \<and> (tr\<^sup>> - tr\<^sup>< = \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e) \<and> (tr\<^sup>> \<ge> tr\<^sup><)\<^sub>e)"
      by pred_auto
  also have "\<dots> =
    ((\<Sqinter> tt\<^sub>1 tt\<^sub>2. (P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>)
      \<and> (tr\<^sup>> - tr\<^sup>< = \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e) \<and> (tr\<^sup>> \<ge> tr\<^sup><)\<^sub>e)"
      by pred_auto
  also have "\<dots> =
    (\<Sqinter> tt\<^sub>1 tt\<^sub>2. (P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>)
      \<and> (tr\<^sup>> - tr\<^sup>< = \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright> \<and> tr\<^sup>> \<ge> tr\<^sup><)\<^sub>e)"
    by (pred_auto; blast)
  also have "\<dots> =
    (\<Sqinter> tt\<^sub>1 tt\<^sub>2. (P\<lbrakk>0,\<guillemotleft>tt\<^sub>1\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk> ;; Q\<lbrakk>0,\<guillemotleft>tt\<^sub>2\<guillemotright>/tr\<^sup><,tr\<^sup>>\<rbrakk>)
              \<and> (tr\<^sup>> = tr\<^sup>< + \<guillemotleft>tt\<^sub>1\<guillemotright> + \<guillemotleft>tt\<^sub>2\<guillemotright>)\<^sub>e)"
    by (simp add: tr_contribution_sum)
  also have "... = (R2(P) ;; R2(Q))"
    by (simp add: R2_seqr_form)
  finally show ?thesis .
qed

lemma R2_seqr_closure [closure]:
  assumes "P is R2" "Q is R2"
  shows "(P ;; Q) is R2"
  by (metis Healthy_def' R2_seqr_distribute assms(1) assms(2))

lemma false_R2 [closure]: "false is R2"
  by (simp add: Healthy_def; pred_auto)

lemma R1_R2_commute:
  "R1(R2(P)) = R2(R1(P))"
  by pred_auto

lemma R2_R1_form: "R2(R1(P)) = R1(R2s(P))"
  by pred_auto

lemma R2s_H1_commute:
  "R2s(H1(P)) = H1(R2s(P))"
  by pred_auto

lemma R2s_H2_commute:
  "R2s(H2(P)) = H2(R2s(P))"
  by pred_auto

lemma R2_R1_seq_drop_left:
  "R2(R1(P) ;; R1(Q)) = R2(P ;; R1(Q))"
  by pred_auto

lemma R2c_idem: "R2c(R2c(P)) = R2c(P)"
  by pred_auto

lemma R2c_Idempotent [closure]: "Idempotent R2c"
  by (simp add: Idempotent_def R2c_idem)

lemma R2c_Monotonic [closure]: "Monotonic R2c"
  by (simp add: mono_def; pred_auto)

lemma R2c_H2_commute: "R2c(H2(P)) = H2(R2c(P))"
  by (simp add: H2_split R2c_disj R2c_def R2s_def)
     (pred_auto)

lemma R2c_seq: "R2c(R2(P) ;; R2(Q)) = (R2(P) ;; R2(Q))"
  by (metis (no_types, lifting) R1_R2c_commute R1_R2c_is_R2 R2_seqr_distribute R2c_idem)

lemma R2_R2c_def: "R2(P) = R1(R2c(P))"
  by pred_auto

lemma R2_comp_def: "R2 = R1 \<circ> R2c"
  by (auto simp add: R2_R2c_def)

lemma R2c_R1_seq: "R2c(R1(R2c(P)) ;; R1(R2c(Q))) = (R1(R2c(P)) ;; R1(R2c(Q)))"
  using R2c_seq[of P Q] by (simp add: R2_R2c_def)

lemma R1_R2c_seqr_distribute:
  fixes P :: "('t::trace,'\<alpha>,'\<beta>) rel_rp" and Q :: "('t,'\<beta>,'\<gamma>) rel_rp"
  assumes "P is R1" "P is R2c" "Q is R1" "Q is R2c"
  shows "R1(R2c(P ;; Q)) = P ;; Q"
  by (metis Healthy_if R1_seqr R2c_R1_seq assms)

lemma R2_R1_true:
  "R2(R1(true)) = R1(true)"
  by (simp add: R2_R1_form R2s_true)

lemma R1_true_R2 [closure]: "R1(true) is R2"
  by (simp add: Healthy_def; pred_auto)

lemma R1_R2s_R1_true_lemma:
  "R1(R2s(R1 (\<not> R2s P) ;; R1 true)) = R1(R2s((\<not> P) ;; R1 true))"
  by pred_auto

lemma R2c_healthy_R2s: "P is R2c \<Longrightarrow> R1(R2s(P)) = R1(P)"
  by (simp add: Healthy_def R1_R2s_R2c)

subsection \<open> R3: No activity while predecessor is waiting \<close>

definition R3 :: "('t::trace, '\<alpha>) hrel_rp \<Rightarrow> ('t, '\<alpha>) hrel_rp" where
[pred]: "R3(P) = (II \<triangleleft> wait\<^sup>< \<triangleright> P)\<^sub>e"

expr_constructor R3

lemma R3_idem: "R3(R3(P)) = R3(P)"
  by pred_auto

lemma R3_Idempotent [closure]: "Idempotent R3"
  by (simp add: Idempotent_def R3_idem)

lemma R3_mono: "P \<sqsubseteq> Q \<Longrightarrow> R3(P) \<sqsubseteq> R3(Q)"
  by pred_auto

lemma R3_Monotonic: "Monotonic R3"
  by (simp add: mono_def; pred_auto)

lemma R3_Continuous: "Continuous R3"
  by pred_auto

lemma R3_conj: "R3(P \<and> Q) = (R3(P) \<and> R3(Q))"
  by pred_auto

lemma R3_disj: "R3(P \<or> Q) = (R3(P) \<or> R3(Q))"
  by pred_auto

lemma R3_USUP:
  assumes "A \<noteq> {}"
  shows "R3(\<Sqinter> i \<in> A. P(i)) = (\<Sqinter> i \<in> A. R3(P(i)))"
  using assms by pred_auto

lemma R3_UINF:
  assumes "A \<noteq> {}"
  shows "R3(\<Squnion> i \<in> A. P(i)) = (\<Squnion> i \<in> A. R3(P(i)))"
  using assms by pred_auto

lemma R3_condr: "R3(P \<triangleleft> b \<triangleright> Q) = (R3(P) \<triangleleft> b \<triangleright> R3(Q))"
  by pred_auto

lemma R3_skipr: "R3(II) = II"
  by pred_auto

lemma R3_form: "R3(P) = ((wait\<^sup>< \<and> II) \<or> (\<not> wait\<^sup>< \<and> P))\<^sub>e"
  by (pred_auto; metis (full_types))

lemma wait_R3:
  "(wait\<^sup>< \<and> R3(P))\<^sub>e = (II \<and> wait\<^sup>>)\<^sub>e"
  by (pred_auto; metis (full_types))

lemma nwait_R3:
  "(\<not>wait\<^sup>< \<and> R3(P))\<^sub>e = (\<not>wait\<^sup>< \<and> P)\<^sub>e"
  by pred_auto

lemma R3_semir_form:
  "(R3(P) ;; R3(Q)) = R3(P ;; R3(Q))"
  by (pred_simp, safe; metis)

lemma R3_semir_closure:
  assumes "P is R3" "Q is R3"
  shows "(P ;; Q) is R3"
  using assms
  by (metis Healthy_def' R3_semir_form)

lemma R1_R3_commute: "R1(R3(P)) = R3(R1(P))"
  by pred_auto

lemma R2_R3_commute: "R2(R3(P)) = R3(R2(P))"
  by (pred_auto, metis add.right_neutral diff_add_cancel_left')+

subsection \<open> R4: The trace strictly increases \<close>

definition R4 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[pred]: "R4(P) = (P \<and> (tr\<^sup>< < tr\<^sup>>)\<^sub>e)"

expr_constructor R4

lemma R4_implies_R1 [closure]: "P is R4 \<Longrightarrow> P is R1"
  apply(simp add: Healthy_def)
  apply pred_auto
  using order_less_imp_le by blast

lemma R4_iff_refine:
  "P is R4 \<longleftrightarrow> (tr\<^sup>< < tr\<^sup>>)\<^sub>e \<sqsubseteq> P"
  by (pred_auto; blast)

lemma R4_idem: "R4 (R4 P) = R4 P"
  by pred_auto

lemma R4_false: "R4(false) = false"
  by pred_auto

lemma R4_conj: "R4(P \<and> Q) = (R4(P) \<and> R4(Q))"
  by pred_auto

lemma R4_disj: "R4(P \<or> Q) = (R4(P) \<or> R4(Q))"
  by pred_auto

lemma R4_is_R4 [closure]: "R4(P) is R4"
  by (simp add: Healthy_def; pred_auto)

lemma false_R4 [closure]: "false is R4"
  by (simp add: Healthy_def; pred_auto)

lemma UINF_R4_closed [closure]:
  "\<lbrakk> \<And> i. P i is R4 \<rbrakk> \<Longrightarrow> (\<Sqinter> i. P i) is R4"
  by (simp add: Healthy_def; pred_auto; blast)

lemma conj_R4_closed [closure]:
  "\<lbrakk> P is R4; Q is R4 \<rbrakk> \<Longrightarrow> (P \<and> Q) is R4"
  by (simp add: Healthy_def R4_conj)

lemma disj_R4_closed [closure]:
  "\<lbrakk> P is R4; Q is R4 \<rbrakk> \<Longrightarrow> (P \<or> Q) is R4"
  by (simp add: Healthy_def R4_disj)

lemma seq_R4_closed_1 [closure]:
  "\<lbrakk> P is R4; Q is R1 \<rbrakk> \<Longrightarrow> (P ;; Q) is R4"
  apply (simp add: Healthy_def; pred_auto)
  using less_le_trans by blast

lemma seq_R4_closed_2 [closure]:
  "\<lbrakk> P is R1; Q is R4 \<rbrakk> \<Longrightarrow> (P ;; Q) is R4"
  by (simp add: Healthy_def; pred_auto, meson order_le_less_trans)

subsection \<open> R5: The trace does not increase \<close>

definition R5 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[pred]: "R5(P) = (P \<and> (tr\<^sup>< = tr\<^sup>>)\<^sub>e)"

expr_constructor R5

lemma R5_implies_R1 [closure]: "P is R5 \<Longrightarrow> P is R1"
  by (pred_auto, metis order_refl)

lemma R5_iff_refine:
  "P is R5 \<longleftrightarrow> (tr\<^sup>< = tr\<^sup>>)\<^sub>e \<sqsubseteq> P"
  by (simp add: Healthy_def; pred_auto; blast)

lemma R5_conj: "R5(P \<and> Q) = (R5(P) \<and> R5(Q))"
  by pred_auto

lemma R5_disj: "R5(P \<or> Q) = (R5(P) \<or> R5(Q))"
  by pred_auto

lemma R4_R5: "R4 (R5 P) = false"
  by pred_auto

lemma R5_R4: "R5 (R4 P) = false"
  by pred_auto

lemma UINF_R5_closed [closure]:
  "\<lbrakk> \<And> i. P i is R5 \<rbrakk> \<Longrightarrow> (\<Sqinter> i. P i) is R5"
  by (simp add: Healthy_def; pred_auto; blast)

lemma conj_R5_closed [closure]:
  "\<lbrakk> P is R5; Q is R5 \<rbrakk> \<Longrightarrow> (P \<and> Q) is R5"
  by (simp add: Healthy_def R5_conj)

lemma disj_R5_closed [closure]:
  "\<lbrakk> P is R5; Q is R5 \<rbrakk> \<Longrightarrow> (P \<or> Q) is R5"
  by (simp add: Healthy_def R5_disj)

lemma seq_R5_closed [closure]:
  "\<lbrakk> P is R5; Q is R5 \<rbrakk> \<Longrightarrow> (P ;; Q) is R5"
  by (pred_auto, metis)

subsection \<open> RP laws \<close>

definition RP_def [pred]: "RP(P) = R1(R2c(R3(P)))"

expr_constructor RP

lemma RP_comp_def: "RP = R1 \<circ> R2c \<circ> R3"
  by (auto simp add: RP_def)

lemma RP_alt_def: "RP(P) = R1(R2(R3(P)))"
  by (metis R1_R2c_is_R2 R1_idem RP_def)

lemma RP_intro: "\<lbrakk> P is R1; P is R2; P is R3 \<rbrakk> \<Longrightarrow> P is RP"
  by (simp add: Healthy_def' RP_alt_def)

lemma RP_idem: "RP(RP(P)) = RP(P)"
  by (simp add: R1_R2c_is_R2 R2_R3_commute R2_idem R3_idem RP_def)

lemma RP_Idempotent [closure]: "Idempotent RP"
  by (simp add: Idempotent_def RP_idem)

lemma RP_mono: "P \<sqsubseteq> Q \<Longrightarrow> RP(P) \<sqsubseteq> RP(Q)"
  by (simp add: R1_R2c_is_R2 R2_mono R3_mono RP_def)

lemma RP_Monotonic: "Monotonic RP"
  by (simp add: mono_def, pred_auto)
(* would be nice to reuse RP_mono
 * apply (simp add: mono_def RP_mono) *)

lemma RP_Continuous: "Continuous RP"
  by (simp add: Continuous_comp R1_Continuous R2c_Continuous R3_Continuous RP_comp_def)

lemma RP_skip:
  "RP(II) = II"
  by (simp add: R1_skip R2c_skip_r R3_skipr RP_def)

lemma RP_skip_closure [closure]:
  "II is RP"
  by (simp add: Healthy_def' RP_skip)

lemma RP_seq_closure [closure]:
  assumes "P is RP" "Q is RP"
  shows "(P ;; Q) is RP"
proof (rule RP_intro)
  show "(P ;; Q) is R1"
    by (metis Healthy_def R1_seqr RP_def assms)
  thus "(P ;; Q) is R2"
    by (metis Healthy_def' R2_R2c_def R2c_R1_seq RP_def assms)
  show "(P ;; Q) is R3"
    by (metis (no_types, lifting) Healthy_def' R1_R2c_is_R2 R2_R3_commute R3_idem R3_semir_form RP_def assms)
qed

(*
subsection \<open> UTP theories \<close>

interpretation rea_theory: utp_theory_continuous RP
  rewrites "P \<in> carrier rea_theory.thy_order \<longleftrightarrow> P is RP"
  and "le des_theory.thy_order = (\<sqsubseteq>)"
  and "eq des_theory.thy_order = (=)"
proof -
  show "utp_theory_continuous RP"
    by (unfold_locales, simp_all add: RP_idem RP_Continuous)
qed (simp_all)

notation rea_theory.utp_top ("\<^bold>\<top>\<^sub>r")
notation rea_theory.utp_bottom ("\<^bold>\<bottom>\<^sub>r")

interpretation rea_theory_rel: utp_theory_unital RP skip_r
  by (unfold_locales, simp_all add: closure)

lemma rea_top: "\<^bold>\<top>\<^sub>r = ($wait \<and> II)"
proof -
  have "\<^bold>\<top>\<^sub>r = RP(false)"
    by (simp add: rea_theory.healthy_top)
  also have "... = ($wait \<and> II)"
    by (rel_auto, metis minus_zero_eq)
  finally show ?thesis .
qed

lemma rea_top_left_zero:
  assumes "P is RP"
  shows "(\<^bold>\<top>\<^sub>r ;; P) = \<^bold>\<top>\<^sub>r"
proof -
  have "(\<^bold>\<top>\<^sub>r ;; P) = (($wait \<and> II) ;; R3(P))"
    by (metis (no_types, lifting) Healthy_def R1_R2c_is_R2 R2_R3_commute R3_idem RP_def assms rea_top)
  also have "... = ($wait \<and> R3(P))"
    by (rel_auto)
  also have "... = ($wait \<and> II)"
    by (metis R3_skipr wait_R3)
  also have "... = \<^bold>\<top>\<^sub>r"
    by (simp add: rea_top)
  finally show ?thesis .
qed

lemma rea_bottom: "\<^bold>\<bottom>\<^sub>r = R1($wait \<Rightarrow> II)"
proof -
  have "\<^bold>\<bottom>\<^sub>r = RP(true)"
    by (simp add: rea_theory.healthy_bottom)
  also have "... = R1($wait \<Rightarrow> II)"
    by (rel_auto, metis minus_zero_eq)
  finally show ?thesis .
qed
*)

end