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

chapter \<open>Transfer Capacity\<close>
theory Effectively_Acyclic_Equal_Capacity
imports Effectively_Acyclic_Switch_Worlds
begin

paragraph \<open>Summary\<close>
text \<open>A quite technical theory that relates capacities with sums over alternating chains.
This result then is used in thm @{term cap_fg_eq_cap_fg} to transfer chains from @{term "h = h1 + h2"} to
@{term "h' = h1' + h2'"} using subflow-preserving extensions @{term "h1 \<lesssim>\<^sub>S h1'"} and
@{term "h2 \<lesssim>\<^sub>S h2'"}.\<close>

text \<open>
  Main lemma: @{term cap_fg_eq_cap_fg}
    equate capacities in two flow graphs related by subflow-preserving extensions.
  Everything else in this theory is required to prove this lemma.
\<close>

section \<open>Auxiliary Development\<close>

text \<open>This section shows many results that are required in the next section.
These results primarily show the equalities between and decompositions of sets
which are used in sum transformations.\<close>

definition "dl_lists' N l \<equiv> {xs | xs. set xs \<subseteq> N \<and> length xs < l \<and> distinct xs }"
definition "ddl_lists' x0 N l \<equiv>
  {xs | xs. hd xs = x0 \<and> xs \<noteq> [] \<and> set xs \<subseteq> N \<and> length xs < l \<and> distinct xs }"

lemma cap'_eq_dl_lists_chain:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "End_closed E" "\<forall>x y. edge_fg h x y \<in> E" "x \<in> dom_fg h" "x' \<notin> dom_fg h"
   "eff_acyclic' h" "h \<noteq> bot" "id \<in> E" "(\<lambda>_. 0) \<in> E" "z \<le> inf_fg h x"
  shows "cap' k (dom_fg h) (edge_fg h) x x' z =
    (\<Sum>ns \<in> dl_lists' (dom_fg h - {x}) k. chain (edge_fg h) (x # ns) x' z)"
proof -
  let ?e = "edge_fg h" let ?N = "dom_fg h"

  have *:
    "(\<Sum>ns\<in>{xs. xs \<in> l_lists' ?N k \<and> \<not>(x \<notin> set xs \<and> distinct xs)}. chain ?e (x # ns) x' z) = 0"
    apply (rule sum.neutral, safe)
    subgoal premises prems for xs
    proof -
      have D: "\<not> distinct (x # xs)" using prems by simp
      have "chain (edge_fg h) (x # xs) x' z = 0"
        apply (rule chain_eff_acylic_zero_not_distinct [of h "x # xs" E z])
        using prems D assms unfolding l_lists'_def by simp_all
      then show False using prems by simp
    qed
    subgoal premises prems for xs
    proof (rule ccontr)
      assume D: "\<not> distinct xs"
      have "chain (edge_fg h) (x # xs) x' z = 0"
        apply (rule chain_eff_acylic_zero_not_distinct [of h "x # xs" E z])
        using prems D assms unfolding l_lists'_def by simp_all
      then show False using prems by simp
    qed
    done

  have **: "{xs. xs \<in> l_lists' ?N k \<and> distinct xs} = dl_lists' ?N k"
    unfolding l_lists'_def dl_lists'_def by auto

  let ?X1 = "{xs. xs \<in> l_lists' ?N k \<and> x \<notin> set xs \<and> distinct xs}"
  let ?X2 = "{xs. xs \<in> l_lists' ?N k \<and> \<not>(x \<notin> set xs \<and> distinct xs)}"

  have "cap' k ?N ?e x x' z = (\<Sum>ns\<in>l_lists' ?N k. chain2 ?e x ns x') z"
    using cap'_unrolled_closed[of ?e E] assms unfolding \<delta>_def by auto
  also have "... = (\<Sum>ns\<in>l_lists' ?N k. chain2 ?e x ns x' z)"
    by (subst plus_fun_apply_iterated[OF l_lists'_finite[OF dom_fg_finite]], simp)
  also have "... = (\<Sum>ns\<in>l_lists' ?N k. chain ?e (x # ns) x' z)"
    by (subst chain2_chain, simp)
  also have "... = (\<Sum>ns\<in>?X1 \<union> ?X2. chain ?e (x # ns) x' z)"
    by (rule sum.cong, auto)
  also have "... = (\<Sum>ns\<in>?X1. chain ?e (x # ns) x' z) + (\<Sum>ns\<in>?X2. chain ?e (x # ns) x' z)"
    apply (rule sum.union_disjoint) using l_lists'_finite[of ?N k] assms by auto
  also have "... = (\<Sum>ns\<in>?X1. chain ?e (x # ns) x' z)"
    using * ** by simp
  also have "... = (\<Sum>ns\<in> dl_lists' (?N - {x}) k. chain ?e (x # ns) x' z)"
    unfolding dl_lists'_def l_lists'_def
    apply (rule sum.cong) apply blast using * ** by simp
  finally show ?thesis .
qed

text \<open>an essential property for disjoint decompositions is the alternating ownership of disjoint sets\<close>

(* TODO: can distinct be removed again? *)
definition "ll_lists' x0 N1 N2 k \<equiv>
  {xss | xss. hd (hd xss) = x0 \<and> xss \<noteq> [] \<and> distinct (concat xss) \<and> set (concat xss) \<subseteq> N1 \<union> N2 \<and>
              length (concat xss) < k \<and> alternating (segment N1) (segment N2) xss}"
definition "kl_lists' x0 N1 N2 k l \<equiv>
  {xss | xss. hd (hd xss) = x0 \<and> xss \<noteq> [] \<and> distinct (concat xss) \<and> set (concat xss) \<subseteq> N1 \<union> N2 \<and>
              length (concat xss) < k  \<and> alternating (segment N1) (segment N2) xss \<and>
              length xss = l \<and> (\<forall>xs \<in> set xss. xs \<noteq> [])}"
definition "xx_lists' N1 N2 k xs \<equiv>
  {xss | xss. distinct (concat xss) \<and> set (concat xss) \<subseteq> N1 \<union> N2 \<and> length (concat xss) < k  \<and>
              alternating (segment N1) (segment N2) xss \<and> map hd xss = xs \<and>
              (\<forall>xs \<in> set xss. xs \<noteq> [])}"
definition "yy_lists' N1 N2 k1 k2 xs \<equiv>
  {xss | xss. distinct (concat xss) \<and> set (concat xss) \<subseteq> N1 \<union> N2 \<and>
              alternating (\<lambda>xs. segment N1 xs \<and> length xs < k1) (\<lambda>xs. segment N2 xs \<and> length xs < k2) xss \<and>
              map hd xss = xs}"
definition "a_lists x0 N1 N2 k \<equiv>
  {xs | xs. hd xs = x0 \<and> xs \<noteq> [] \<and> alternating (\<lambda>x. x \<in> N1) (\<lambda>x. x \<in> N2) xs \<and>
            length xs = k \<and> distinct xs}"

definition "PL \<equiv> \<lambda>x ns zss. distinct (concat ((x # ns) # zss))"

lemma yy_lists'_cons:
  "ys \<in> yy_lists' N1 N2 k1 k2 (x # xs) \<Longrightarrow> hd (hd ys) = x"
  unfolding yy_lists'_def by auto

lemma yy_lists'_finite:
  assumes "finite N1" "finite N2"
  shows "finite (yy_lists' N1 N2 k1 k2 xs)"
proof -
  let ?L = "{xs . xs \<noteq> [] \<and> set xs \<subseteq> N1 \<union> N2 \<and> distinct xs}"
  let ?LL = "{xs . set xs \<subseteq> N1 \<union> N2 \<and> length xs \<le> card (N1 \<union> N2)}"
  let ?X = "{xss . set (concat xss) \<subseteq> N1 \<union> N2 \<and> (\<forall>xs \<in> set xss. xs \<noteq> []) \<and> distinct (concat xss)}"
  let ?Y = "{xss . set xss \<subseteq> ?L \<and> length xss \<le> card (N1 \<union> N2)}"

  have L_LL: "?L \<subseteq> ?LL"
    using distinct_length_le assms by auto
  have F: "finite ?LL"
    using finite_lists_length_le[OF finite_UnI[OF assms(1) assms(2)]]
    by simp
  have F: "finite ?L"
    by (fact rev_finite_subset[OF F L_LL])

  have S: "yy_lists' N1 N2 k1 k2 xs \<subseteq> ?X"
    unfolding yy_lists'_def using alternating_props by auto

  have T: "?X \<subseteq> ?Y"
    apply safe
       apply auto[1]
      apply auto[1]
    using distinct_from_concat apply blast
    subgoal for xss
      using distinct_length_le[of "concat xss" "N1 \<union> N2"] assms length_length_concat[of xss] by simp
    done

  have F: "finite ?Y"
    using finite_lists_length_le[OF F] by blast

  show ?thesis
    by (fact rev_finite_subset[OF rev_finite_subset[OF F T] S])
qed

lemma chain_cap_yy_lists'_sum:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "alternating (\<lambda>x. x \<in> dom_fg h1) (\<lambda>x. x \<in> dom_fg h2) xs" "eff_acyclic' h"
    "xs \<noteq> []" "distinct xs" "set xs \<subseteq> dom_fg h" "y \<notin> dom_fg h" "h = h1 + h2" "h \<noteq> bot"
    "End_closed E" "\<forall>x y. edge_fg h x y \<in> E" "id \<in> E" "(\<lambda>_. 0) \<in> E"
    "\<forall>x y. edge_fg h1 x y \<in> E" "\<forall>x y. edge_fg h2 x y \<in> E" "eff_acyclic' h1" "eff_acyclic' h2"
    "z \<le> inf_fg h1 (hd xs)"
  shows "(\<Sum>zss \<in> yy_lists' (dom_fg h1) (dom_fg h2) (card (dom_fg h1) + 1) (card (dom_fg h2) + 1) xs.
            chains (edge_fg h) zss y z) =
         chain (alt_cap_hd_fg h1 h2) xs y z"
  using assms
proof (induction xs arbitrary: z rule: alternating_induct'_symmetric[where a=h1 and b=h2])
  case (empty h1 h2)
  then show ?case by simp
next
  case (base h1 h2 x)
  then have *: "x \<in> dom_fg h1" "x \<notin> dom_fg h2" "dom_fg h = dom_fg h1 \<union> dom_fg h2"
    using plus_fg_dom_un plus_fg_dom_disj by blast+
  let ?e1 = "edge_fg h1" let ?N1 = "dom_fg h1" let ?k1 = "card ?N1" let ?N2 = "dom_fg h2"
  let ?k2 = "card ?N2" let ?N2 = "dom_fg h2"

  have EQ: "Cons x ` dl_lists' (?N1 - {x}) ?k1 = concat ` yy_lists' ?N1 ?N2 (?k1 + 1) (?k2 + 1) [x]"
  proof
    show "(#) x ` dl_lists' (?N1 - {x}) (card ?N1) \<subseteq> concat ` yy_lists' ?N1 ?N2 (?k1 + 1) (?k2 + 1) [x]"
      unfolding dl_lists'_def yy_lists'_def
    proof (safe, goal_cases)
      case (1 x' xa xs)
      let ?xss = "[x # xs]"
      show ?case
        unfolding yy_lists'_def image_def
        apply (simp, rule exI[where x="?xss"]) using * 1 by auto
    qed
    show "concat ` yy_lists' ?N1 ?N2 (?k1 + 1) (?k2 + 1) [x] \<subseteq> (#) x ` dl_lists' (?N1 - {x}) (card ?N1)"
      unfolding yy_lists'_def dl_lists'_def image_def
      apply safe
      subgoal for xa xaa xss z zs
        apply (rule bexI[where x="tl z"], simp, simp, intro conjI)
          apply (metis Diff_empty Diff_eq_empty_iff base.hyps(2) distinct.simps(2) hd_Cons_tl
                 insert_Diff1 list.simps(15) subset_Diff_insert)
         apply (metis diff_Suc_less length_greater_0_conv less_SucE less_imp_diff_less)
        using distinct_tl by blast
      done
  qed

  have inf: "z \<le> inf_fg h1 x" using inf_fg_le_inf_fg[of h1 h2 x E] base by simp

  have "cap' ?k1 ?N1 ?e1 x y z = (\<Sum>ns \<in> dl_lists' (?N1 - {x}) ?k1. chain ?e1 (x # ns) y z)"
    using cap'_eq_dl_lists_chain[of E h1 x y z "card ?N1"] plus_fg_ops_exist(1)[of h1 h2] base inf
    unfolding eff_acyclic'_def by simp
  also have "... = (\<Sum>ns \<in> Cons x ` dl_lists' (?N1 - {x}) ?k1. chain ?e1 ns y z)"
    apply (rule sum.reindex_cong[symmetric, where l="Cons x"])
    by (intro inj_onI, simp_all add: dl_lists'_def)
  also have "... = (\<Sum>ns \<in> concat ` yy_lists' ?N1 ?N2 (?k1 + 1) (?k2 + 1) [x]. chain ?e1 ns y z)"
    using EQ by simp
  also have "... = (\<Sum>nss \<in> yy_lists' ?N1 ?N2 (?k1 + 1) (?k2 + 1) [x]. chain ?e1 (concat nss) y z)"
    apply (rule sum.reindex_cong[where l=concat])
    by (intro inj_onI, auto simp: yy_lists'_def)
  also have "... = (\<Sum>nss \<in> yy_lists' ?N1 ?N2 (?k1 + 1) (?k2 + 1) [x]. chains ?e1 nss y z)"
    apply (rule sum.cong, simp) using chain_concat_chains unfolding yy_lists'_def by auto
  also have "... = (\<Sum>nss \<in> yy_lists' ?N1 ?N2 (?k1 + 1) (?k2 + 1) [x]. chains (edge_fg h) nss y z)"
    apply (rule sum.cong, simp)
    subgoal for xss
      using chains_cong[OF edge_fg_plus_fg_on1[of h1 h2], of xss y z] base
      unfolding yy_lists'_def by auto
    done
  finally show ?case
    using * by simp
next
  case (step h1 h2 x y' zs)
  then have *: "x \<in> dom_fg h1" "x \<notin> dom_fg h2" "dom_fg h = dom_fg h1 \<union> dom_fg h2"
    "dom_fg h1 \<inter> dom_fg h2 = {}"
    using plus_fg_dom_un plus_fg_dom_disj by blast+
  let ?e1 = "edge_fg h1" let ?N1 = "dom_fg h1" let ?k1 = "card ?N1"
  let ?N2 = "dom_fg h2" let ?k2 = "card ?N2" let ?N2 = "dom_fg h2"

  let ?L = "\<lambda>zss. l_lists' (dom_fg h1) (card (dom_fg h1))"
  let ?L1 = "\<lambda>zss. {ns . ns \<in> l_lists' (dom_fg h1) (card (dom_fg h1)) \<and> PL x ns zss}"
  let ?L2 = "\<lambda>zss. {ns . ns \<in> l_lists' (dom_fg h1) (card (dom_fg h1)) \<and> \<not> PL x ns zss}"

  have S: "\<And>zss. ?L zss = ?L1 zss \<union> ?L2 zss"
    by auto

  have inf: "z \<le> flow_fg (h1 + h2) x"
    using inf_fg_le_flow_fg[of h1 x] flow_fg_plus_fg_on1[of h1 h2]
      plus_fg_ops_exist(1)[of h1 h2] step
    by simp

  have ZERO: "(\<Sum>zss\<in>yy_lists' ?N2 ?N1 (card ?N2 + 1) (card ?N1 + 1) (y' # zs).
      chains (edge_fg h) zss y (\<Sum>ns\<in>?L2 zss. chain (edge_fg h1) (x # ns) y' z)) = 0"
    apply (rule sum.neutral, safe)
    apply (subst fun_dist_right''[where g="chains _ _ _" and E=E])
    using step apply simp_all
     apply (rule endo_chains_closed)
    using step apply blast+
    apply clarsimp
    apply (subst chain_cong'[OF edge_fg_plus_fg_on1[of h1 h2], symmetric])
      apply blast
    unfolding l_lists'_def apply simp
    subgoal premises prems for xss xs
    proof -
      have "chains (edge_fg (h1 + h2)) xss y (chain (edge_fg (h1 + h2)) (x # xs) y' z) =
            chains (edge_fg (h1 + h2)) ((x # xs) # xss) y z"
        using prems(1) unfolding yy_lists'_def
        by (cases xss, auto)
      moreover have "chains (edge_fg (h1 + h2)) ((x # xs) # xss) y z = 0"
        apply (rule chains_eff_acylic_zero_not_distinct)
        using prems inf unfolding PL_def apply blast
        using prems apply blast
        using inf unfolding PL_def apply simp
        subgoal
          using prems apply simp
        using alternating_props prems(1) inf unfolding PL_def yy_lists'_def by blast
        using prems subgoal
          apply simp
        using alternating_props prems(1) inf unfolding PL_def yy_lists'_def by blast
        using prems inf unfolding PL_def id_def by blast+
      ultimately show ?thesis
        by simp
    qed
    done

  let ?X = "yy_lists' ?N2 ?N1 (card ?N2 + 1) (card ?N1 + 1) (y' # zs)"
  let ?X' = "yy_lists' ?N1 ?N2 (card ?N1 + 1) (card ?N2 + 1) (x # y' # zs)"

  have XL1: "?X' = (\<lambda>(zss,ns). (x # ns) # zss) ` Sigma ?X ?L1"
  proof (safe, goal_cases)
    case (1 xs)
    then show ?case
      unfolding yy_lists'_def image_def PL_def
      apply auto
      subgoal for z zs zss
        apply (rule exI[where x="zs # zss"])
        apply auto
        apply (rule exI[where x="tl z"])
        apply auto
        unfolding l_lists'_def
        subgoal premises prems
        proof -
          have "set z \<subseteq> ?N1" using prems by blast
          then have "set (tl z) \<subseteq> ?N1" by (simp add: list.set_sel(2) prems subset_code(1))
          moreover have "length (tl z) < card ?N1"
            using distinct_length_le[OF \<open>set z \<subseteq> ?N1\<close> \<open>distinct z\<close> dom_fg_finite] \<open>z \<noteq> []\<close>
            by (simp add: Suc_le_lessD)
          ultimately show ?thesis by simp
        qed
             apply (metis distinct.simps(2) hd_Cons_tl)
        using "*"(2) apply auto[1]
        apply (meson UN_I UnCI disjoint_iff_not_equal list.set_sel(1))
          apply (simp add: distinct_tl)
         apply (meson "*"(4) disjoint_iff_not_equal in_mono list.set_sel(2))
        by (meson UN_I UnCI disjoint_iff_not_equal list.set_sel(2))
      done
  next
    case (2 z a b)
    then show ?case
      unfolding yy_lists'_def l_lists'_def PL_def
      apply safe
      apply (rule_tac x="(x # b) # z # zsa" in exI)
      using * by auto
  qed

  have "cap_fg h1 (hd [x]) y' z \<le> cap_fg h1 (hd [x]) y' (inf_fg h1 (hd [x]))"
    apply (rule pos_endo_mono'_closed[where f="cap_fg h1 (hd [x]) y'" and E=E])
    using inf_fg_le_inf_fg[of h1 h2 x E] step apply simp
    by (rule endo_cap', auto simp: step)
  also have "... \<le> inf_fg h2 y'"
    using cap'_fg_inf_fg_fg_le_inf_fg[of h h1 h2 "[x]" E y'] step by simp
  finally have inf: "cap_fg h1 (hd [x]) y' z \<le> inf_fg h2 y'" .

  have "chain (alt_cap_hd_fg h1 h2) (x # y' # zs) y z =
        chain (alt_cap_hd_fg h1 h2) (y' # zs) y (cap_fg h1 x y' z)"
    using step by simp
  also have "... = (\<Sum>zss\<in>yy_lists' ?N2 ?N1 (card ?N2 + 1) (card ?N1 + 1) (y' # zs).
          chains (edge_fg h) zss y (cap_fg h1 x y' z))"
    apply (subst alt_cap_hd_fg_sym', simp add: *)
    apply (subst step.IH[symmetric])
    using step inf unfolding id_def
                    apply blast+
    using step inf apply simp
    using step inf apply simp
    using step inf ac_simps unfolding id_def apply blast+
    using step inf by (simp_all add: algebra_simps)
  also have "... = (\<Sum>zss\<in>yy_lists' ?N2 ?N1 (card ?N2 + 1) (card ?N1 + 1) (y' # zs).
          chains (edge_fg h) zss y (\<Sum>ns\<in>?L zss. chain (edge_fg h1) (x # ns) y' z))"
    apply (subst cap'_unrolled_closed'[OF dom_fg_finite _ \<open>End_closed E\<close>])
    using step apply simp
    using step apply simp
    using step unfolding id_def apply simp
    using step apply simp
    using step unfolding \<delta>_def apply simp
    by (subst plus_fun_apply_iterated[OF l_lists'_finite[OF dom_fg_finite]], simp)
  also have "... = (\<Sum>zss\<in>yy_lists' ?N2 ?N1 (card ?N2 + 1) (card ?N1 + 1) (y' # zs).
          chains (edge_fg h) zss y (\<Sum>ns\<in>?L1 zss \<union> ?L2 zss. chain (edge_fg h1) (x # ns) y' z))"
    apply (rule sum.cong, simp)
    subgoal for zss by (subst S[of zss], simp)
    done
  also have "... = (\<Sum>zss\<in>?X. chains (edge_fg h) zss y ((\<Sum>ns\<in>?L1 zss. chain (edge_fg h1) (x # ns) y' z) +
                                                        (\<Sum>ns\<in>?L2 zss. chain (edge_fg h1) (x # ns) y' z)))"
    by (subst sum.union_disjoint, auto)
  also have "... = (\<Sum>zss\<in>?X. chains (edge_fg h) zss y (\<Sum>ns\<in>?L1 zss. chain (edge_fg h1) (x # ns) y' z)) +
                   (\<Sum>zss\<in>?X. chains (edge_fg h) zss y (\<Sum>ns\<in>?L2 zss. chain (edge_fg h1) (x # ns) y' z)) "
    apply (subst endo_sum_closed[where f="chains _ _ _"])
      apply (rule endo_chains_closed)
    using step apply blast+
    by (rule sum.distrib)
  also have "... = (\<Sum>zss\<in>?X. chains (edge_fg h) zss y (\<Sum>ns\<in>?L1 zss. chain (edge_fg h1) (x # ns) y' z))"
    using ZERO by simp
  also have "... = (\<Sum>zss\<in>?X. \<Sum>ns\<in>?L1 zss. chains (edge_fg h) zss y (chain (edge_fg h1) (x # ns) y' z))"
    apply (rule sum.cong[OF _ fun_dist_right''[where E=E]], simp_all add: step)
    apply (rule endo_chains_closed)
    using step unfolding id_def by blast+
  also have "... = (\<Sum>zss\<in>?X. \<Sum>ns\<in>?L1 zss. chains (edge_fg h) ((x # ns) # zss) y z)"
    apply (rule sum.cong[OF _ sum.cong], simp, simp)
    apply (case_tac zss, simp)
    unfolding yy_lists'_def apply simp
    using step apply simp
    by (subst chain_cong'[OF edge_fg_plus_fg_on1[of h1 h2], symmetric], simp_all add: l_lists'_def)
  also have "... = (\<Sum>(zss,ns)\<in>Sigma ?X ?L1. chains (edge_fg h) ((x # ns) # zss) y z)"
    apply (rule sum.Sigma)
    apply (rule yy_lists'_finite[OF dom_fg_finite dom_fg_finite])
    by simp
  also have "... = (\<Sum>zss\<in>(\<lambda>(zss,ns). (x # ns) # zss) ` Sigma ?X ?L1. chains (edge_fg h) zss y z)"
    by (rule sum.reindex_cong[where l="\<lambda>(zss,ns). (x # ns) # zss", symmetric], auto intro: inj_onI)
  also have "... = (\<Sum>zss\<in>?X'. chains (edge_fg h) zss y z)"
    by (subst XL1, simp)
  finally show ?case by simp
qed

lemma dl_lists'_eq_concat_ll_lists':
  assumes "x0 \<in> N1"
  shows "ddl_lists' x0 (N1 \<union> N2) k = concat ` ll_lists' x0 N1 N2 k"
proof (standard, goal_cases)
  case 1 show ?case
  proof (standard, goal_cases)
    case (1 xs)
    then have *: "set xs \<subseteq> N1 \<union> N2" "length xs < k" "distinct xs" "hd xs = x0" "xs \<noteq> []"
      unfolding ddl_lists'_def by auto
    moreover have
      "\<exists>xss. concat xss = xs \<and> xss \<noteq> [] \<and> (\<forall>xs\<in>set xss. xs \<noteq> []) \<and>
             alternating (segment N1) (segment N2) xss"
      apply (rule split_segments[of xs N1 N2])
      using assms * by simp_all
    ultimately obtain xss where **:
      "concat xss = xs \<and> xss \<noteq> [] \<and> (\<forall>xs\<in>set xss. xs \<noteq> []) \<and>
       alternating (segment N1) (segment N2) xss"
      using split_segments[of xs N1 N2] by auto
    then have "xss \<in> ll_lists' x0 N1 N2 k"
      using * ** unfolding ll_lists'_def
      apply clarsimp
      using hd_hd_concat_hd by blast
    then show ?case
      using ** unfolding ll_lists'_def by auto
  qed
next
  case 2 show ?case
    unfolding ll_lists'_def ddl_lists'_def
    apply auto
         apply (metis (mono_tags, lifting) alternating.simps(2) concat.simps(2) hd_Cons_tl hd_append2)
        apply (metis (mono_tags, lifting) alternating.simps(2) hd_Cons_tl hd_in_set)
    by auto[1]
qed

lemma ll_lists'_UN_kl_lists':
  "ll_lists' x0 N1 N2 l = (\<Union>k \<in> {0..<l}. kl_lists' x0 N1 N2 l k)"
proof
  show "ll_lists' x0 N1 N2 l \<subseteq> \<Union> (kl_lists' x0 N1 N2 l ` {0..<l})"
    unfolding ll_lists'_def kl_lists'_def
    using length_concat_le_length alternating_props by fastforce+

  show "\<Union> (kl_lists' x0 N1 N2 l ` {0..<l}) \<subseteq> ll_lists' x0 N1 N2 l"
    unfolding kl_lists'_def ll_lists'_def by auto
qed

lemma alternating_hd:
  assumes "alternating P Q xs" "alternating P Q xs \<Longrightarrow> alternating P' Q' (map hd xs)"
    "alternating Q P xs \<Longrightarrow> alternating Q' P' (map hd xs)"
  shows "alternating P' Q' (map hd xs)"
  using assms disj_forward by blast

lemma UN_kl_lists'_UN_UN_a_lists:
  "(\<Union>k \<in> {0..<l}. kl_lists' x0 N1 N2 l k) =
   (\<Union>k \<in> {0..<l}. \<Union>xs \<in> a_lists x0 N1 N2 k. xx_lists' N1 N2 l xs)"
proof
  have blub1: "\<And>xss. alternating (segment N1) (segment N2) xss
    \<Longrightarrow> alternating (\<lambda>x. x \<in> N1) (\<lambda>x. x \<in> N2) (map hd xss)"
    subgoal for xss
      by (induction xss arbitrary: N1 N2, simp, auto)
    done
  have blub2:"\<And>xss. alternating (segment N2) (segment N1) xss
    \<Longrightarrow> alternating (\<lambda>x. x \<in> N2) (\<lambda>x. x \<in> N1) (map hd xss)"
    subgoal for xss
      by (induction xss arbitrary: N2 N1, simp, auto)
    done

  show "\<Union> (kl_lists' x0 N1 N2 l ` {0..<l})
    \<subseteq> (\<Union>k\<in>{0..<l}. \<Union>xs\<in>a_lists x0 N1 N2 k. xx_lists' N1 N2 l xs)"
  proof (safe, goal_cases)
    case (1 xss k)
    then show ?case
      apply auto
      apply (rule bexI[where x=k])
       apply (rule bexI[where x="map hd xss"])
      unfolding xx_lists'_def kl_lists'_def a_lists_def apply simp_all
      apply (intro conjI)
        apply (simp add: hd_map)
       apply (rule alternating_hd[where P="segment N1" and Q="segment N2"], blast)
      using blub1 blub2 distinct_map_hd by auto
  qed

  show "(\<Union>k\<in>{0..<l}. \<Union>xs\<in>a_lists x0 N1 N2 k. xx_lists' N1 N2 l xs) \<subseteq> \<Union> (kl_lists' x0 N1 N2 l ` {0..<l})"
    unfolding a_lists_def kl_lists'_def xx_lists'_def
    by (clarsimp, metis hd_map)
qed

lemma xx_lists'_eq_yy_lists':
  assumes "l > card (N1 \<union> N2)" "finite N1" "finite N2" "k > card N1" "kk > card N2" "N1 \<inter> N2 = {}"
  shows "xx_lists' N1 N2 l xs = yy_lists' N1 N2 k kk xs"
proof
  have A1: "alternating (segment N1) (segment N2) xss \<Longrightarrow> distinct (concat xss) \<Longrightarrow>
    alternating (\<lambda>xs. segment N1 xs \<and> length xs < k) (\<lambda>xs. segment N2 xs \<and> length xs < kk) xss"
    for xss
  proof (induction xss rule: alternating_induct'[where a=N1 and aa=k and b=N2 and bb=kk])
    case emptyP
    then show ?case by simp
  next
    case emptyQ
    then show ?case by simp
  next
    case (baseP xs)
    then show ?case using distinct_length_le[of xs N1] assms by simp
  next
    case (baseQ xs)
    then show ?case using distinct_length_le[of xs N2] assms by simp
  next
    case (stepP xs ys zss)
    then show ?case using distinct_length_le[of xs N1] assms by simp
  next
    case (stepQ xs ys zss)
    then show ?case using distinct_length_le[of xs N2] assms by simp
  qed

  have A3: "alternating (\<lambda>xs. set xs \<subseteq> N1 \<and> xs \<noteq> [] \<and> length xs < k) (\<lambda>xs. set xs \<subseteq> N2 \<and> xs \<noteq> [] \<and> length xs < kk) xss \<Longrightarrow>
        alternating (segment N1) (segment N2) xss \<and> (\<forall>xs\<in>set xss. xs \<noteq> [])" for xss
    apply (induction xss rule: alternating_induct'[where a=N1 and aa=k and b=N2 and bb=kk])
    using assms by simp_all

  show "xx_lists' N1 N2 l xs \<subseteq> yy_lists' N1 N2 k kk xs"
    unfolding yy_lists'_def xx_lists'_def
    apply safe
     apply (rule_tac x=xss in exI, simp)
    using A1 by simp

  show "yy_lists' N1 N2 k kk xs \<subseteq> xx_lists' N1 N2 l xs"
    unfolding yy_lists'_def xx_lists'_def
    apply safe
     apply (rule_tac x=xss in exI)
    subgoal for x xss
      using distinct_length_le[of "concat xss" "N1 \<union> N2"] assms apply simp
      apply (intro conjI)
      using A3 by blast+
    done
qed

lemma Cons_dl_lists'_ddl_lists':
  assumes "x \<in> N"
  shows "Cons x ` dl_lists' (N - {x}) k = ddl_lists' x N (k + 1)"
  using assms
  unfolding dl_lists'_def ddl_lists'_def image_def
  apply auto
  apply (rule_tac x="tl xa" in exI, auto)
     apply (simp add: list.set_sel(2) subsetD)
    apply (metis distinct.simps(2) hd_Cons_tl)
   apply (metis diff_Suc_less length_greater_0_conv less_antisym less_imp_diff_less)
  using distinct_tl by metis

lemma a_lists_finite:
  assumes "finite N1" "finite N2"
  shows "finite (a_lists x0 N1 N2 k)"
proof -
  have "a_lists x0 N1 N2 k \<subseteq> k_lists (N1 \<union> N2) k"
    unfolding a_lists_def k_lists_def apply auto
    using alternating_props by blast+
  then show ?thesis
    using k_lists_finite[OF finite_UnI[OF \<open>finite N1\<close> \<open>finite N2\<close>]] finite_subset by blast
qed

lemma alternating_concat_inj_False:
  assumes "alternating (\<lambda>xs. segment N1 xs \<and> length xs < k1) (\<lambda>xs. segment N2 xs \<and> length xs < k2) xss"
    "alternating (\<lambda>xs. segment N2 xs \<and> length xs < k1) (\<lambda>xs. segment N1 xs \<and> length xs < k2) yss"
    "concat xss = concat yss"  "N1 \<inter> N2 = {}" "xss \<noteq> []" "yss \<noteq> []"
  shows False
proof -
  from assms have A: "hd (hd xss) \<in> N1" apply (cases xss) using alternating_props by auto
  from assms have B: "hd (hd yss) \<in> N2" apply (cases yss) using alternating_props by auto

  from assms have "hd (hd xss) = hd (hd yss)"
    using alternating_props[where xs=xss] alternating_props[where xs=yss]
    by (smt alternating.elims(2) concat.simps(2) hd_append2 list.sel(1))
  then show False using assms A B by auto
qed

lemma alternating_concat_inj:
  assumes "alternating (\<lambda>xs. segment N1 xs \<and> length xs < k1) (\<lambda>xs. segment N2 xs \<and> length xs < k2) xss"
    "alternating (\<lambda>xs. segment N1 xs \<and> length xs < k1) (\<lambda>xs. segment N2 xs \<and> length xs < k2) yss"
    "concat xss = concat yss"  "N1 \<inter> N2 = {}"
  shows "xss = yss"
  using assms
proof (induction xss yss arbitrary: N1 N2 k1 k2 rule: list_induct2')
  case 1
  then show ?case by simp
next
  case (2 x xs)
  then show ?case by simp
next
  case (3 y ys)
  then show ?case by simp
next
  case (4 xs xss ys yss)
  have **: "xs = ys"
  proof (rule ccontr, goal_cases)
    case 1
    then show ?case
    proof (cases "length xs = length ys")
      case True
      then obtain n where "xs!n \<noteq> ys!n" using "1" nth_equalityI by blast
      then show ?thesis using 4 True by auto
    next
      case False
      then show ?thesis
      proof (cases "length xs < length ys")
        case True
        with 1 4 have *: "ys!(length xs) \<in> N1" "xss \<noteq> []" by auto
        have **: "alternating (segment N2) (segment N1) xss" using 1 4 True
          apply (cases "xs # xss", simp, simp) by (rule alternating_map_fwd, blast+)
        then have ***: "hd (hd (xss)) \<in> N2" using 1 4 True * by (cases xss, auto)
        have "\<forall>xs \<in> set xss. xs \<noteq> []" using ** alternating_props[where xs=xss] by auto
        then  have A: "hd (hd xss) = concat (xs # xss) ! (length xs) "
          using 1 4 True * concat_cons_length_hd_hd[of xss xs] by simp
        then have AA: "concat (ys # yss) ! (length xs) = hd (hd xss)" using 4 by simp
        have "concat (ys # yss) ! (length xs) = ys ! (length xs)"
          using True by (simp add: nth_append)
        then show False using *** ** * A AA 4 by auto
      next
        case False
        then have False: "length ys < length xs" using False \<open>length xs \<noteq> length ys\<close> by simp
        with 1 4 have *: "xs!(length ys) \<in> N1" "yss \<noteq> []" by auto
        have **: "alternating (segment N2) (segment N1) yss" using 1 4 False
          apply (cases "ys # yss", simp, simp) by (rule alternating_map_fwd, blast+)
        then have ***: "hd (hd (yss)) \<in> N2" using 1 4 False * by (cases yss, auto)
        have "\<forall>xs \<in> set yss. xs \<noteq> []" using ** alternating_props[where xs=yss] by auto
        then  have A: "hd (hd yss) = concat (ys # yss) ! (length ys) "
          using 1 4 False * concat_cons_length_hd_hd[of yss ys] by simp
        then have AA: "concat (xs # xss) ! (length ys) = hd (hd yss)" using 4 by simp
        have "concat (xs # xss) ! (length ys) = xs ! (length ys)"
          using False by (simp add: nth_append)
        then show False using *** ** * A AA 4 by auto
      qed
    qed
  qed
  with 4 have *: "concat xss = concat yss" by simp
  have "xss = yss"
    apply (rule "4.IH"[of N2 k2 N1 k1])
    using 4 * by auto
  then show ?case
    using ** by simp
qed

text \<open>Main auxiliary result: decompose capacity into sum of alternating chains\<close>

lemma cap_fg_to_sums:
  fixes E :: "('a \<Rightarrow> 'a :: pos_cancel_comm_monoid_add) set"
  assumes "m \<le> inf_fg h x" "x \<in> dom_fg h1" "x' \<notin> dom_fg h" "h = h1 + h2""h \<noteq> bot"
    "eff_acyclic' h" "eff_acyclic' h1" "eff_acyclic' h2"
    "End_closed E" "\<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" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "cap_fg h x x' m =
    (\<Sum>k\<in>{0..<card (dom_fg h) + 1}.
      \<Sum>xs \<in> a_lists x (dom_fg h1) (dom_fg h2) k. chain (alt_cap_hd_fg h1 h2) xs x' m)"
proof -
  let ?N = "dom_fg h" let ?e = "edge_fg h" let ?f = "flow_fg h"
  let ?N1 = "dom_fg h1" let ?N2 = "dom_fg h2"

  have D: "dom_fg h = dom_fg h1 \<union> dom_fg h2" "dom_fg h1 \<inter> dom_fg h2 = {}" using assms by auto
  then have "x \<notin> ?N2" using assms by blast
  then have DD: "dom_fg h1 - {x} \<union> dom_fg h2 = dom_fg h1 \<union> dom_fg h2 - {x}" by auto
  have DDD: "x \<in> dom_fg (h1 + h2)" using assms by simp

  have "cap_fg h x x' m = (\<Sum>ns\<in>dl_lists' (?N - {x}) (card ?N). chain ?e (x # ns) x' m)"
    using cap'_eq_dl_lists_chain[of E h x x' m] assms unfolding eff_acyclic'_def by simp
  also have "... = (\<Sum>ns\<in>Cons x ` dl_lists' (?N - {x}) (card ?N). chain ?e ns x' m)"
    by (rule sum.reindex_cong[symmetric, where l="Cons x"], simp_all)
  also have "... = (\<Sum>ns\<in>ddl_lists' x ?N (card ?N + 1). chain ?e ns x' m)"
    by (rule sum.cong, rule Cons_dl_lists'_ddl_lists', simp_all add: assms DDD)
  also have "... = (\<Sum>ns\<in>concat ` ll_lists' x ?N1 ?N2 (card ?N + 1). chain ?e ns x' m)"
    apply (rule sum.cong) using assms D DD dl_lists'_eq_concat_ll_lists'[of x ?N1 ?N2 "card ?N + 1"]
    by simp_all
  also have "... =
    (\<Sum>ns\<in>concat ` (\<Union>k \<in> {0..<card ?N + 1}. kl_lists' x ?N1 ?N2 (card ?N + 1) k). chain ?e ns x' m)"
    apply (rule sum.cong) using ll_lists'_UN_kl_lists' by metis+
  also have "... = (\<Sum>ns\<in>concat ` (\<Union>k \<in> {0..<card ?N + 1}.
    \<Union>xs \<in> a_lists x ?N1 ?N2 k. xx_lists' ?N1 ?N2 (card ?N + 1) xs). chain ?e ns x' m)"
    apply (rule sum.cong) using arg_cong[OF UN_kl_lists'_UN_UN_a_lists[of x ?N1 ?N2 "card ?N + 1"]]
    by metis+
  also have "... = (\<Sum>nss\<in>(\<Union>k \<in> {0..<card ?N + 1}.
    \<Union>xs \<in> a_lists x ?N1 ?N2 k. yy_lists' ?N1 ?N2 (card ?N1 + 1) (card ?N2 + 1) xs).
      chain ?e (concat nss) x' m)"
    apply (subst xx_lists'_eq_yy_lists'[where k="card ?N1 + 1" and kk="card ?N2 + 1"])
    using assms apply simp
    using dom_fg_finite[of h1] dom_fg_finite[of h2] plus_fg_dom_disj[of h1 h2]
    using \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close> apply simp_all
    apply (rule sum.reindex_cong[where l=concat])
      apply (intro inj_onI)
    subgoal unfolding yy_lists'_def
      apply safe
      using alternating_concat_inj[of ?N1 "Suc (card ?N1)" ?N2 "Suc (card ?N2)"] by simp
    by auto
  also have "... = (\<Sum>nss\<in>(\<Union>k \<in> {0..<card ?N + 1}.
    \<Union>xs \<in> a_lists x ?N1 ?N2 k. yy_lists' ?N1 ?N2 (card ?N1 + 1) (card ?N2 + 1) xs).
      chains ?e nss x' m)"
    apply (rule sum.cong, simp) apply (subst chain_concat_chains)
    unfolding yy_lists'_def
    using alternating_props apply blast
    by simp
  also have "... = (\<Sum>k\<in>{0..<card ?N + 1}.
    \<Sum>nss \<in> (\<Union>xs \<in> a_lists x ?N1 ?N2 k. yy_lists' ?N1 ?N2 (card ?N1 + 1) (card ?N2 + 1) xs).
      chains ?e nss x' m)"
    apply (rule sum.UNION_disjoint, simp, safe)
     apply (intro finite_UN_I[OF a_lists_finite[OF dom_fg_finite dom_fg_finite]])
    apply (rule yy_lists'_finite)
    unfolding a_lists_def yy_lists'_def by auto
  also have "... = (\<Sum>k\<in>{0..<card ?N + 1}. \<Sum>xs \<in> a_lists x ?N1 ?N2 k.
                    \<Sum>nss \<in> yy_lists' ?N1 ?N2 (card ?N1 + 1) (card ?N2 + 1) xs. chains ?e nss x' m)"
    apply (rule sum.cong[OF _ sum.UNION_disjoint, simp], simp)
      apply (rule a_lists_finite[OF dom_fg_finite dom_fg_finite])
    apply safe
    apply (rule yy_lists'_finite)
    unfolding a_lists_def yy_lists'_def by auto
  also have "... = (\<Sum>k\<in>{0..<card ?N + 1}. \<Sum>xs \<in> a_lists x ?N1 ?N2 k. chain (alt_cap_hd_fg h1 h2) xs x' m)"
    apply (rule sum.cong[OF _ sum.cong[OF _ chain_cap_yy_lists'_sum]])
    using assms alternating_props D unfolding a_lists_def
    apply blast
    apply blast
    apply blast
    using assms apply blast
    apply blast
                 apply blast
    using D(1) alternating_props apply fastforce
    using assms apply blast+
    subgoal for xs xa
      apply (rule order_trans[OF _ inf_fg_le_inf_fg[of h1 h2 "hd xa"]])
      using assms by simp_all
    done
  finally show ?thesis .
qed

section \<open>Equality of capacities\<close>

text \<open>Use previous result to prove equality of capacities in flow graph sums related by
subflow-preserving extensions.

The difference to @{term Effectively_Acyclic_Switch_World} is that we have to transfer a capacity
in h=h1+h2 to a capacity h'=h1'+h2' instead of a convoluted alternating path (where we already
know the path segments within h1 and h2, respectively). Therefore, we first have to decompose
the capacity in h1+h2 into a convoluted alternating path with segments in h1 and h2, resp.,
then apply the already existing result, and convert back to a capacity.\<close>

lemma cap_fg_eq_cap_fg_case:
  fixes h h1 h2 h' h1' h2' :: "('a,'b :: pos_cancel_comm_monoid_add) fg"
  assumes "m \<le> inf_fg h x" "x \<in> dom_fg h1" "x' \<notin> dom_fg h" "h = h1 + h2" "h' = h1' + h2'" "h \<noteq> bot"
    "h' \<noteq> bot" "id \<in> E" "eff_acyclic' h" "End_closed E" "\<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" "m \<le> inf_fg h x" "m \<le> inf_fg h' x"
    "\<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"
    "dom_fg h = dom_fg h'" "dom_fg h1 = dom_fg h1'" "dom_fg h2 = dom_fg h2'" "eff_acyclic' h'"
    "eff_acyclic' h1" "eff_acyclic' h2" "(\<lambda>_. 0) \<in> E" "eff_acyclic' h1'" "eff_acyclic' h2'"
    "\<forall>n \<in> dom_fg h1. \<forall>n' \<in> -dom_fg h1. \<forall>m \<le> inf_fg h1 n. cap_fg h1 n n' m = cap_fg h1' n n' m"
    "\<forall>n \<in> dom_fg h2. \<forall>n' \<in> -dom_fg h2. \<forall>m \<le> inf_fg h2 n. cap_fg h2 n n' m = cap_fg h2' n n' m"
  shows "cap_fg h x x' m = cap_fg h' x x' m"
proof -
  let ?N = "dom_fg h" let ?e = "edge_fg h" let ?f = "flow_fg h"
  let ?N1 = "dom_fg h1" let ?N2 = "dom_fg h2"
  let ?N1' = "dom_fg h1'" let ?N2' = "dom_fg h2'" let ?N' = "dom_fg h'"

  have S1: "card ?N = card ?N'"
    using assms by simp

  have "cap_fg h x x' m =
    (\<Sum>k\<in>{0..<card ?N + 1}. \<Sum>xs \<in> a_lists x ?N1 ?N2 k. chain (alt_cap_hd_fg h1 h2) xs x' m)"
    apply (cases "x \<in> dom_fg h1")
    apply (rule cap_fg_to_sums)
    using assms by blast+
  also have "... =
    (\<Sum>k\<in>{0..<card ?N + 1}. \<Sum>xs \<in> a_lists x ?N1' ?N2' k. chain (alt_cap_hd_fg h1' h2') xs x' m)"
    apply (rule sum.cong[OF _ sum.cong], simp, simp, simp add: assms)
    unfolding a_lists_def apply simp
    subgoal for k xs
      apply (rule chains'_switch_world_chain[of h1 h2 xs h1' h2' E m, symmetric])
      using assms apply simp_all
      apply (cases xs, simp)
      using inf_fg_le_inf_fg[of h1 h2 x E] S1 by simp
    done
  also have "... = cap_fg h' x x' m"
    apply (cases "x \<in> dom_fg h1'")
    apply (subst S1, rule cap_fg_to_sums[symmetric])
    using assms by blast+
  finally show ?thesis .
qed

lemma cap_fg_eq_cap_fg:
  fixes h h1 h2 h' h1' h2' :: "('a,'b :: pos_cancel_comm_monoid_add) fg"
  assumes "m \<le> inf_fg h x" "x \<in> dom_fg h" "x' \<notin> dom_fg h" "h = h1 + h2" "h' = h1' + h2'" "h \<noteq> bot"
    "h' \<noteq> bot" "id \<in> E" "eff_acyclic' h" "End_closed E" "\<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" "m \<le> inf_fg h x" "m \<le> inf_fg h' x"
    "\<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"
    "dom_fg h = dom_fg h'" "dom_fg h1 = dom_fg h1'" "dom_fg h2 = dom_fg h2'" "eff_acyclic' h'"
    "eff_acyclic' h1" "eff_acyclic' h2" "(\<lambda>_. 0) \<in> E" "eff_acyclic' h1'" "eff_acyclic' h2'"
    "\<forall>n \<in> dom_fg h1. \<forall>n' \<in> -dom_fg h1. \<forall>m \<le> inf_fg h1 n. cap_fg h1 n n' m = cap_fg h1' n n' m"
    "\<forall>n \<in> dom_fg h2. \<forall>n' \<in> -dom_fg h2. \<forall>m \<le> inf_fg h2 n. cap_fg h2 n n' m = cap_fg h2' n n' m"
  shows "cap_fg h x x' m = cap_fg h' x x' m"
proof (cases "x \<in> dom_fg h1")
  case True
  then show ?thesis using cap_fg_eq_cap_fg_case[of m h x h1 x' h2 h' h1' h2' E] assms by blast
next
  case False
  then show ?thesis using cap_fg_eq_cap_fg_case[of m h x h2 x' h1 h' h2' h1' E] assms
    by (simp add: algebra_simps)
qed

end


section \<open>Hoare-Triples\<close>
theory Hoare_Triple
imports Run Assertions
begin

text \<open>In this theory, we define Hoare-Triples, which are our basic tool
  for specifying properties of Imperative HOL programs.\<close>

subsection \<open>Definition\<close>

text \<open>Analyze the heap before and after executing a command, to add
  the allocated addresses to the covered address range.\<close>
definition new_addrs :: "heap \<Rightarrow> addr set \<Rightarrow> heap \<Rightarrow> addr set" where
  "new_addrs h as h' = as \<union> {a. lim h \<le> a \<and> a < lim h'}"

lemma new_addr_refl[simp]: "new_addrs h as h = as"
  unfolding new_addrs_def by auto

text \<open>
  Apart from correctness of the program wrt. the pre- and post condition,
  a Hoare-triple also encodes some well-formedness conditions of the command:
  The command must not change addresses outside the address range of the
  precondition, and it must not decrease the heap limit.

  Note that we do not require that the command only reads from heap locations
  inside the precondition's address range, as this condition would be quite
  complicated to express with the heap model of Imperative/HOL, and is not
  necessary in our formalization of partial heaps, that always contain the
  information for all addresses.
\<close>
definition hoare_triple
  :: "assn \<Rightarrow> 'a Heap \<Rightarrow> ('a \<Rightarrow> assn) \<Rightarrow> bool" ("<_>/ _/ <_>")
  where
  "<P> c <Q> \<equiv> \<forall>h as \<sigma> r. (h,as)\<Turnstile>P \<and> run c (Some h) \<sigma> r
  \<longrightarrow> (let h'=the_state \<sigma>; as'=new_addrs h as h' in
    \<not>is_exn \<sigma> \<and> (h',as')\<Turnstile>Q r \<and> relH ({a . a<lim h \<and> a\<notin>as}) h h'
    \<and> lim h \<le> lim h')"

text \<open>Sanity checking theorems for Hoare-Triples\<close>
lemma
  assumes "<P> c <Q>"
  assumes "(h,as)\<Turnstile>P"
  shows hoare_triple_success: "success c h"
    and hoare_triple_effect: "\<exists>h' r. effect c h h' r \<and> (h',new_addrs h as h')\<Turnstile>Q r"
  using assms
  unfolding hoare_triple_def success_def effect_def
  apply -
  apply (auto simp: Let_def run.simps) apply fastforce
  by (metis is_exn.simps(2) not_Some_eq2 the_state.simps)

lemma hoare_tripleD:
  fixes h h' as as' \<sigma> r
  assumes "<P> c <Q>"
  assumes "(h,as)\<Turnstile>P"
  assumes "run c (Some h) \<sigma> r"
  defines "h'\<equiv>the_state \<sigma>" and "as'\<equiv>new_addrs h as h'"
  shows "\<not>is_exn \<sigma>"
  and "(h',as')\<Turnstile>Q r"
  and "relH ({a . a<lim h \<and> a\<notin>as}) h h'"
  and "lim h \<le> lim h'"
  using assms
  unfolding hoare_triple_def h'_def as'_def
  by (auto simp: Let_def)

text \<open>For garbage-collected languages, specifications usually allow for some
  arbitrary heap parts in the postcondition. The following abbreviation defines
  a handy shortcut notation for such specifications.\<close>
abbreviation hoare_triple'
  :: "assn \<Rightarrow> 'r Heap \<Rightarrow> ('r \<Rightarrow> assn) \<Rightarrow> bool" ("<_> _ <_>\<^sub>t")
  where "<P> c <Q>\<^sub>t \<equiv> <P> c <\<lambda>r. Q r * true>"

subsection \<open>Rules\<close>
text \<open>
  In this section, we provide a set of rules to prove Hoare-Triples correct.
\<close>
subsubsection \<open>Basic Rules\<close>

lemma hoare_triple_preI:
  assumes "\<And>h. h\<Turnstile>P \<Longrightarrow> <P> c <Q>"
  shows "<P> c <Q>"
  using assms
  unfolding hoare_triple_def
  by auto

lemma frame_rule:
  assumes A: "<P> c <Q>"
  shows "<P*R> c <\<lambda>x. Q x * R>"
  unfolding hoare_triple_def Let_def
  apply (intro allI impI)
  apply (elim conjE)
  apply (intro conjI)
proof -
  fix h as
  assume "(h,as) \<Turnstile> P * R"
  then obtain as1 as2 where [simp]: "as=as1\<union>as2" and DJ: "as1\<inter>as2={}"
    and M1: "(h,as1)\<Turnstile>P" and M2: "(h,as2)\<Turnstile>R"
    unfolding times_assn_def
    by (auto simp: Abs_assn_inverse)

  fix \<sigma> r
  assume RUN: "run c (Some h) \<sigma> r"
  from hoare_tripleD(1)[OF A M1 RUN] show "\<not> is_exn \<sigma>" .
  from hoare_tripleD(4)[OF A M1 RUN]
  show "lim h \<le> lim (the_state \<sigma>)" .

  from hoare_tripleD(3)[OF A M1 RUN] have
    RH1: "relH {a. a < lim h \<and> a \<notin> as1} h (the_state \<sigma>)" .
  moreover have "{a. a < lim h \<and> a \<notin> as} \<subseteq> {a. a < lim h \<and> a \<notin> as1}"
    by auto
  ultimately show "relH {a. a < lim h \<and> a \<notin> as} h (the_state \<sigma>)"
    by (blast intro: relH_subset)

  from hoare_tripleD(2)[OF A M1 RUN] have
    "(the_state \<sigma>, new_addrs h as1 (the_state \<sigma>)) \<Turnstile> Q r" .
  moreover have DJN: "new_addrs h as1 (the_state \<sigma>) \<inter> as2 = {}"
    using DJ models_in_range[OF M2]
    by (auto simp: in_range.simps new_addrs_def)
  moreover have "as2 \<subseteq> {a. a < lim h \<and> a \<notin> as1}"
    using DJ models_in_range[OF M2]
    by (auto simp: in_range.simps)
  hence "relH as2 h (the_state \<sigma>)" using RH1
    by (blast intro: relH_subset)
  with M2 have "(the_state \<sigma>, as2)\<Turnstile>R"
    by (metis mem_Collect_eq Rep_assn
      proper_iff relH_in_rangeI(2))
  moreover have "new_addrs h as (the_state \<sigma>)
    = new_addrs h as1 (the_state \<sigma>) \<union> as2"
    by (auto simp: new_addrs_def)
  ultimately show
    "(the_state \<sigma>, new_addrs h as (the_state \<sigma>)) \<Turnstile> Q r * R"
    unfolding times_assn_def
    apply (simp add: Abs_assn_inverse)
    apply blast
    done
qed

lemma false_rule[simp, intro!]: "<false> c <Q>"
  unfolding hoare_triple_def by simp

lemma cons_rule:
  assumes CPRE: "P \<Longrightarrow>\<^sub>A P'"
  assumes CPOST: "\<And>x. Q x \<Longrightarrow>\<^sub>A Q' x"
  assumes R: "<P'> c <Q>"
  shows "<P> c <Q'>"
  unfolding hoare_triple_def Let_def
  using hoare_tripleD[OF R entailsD[OF CPRE]] entailsD[OF CPOST]
  by blast

lemmas cons_pre_rule = cons_rule[OF _ ent_refl]
lemmas cons_post_rule = cons_rule[OF ent_refl, rotated]

lemma cons_rulet: "\<lbrakk>P\<Longrightarrow>\<^sub>tP'; \<And>x. Q x \<Longrightarrow>\<^sub>t Q' x; <P'> c <Q>\<^sub>t \<rbrakk> \<Longrightarrow> <P> c <Q'>\<^sub>t"
  unfolding entailst_def
  apply (rule cons_pre_rule)
  apply assumption
  apply (rule cons_post_rule)
  apply (erule frame_rule)
  by (simp add: enttD enttI)

lemmas cons_pre_rulet = cons_rulet[OF _ entt_refl]
lemmas cons_post_rulet = cons_rulet[OF entt_refl, rotated]

lemma norm_pre_ex_rule:
  assumes A: "\<And>x. <P x> f <Q>"
  shows "<\<exists>\<^sub>Ax. P x> f <Q>"
  unfolding hoare_triple_def Let_def
  apply (intro allI impI, elim conjE mod_exE)
  using hoare_tripleD[OF A]
  by blast

lemma norm_pre_pure_iff[simp]:
  "<P*\<up>b> f <Q> \<longleftrightarrow> (b \<longrightarrow> <P> f <Q>)"
  unfolding hoare_triple_def Let_def
  by auto

lemma norm_pre_pure_iff_sng[simp]:
  "<\<up>b> f <Q> \<longleftrightarrow> (b \<longrightarrow> <emp> f <Q>)"
  using norm_pre_pure_iff[where P=emp]
  by simp

lemma norm_pre_pure_rule1:
  "\<lbrakk>b \<Longrightarrow> <P> f <Q>\<rbrakk> \<Longrightarrow> <P*\<up>b> f <Q>" by simp

lemma norm_pre_pure_rule2:
  "\<lbrakk> b \<Longrightarrow> <emp> f <Q> \<rbrakk> \<Longrightarrow> <\<up>b> f <Q>" by simp

lemmas norm_pre_pure_rule = norm_pre_pure_rule1 norm_pre_pure_rule2

subsubsection \<open>Rules for Atomic Commands\<close>
lemma ref_rule:
  "<emp> ref x <\<lambda>r. r \<mapsto>\<^sub>r x>"
  unfolding one_assn_def sngr_assn_def hoare_triple_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (intro allI impI)
  apply (elim conjE run_elims)
  apply simp
  apply (auto
    simp: new_addrs_def Ref.alloc_def Let_def
    Ref.set_def Ref.get_def relH_def in_range.simps)
  done

lemma lookup_rule:
  "<p \<mapsto>\<^sub>r x> !p <\<lambda>r. p \<mapsto>\<^sub>r x * \<up>(r = x)>"
  unfolding hoare_triple_def sngr_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto elim: run_elims simp add: relH_refl in_range.simps new_addrs_def)
  done

lemma update_rule:
  "<p \<mapsto>\<^sub>r y> p := x <\<lambda>r. p \<mapsto>\<^sub>r x>"
  unfolding hoare_triple_def sngr_assn_def
  apply (auto elim!: run_update
    simp: Let_def Abs_assn_inverse new_addrs_def in_range.simps
    intro!: relH_set_ref)
  done

lemma update_wp_rule:
  "<r \<mapsto>\<^sub>r y * ((r \<mapsto>\<^sub>r x) -* (Q ()))> r := x <Q>"
  apply (rule cons_post_rule)
  apply (rule frame_rule[OF update_rule[where p=r and x=x],
    where R="((r \<mapsto>\<^sub>r x) -* (Q ()))"])
  apply (rule ent_trans)
  apply (rule ent_mp)
  by simp

lemma new_rule:
  "<emp> Array.new n x <\<lambda>r. r \<mapsto>\<^sub>a replicate n x>"
  unfolding hoare_triple_def snga_assn_def one_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps
  )
  done

lemma make_rule: "<emp> Array.make n f <\<lambda>r. r \<mapsto>\<^sub>a (map f [0 ..< n])>"
  unfolding hoare_triple_def snga_assn_def one_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps
  )
  done

lemma of_list_rule: "<emp> Array.of_list xs <\<lambda>r. r \<mapsto>\<^sub>a xs>"
  unfolding hoare_triple_def snga_assn_def one_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps
  )
  done

lemma length_rule:
  "<a \<mapsto>\<^sub>a xs> Array.len a <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = length xs)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps Array.length_def
  )
  done

text \<open>Note that the Boolean expression is placed at meta level and not
  inside the precondition. This makes frame inference simpler.\<close>
lemma nth_rule:
  "\<lbrakk>i < length xs\<rbrakk> \<Longrightarrow> <a \<mapsto>\<^sub>a xs> Array.nth a i <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = xs ! i)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps Array.length_def
  )
  done

lemma upd_rule:
  "\<lbrakk>i < length xs\<rbrakk> \<Longrightarrow>
  <a \<mapsto>\<^sub>a xs>
  Array.upd i x a
  <\<lambda>r. (a \<mapsto>\<^sub>a (list_update xs i x)) * \<up>(r = a)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps Array.length_def Array.update_def comp_def
  )
  done

lemma freeze_rule:
  "<a \<mapsto>\<^sub>a xs> Array.freeze a <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up>(r = xs)>"
  unfolding hoare_triple_def snga_assn_def
  apply (simp add: Let_def Abs_assn_inverse)
  apply (auto
    elim!: run_elims
    simp: Let_def new_addrs_def Array.get_def Array.set_def Array.alloc_def
      relH_def in_range.simps Array.length_def Array.update_def
  )
  done

lemma return_wp_rule:
  "<Q x> return x <Q>"
  unfolding hoare_triple_def Let_def
  apply (auto elim!: run_elims)
  apply (rule relH_refl)
  apply (simp add: in_range.simps)
  done

lemma return_sp_rule:
  "<P> return x <\<lambda>r. P * \<up>(r = x)>"
  unfolding hoare_triple_def Let_def
  apply (simp add: Abs_assn_inverse)
  apply (auto elim!: run_elims intro!: relH_refl intro: models_in_range)
  apply (simp add: in_range.simps)
  done

lemma raise_iff:
  "<P> raise s <Q> \<longleftrightarrow> P = false"
  unfolding hoare_triple_def Let_def
  apply (rule iffI)
  apply (unfold bot_assn_def) []
  apply rule
  apply (auto simp add: run_raise_iff) []

  apply (auto simp add: run_raise_iff) []
  done

lemma raise_rule: "<false> raise s <Q>"
  by (simp add: raise_iff)

subsubsection \<open>Rules for Composed Commands\<close>
lemma bind_rule:
  assumes T1: "<P> f <R>"
  assumes T2: "\<And>x. <R x> g x <Q>"
  shows "<P> bind f g <Q>"
  unfolding hoare_triple_def Let_def
  apply (intro allI impI)
  apply (elim conjE run_elims)
  apply (intro conjI)
proof -
  fix h as \<sigma>'' r'' \<sigma>' r'
  assume M: "(h,as) \<Turnstile> P"
    and R1: "run f (Some h) \<sigma>' r'"
    and R2: "run (g r') \<sigma>' \<sigma>'' r''"

  from hoare_tripleD[OF T1 M R1] have NO_E: "\<not> is_exn \<sigma>'"
    and M': "(the_state \<sigma>', new_addrs h as (the_state \<sigma>')) \<Turnstile> R r'"
    and RH': "relH {a. a < lim h \<and> a \<notin> as} h (the_state \<sigma>')"
    and LIM: "lim h \<le> lim (the_state \<sigma>')"
    by auto

  from NO_E have [simp]: "Some (the_state \<sigma>') = \<sigma>'" by (cases \<sigma>') auto

  from hoare_tripleD[OF T2 M', simplified, OF R2] have
    NO_E'': "\<not> is_exn \<sigma>''"
    and M'': "(the_state \<sigma>'',
      new_addrs (the_state \<sigma>')
        (new_addrs h as (the_state \<sigma>')) (the_state \<sigma>''))
      \<Turnstile> Q r''"
    and RH'':
    "relH
      {a. a < lim (the_state \<sigma>')
        \<and> a \<notin> new_addrs h as (the_state \<sigma>')
      }
      (the_state \<sigma>') (the_state \<sigma>'')"
    and LIM': "lim (the_state \<sigma>') \<le> lim (the_state \<sigma>'')" by auto

  show "\<not> is_exn \<sigma>''" by fact

  have
    "new_addrs
      (the_state \<sigma>')
      (new_addrs h as (the_state \<sigma>'))
      (the_state \<sigma>'')
    = new_addrs h as (the_state \<sigma>'')"
    using LIM LIM'
    by (auto simp add: new_addrs_def)
  with M'' show
    "(the_state \<sigma>'', new_addrs h as (the_state \<sigma>'')) \<Turnstile> Q r''"
    by simp

  note RH'
  also have "relH {a. a < lim h \<and> a \<notin> as} (the_state \<sigma>') (the_state \<sigma>'')"
    apply (rule relH_subset[OF RH''])
    using LIM LIM'
    by (auto simp: new_addrs_def)
  finally show "relH {a. a < lim h \<and> a \<notin> as} h (the_state \<sigma>'')" .

  note LIM
  also note LIM'
  finally show "lim h \<le> lim (the_state \<sigma>'')" .
qed

lemma if_rule:
  assumes  "b \<Longrightarrow> <P> f <Q>"
  assumes  "\<not>b \<Longrightarrow> <P> g <Q>"
  shows "<P> if b then f else g <Q>"
  using assms by auto

lemma if_rule_split:
  assumes  B: "b \<Longrightarrow> <P> f <Q1>"
  assumes  NB: "\<not>b \<Longrightarrow> <P> g <Q2>"
  assumes M: "\<And>x. (Q1 x * \<up>b) \<or>\<^sub>A (Q2 x * \<up>(\<not>b)) \<Longrightarrow>\<^sub>A Q x"
  shows "<P> if b then f else g <Q>"
  apply (cases b)
  apply simp_all
  apply (rule cons_post_rule)
  apply (erule B)
  apply (rule ent_trans[OF _ ent_disjI1[OF M]])
  apply simp

  apply (rule cons_post_rule)
  apply (erule NB)
  apply (rule ent_trans[OF _ ent_disjI2[OF M]])
  apply simp
  done

lemma split_rule:
  assumes P: "<P> c <R>"
  assumes Q: "<Q> c <R>"
  shows "<P \<or>\<^sub>A Q> c <R>"
  unfolding hoare_triple_def
  apply (intro allI impI)
  apply (elim conjE)
  apply simp
  apply (erule disjE)
  using hoare_tripleD[OF P] apply simp
  using hoare_tripleD[OF Q] apply simp
  done

lemmas decon_if_split = if_rule_split split_rule
  \<comment> \<open>Use with care: Complete splitting of if statements\<close>

lemma case_prod_rule:
  "(\<And>a b. x = (a, b) \<Longrightarrow> <P> f a b <Q>) \<Longrightarrow> <P> case x of (a, b) \<Rightarrow> f a b <Q>"
  by (auto split: prod.split)

lemma case_list_rule:
  "\<lbrakk> l=[] \<Longrightarrow> <P> fn <Q>; \<And>x xs. l=x#xs \<Longrightarrow> <P> fc x xs <Q> \<rbrakk> \<Longrightarrow>
  <P> case_list fn fc l <Q>"
  by (auto split: list.split)

lemma case_option_rule:
  "\<lbrakk> v=None \<Longrightarrow> <P> fn <Q>; \<And>x. v=Some x \<Longrightarrow> <P> fs x <Q> \<rbrakk>
  \<Longrightarrow> <P> case_option fn fs v <Q>"
  by (auto split: option.split)

lemma case_sum_rule:
  "\<lbrakk> \<And>x. v=Inl x \<Longrightarrow> <P> fl x <Q>;
     \<And>x. v=Inr x \<Longrightarrow> <P> fr x <Q> \<rbrakk>
  \<Longrightarrow> <P> case_sum fl fr v <Q>"
  by (auto split: sum.split)

lemma let_rule: "(\<And>x. x = t \<Longrightarrow> <P> f x <Q>) \<Longrightarrow> <P> Let t f <Q>"
  by (auto)

end


(*  Title:      HOL/HOLCF/IOA/meta_theory/Automata.thy
    Author:     Olaf Müller, Konrad Slind, Tobias Nipkow
*)

section {* The I/O automata of Lynch and Tuttle in HOLCF *}

theory Automata
imports Asig
begin

default_sort type

type_synonym
  ('a, 's) transition = "'s * 'a * 's"

type_synonym
  ('a, 's) ioa = "'a signature * 's set * ('a,'s)transition set * ('a set set) * ('a set set)"

consts

  (* IO automata *)

  asig_of        ::"('a,'s)ioa => 'a signature"
  starts_of      ::"('a,'s)ioa => 's set"
  trans_of       ::"('a,'s)ioa => ('a,'s)transition set"
  wfair_of       ::"('a,'s)ioa => ('a set) set"
  sfair_of       ::"('a,'s)ioa => ('a set) set"

  is_asig_of     ::"('a,'s)ioa => bool"
  is_starts_of   ::"('a,'s)ioa => bool"
  is_trans_of    ::"('a,'s)ioa => bool"
  input_enabled  ::"('a,'s)ioa => bool"
  IOA            ::"('a,'s)ioa => bool"

  (* constraints for fair IOA *)

  fairIOA        ::"('a,'s)ioa => bool"
  input_resistant::"('a,'s)ioa => bool"

  (* enabledness of actions and action sets *)

  enabled        ::"('a,'s)ioa => 'a => 's => bool"
  Enabled    ::"('a,'s)ioa => 'a set => 's => bool"

  (* action set keeps enabled until probably disabled by itself *)

  en_persistent  :: "('a,'s)ioa => 'a set => bool"

 (* post_conditions for actions and action sets *)

  was_enabled        ::"('a,'s)ioa => 'a => 's => bool"
  set_was_enabled    ::"('a,'s)ioa => 'a set => 's => bool"

  (* invariants *)
  invariant     :: "[('a,'s)ioa, 's=>bool] => bool"

  (* binary composition of action signatures and automata *)
  asig_comp    ::"['a signature, 'a signature] => 'a signature"
  compatible   ::"[('a,'s)ioa, ('a,'t)ioa] => bool"
  par          ::"[('a,'s)ioa, ('a,'t)ioa] => ('a,'s*'t)ioa"  (infixr "||" 10)

  (* hiding and restricting *)
  hide_asig     :: "['a signature, 'a set] => 'a signature"
  hide          :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
  restrict_asig :: "['a signature, 'a set] => 'a signature"
  restrict      :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"

  (* renaming *)
  rename_set    :: "'a set => ('c => 'a option) => 'c set"
  rename        :: "('a, 'b)ioa => ('c => 'a option) => ('c,'b)ioa"

notation (xsymbols)
  par  (infixr "\<parallel>" 10)

inductive
  reachable :: "('a, 's) ioa => 's => bool"
  for C :: "('a, 's) ioa"
  where
    reachable_0:  "s : starts_of C ==> reachable C s"
  | reachable_n:  "[| reachable C s; (s, a, t) : trans_of C |] ==> reachable C t"

abbreviation
  trans_of_syn  ("_ -_--_-> _" [81,81,81,81] 100) where
  "s -a--A-> t == (s,a,t):trans_of A"

notation (xsymbols)
  trans_of_syn  ("_ \<midarrow>_\<midarrow>_\<longrightarrow> _" [81,81,81,81] 100)

abbreviation "act A == actions (asig_of A)"
abbreviation "ext A == externals (asig_of A)"
abbreviation int where "int A == internals (asig_of A)"
abbreviation "inp A == inputs (asig_of A)"
abbreviation "out A == outputs (asig_of A)"
abbreviation "local A == locals (asig_of A)"

defs

(* --------------------------------- IOA ---------------------------------*)

asig_of_def:   "asig_of == fst"
starts_of_def: "starts_of == (fst o snd)"
trans_of_def:  "trans_of == (fst o snd o snd)"
wfair_of_def:  "wfair_of == (fst o snd o snd o snd)"
sfair_of_def:  "sfair_of == (snd o snd o snd o snd)"

is_asig_of_def:
  "is_asig_of A == is_asig (asig_of A)"

is_starts_of_def:
  "is_starts_of A ==  (~ starts_of A = {})"

is_trans_of_def:
  "is_trans_of A ==
    (!triple. triple:(trans_of A) --> fst(snd(triple)):actions(asig_of A))"

input_enabled_def:
  "input_enabled A ==
    (!a. (a:inputs(asig_of A)) --> (!s1. ? s2. (s1,a,s2):(trans_of A)))"

ioa_def:
  "IOA A == (is_asig_of A    &
             is_starts_of A  &
             is_trans_of A   &
             input_enabled A)"

invariant_def: "invariant A P == (!s. reachable A s --> P(s))"

(* ------------------------- parallel composition --------------------------*)

compatible_def:
  "compatible A B ==
  (((out A Int out B) = {}) &
   ((int A Int act B) = {}) &
   ((int B Int act A) = {}))"

asig_comp_def:
  "asig_comp a1 a2 ==
     (((inputs(a1) Un inputs(a2)) - (outputs(a1) Un outputs(a2)),
       (outputs(a1) Un outputs(a2)),
       (internals(a1) Un internals(a2))))"

par_def:
  "(A || B) ==
      (asig_comp (asig_of A) (asig_of B),
       {pr. fst(pr):starts_of(A) & snd(pr):starts_of(B)},
       {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
            in (a:act A | a:act B) &
               (if a:act A then
                  (fst(s),a,fst(t)):trans_of(A)
                else fst(t) = fst(s))
               &
               (if a:act B then
                  (snd(s),a,snd(t)):trans_of(B)
                else snd(t) = snd(s))},
        wfair_of A Un wfair_of B,
        sfair_of A Un sfair_of B)"

(* ------------------------ hiding -------------------------------------------- *)

restrict_asig_def:
  "restrict_asig asig actns ==
    (inputs(asig) Int actns,
     outputs(asig) Int actns,
     internals(asig) Un (externals(asig) - actns))"

(* Notice that for wfair_of and sfair_of nothing has to be changed, as
   changes from the outputs to the internals does not touch the locals as
   a whole, which is of importance for fairness only *)

restrict_def:
  "restrict A actns ==
    (restrict_asig (asig_of A) actns,
     starts_of A,
     trans_of A,
     wfair_of A,
     sfair_of A)"

hide_asig_def:
  "hide_asig asig actns ==
    (inputs(asig) - actns,
     outputs(asig) - actns,
     internals(asig) Un actns)"

hide_def:
  "hide A actns ==
    (hide_asig (asig_of A) actns,
     starts_of A,
     trans_of A,
     wfair_of A,
     sfair_of A)"

(* ------------------------- renaming ------------------------------------------- *)

rename_set_def:
  "rename_set A ren == {b. ? x. Some x = ren b & x : A}"

rename_def:
"rename ioa ren ==
  ((rename_set (inp ioa) ren,
    rename_set (out ioa) ren,
    rename_set (int ioa) ren),
   starts_of ioa,
   {tr. let s = fst(tr); a = fst(snd(tr));  t = snd(snd(tr))
        in
        ? x. Some(x) = ren(a) & (s,x,t):trans_of ioa},
   {rename_set s ren | s. s: wfair_of ioa},
   {rename_set s ren | s. s: sfair_of ioa})"

(* ------------------------- fairness ----------------------------- *)

fairIOA_def:
  "fairIOA A == (! S : wfair_of A. S<= local A) &
                (! S : sfair_of A. S<= local A)"

input_resistant_def:
  "input_resistant A == ! W : sfair_of A. ! s a t.
                        reachable A s & reachable A t & a:inp A &
                        Enabled A W s & s -a--A-> t
                        --> Enabled A W t"

enabled_def:
  "enabled A a s == ? t. s-a--A-> t"

Enabled_def:
  "Enabled A W s == ? w:W. enabled A w s"

en_persistent_def:
  "en_persistent A W == ! s a t. Enabled A W s &
                                 a ~:W &
                                 s -a--A-> t
                                 --> Enabled A W t"
was_enabled_def:
  "was_enabled A a t == ? s. s-a--A-> t"

set_was_enabled_def:
  "set_was_enabled A W t == ? w:W. was_enabled A w t"

declare split_paired_Ex [simp del]

lemmas ioa_projections = asig_of_def starts_of_def trans_of_def wfair_of_def sfair_of_def

subsection "asig_of, starts_of, trans_of"

lemma ioa_triple_proj:
 "((asig_of (x,y,z,w,s)) = x)   &
  ((starts_of (x,y,z,w,s)) = y) &
  ((trans_of (x,y,z,w,s)) = z)  &
  ((wfair_of (x,y,z,w,s)) = w) &
  ((sfair_of (x,y,z,w,s)) = s)"
  apply (simp add: ioa_projections)
  done

lemma trans_in_actions:
  "[| is_trans_of A; (s1,a,s2):trans_of(A) |] ==> a:act A"
apply (unfold is_trans_of_def actions_def is_asig_def)
  apply (erule allE, erule impE, assumption)
  apply simp
done

lemma starts_of_par:
"starts_of(A || B) = {p. fst(p):starts_of(A) & snd(p):starts_of(B)}"
  apply (simp add: par_def ioa_projections)
done

lemma trans_of_par:
"trans_of(A || B) = {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
             in (a:act A | a:act B) &
                (if a:act A then
                   (fst(s),a,fst(t)):trans_of(A)
                 else fst(t) = fst(s))
                &
                (if a:act B then
                   (snd(s),a,snd(t)):trans_of(B)
                 else snd(t) = snd(s))}"

apply (simp add: par_def ioa_projections)
done

subsection "actions and par"

lemma actions_asig_comp:
  "actions(asig_comp a b) = actions(a) Un actions(b)"
  apply (simp (no_asm) add: actions_def asig_comp_def asig_projections)
  apply blast
  done

lemma asig_of_par: "asig_of(A || B) = asig_comp (asig_of A) (asig_of B)"
  apply (simp add: par_def ioa_projections)
  done

lemma externals_of_par: "ext (A1||A2) =
   (ext A1) Un (ext A2)"
apply (simp add: externals_def asig_of_par asig_comp_def
  asig_inputs_def asig_outputs_def Un_def set_diff_eq)
apply blast
done

lemma actions_of_par: "act (A1||A2) =
   (act A1) Un (act A2)"
apply (simp add: actions_def asig_of_par asig_comp_def
  asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)
apply blast
done

lemma inputs_of_par: "inp (A1||A2) =
          ((inp A1) Un (inp A2)) - ((out A1) Un (out A2))"
apply (simp add: actions_def asig_of_par asig_comp_def
  asig_inputs_def asig_outputs_def Un_def set_diff_eq)
done

lemma outputs_of_par: "out (A1||A2) =
          (out A1) Un (out A2)"
apply (simp add: actions_def asig_of_par asig_comp_def
  asig_outputs_def Un_def set_diff_eq)
done

lemma internals_of_par: "int (A1||A2) =
          (int A1) Un (int A2)"
apply (simp add: actions_def asig_of_par asig_comp_def
  asig_inputs_def asig_outputs_def asig_internals_def Un_def set_diff_eq)
done

subsection "actions and compatibility"

lemma compat_commute: "compatible A B = compatible B A"
apply (simp add: compatible_def Int_commute)
apply auto
done

lemma ext1_is_not_int2:
 "[| compatible A1 A2; a:ext A1|] ==> a~:int A2"
apply (unfold externals_def actions_def compatible_def)
apply simp
apply blast
done

(* just commuting the previous one: better commute compatible *)
lemma ext2_is_not_int1:
 "[| compatible A2 A1 ; a:ext A1|] ==> a~:int A2"
apply (unfold externals_def actions_def compatible_def)
apply simp
apply blast
done

lemmas ext1_ext2_is_not_act2 = ext1_is_not_int2 [THEN int_and_ext_is_act]
lemmas ext1_ext2_is_not_act1 = ext2_is_not_int1 [THEN int_and_ext_is_act]

lemma intA_is_not_extB:
 "[| compatible A B; x:int A |] ==> x~:ext B"
apply (unfold externals_def actions_def compatible_def)
apply simp
apply blast
done

lemma intA_is_not_actB:
"[| compatible A B; a:int A |] ==> a ~: act B"
apply (unfold externals_def actions_def compatible_def is_asig_def asig_of_def)
apply simp
apply blast
done

(* the only one that needs disjointness of outputs and of internals and _all_ acts *)
lemma outAactB_is_inpB:
"[| compatible A B; a:out A ;a:act B|] ==> a : inp B"
apply (unfold asig_outputs_def asig_internals_def actions_def asig_inputs_def
    compatible_def is_asig_def asig_of_def)
apply simp
apply blast
done

(* needed for propagation of input_enabledness from A,B to A||B *)
lemma inpAAactB_is_inpBoroutB:
"[| compatible A B; a:inp A ;a:act B|] ==> a : inp B | a: out B"
apply (unfold asig_outputs_def asig_internals_def actions_def asig_inputs_def
    compatible_def is_asig_def asig_of_def)
apply simp
apply blast
done

subsection "input_enabledness and par"

(* ugly case distinctions. Heart of proof:
     1. inpAAactB_is_inpBoroutB ie. internals are really hidden.
     2. inputs_of_par: outputs are no longer inputs of par. This is important here *)
lemma input_enabled_par:
"[| compatible A B; input_enabled A; input_enabled B|]
      ==> input_enabled (A||B)"
apply (unfold input_enabled_def)
apply (simp add: Let_def inputs_of_par trans_of_par)
apply (tactic "safe_tac (Context.raw_transfer @{theory} @{theory_context Fun})")
apply (simp add: inp_is_act)
prefer 2
apply (simp add: inp_is_act)
(* a: inp A *)
apply (case_tac "a:act B")
(* a:act B *)
apply (erule_tac x = "a" in allE)
apply simp
apply (drule inpAAactB_is_inpBoroutB)
apply assumption
apply assumption
apply (erule_tac x = "a" in allE)
apply simp
apply (erule_tac x = "aa" in allE)
apply (erule_tac x = "b" in allE)
apply (erule exE)
apply (erule exE)
apply (rule_tac x = " (s2,s2a) " in exI)
apply (simp add: inp_is_act)
(* a~: act B*)
apply (simp add: inp_is_act)
apply (erule_tac x = "a" in allE)
apply simp
apply (erule_tac x = "aa" in allE)
apply (erule exE)
apply (rule_tac x = " (s2,b) " in exI)
apply simp

(* a:inp B *)
apply (case_tac "a:act A")
(* a:act A *)
apply (erule_tac x = "a" in allE)
apply (erule_tac x = "a" in allE)
apply (simp add: inp_is_act)
apply (frule_tac A1 = "A" in compat_commute [THEN iffD1])
apply (drule inpAAactB_is_inpBoroutB)
back
apply assumption
apply assumption
apply simp
apply (erule_tac x = "aa" in allE)
apply (erule_tac x = "b" in allE)
apply (erule exE)
apply (erule exE)
apply (rule_tac x = " (s2,s2a) " in exI)
apply (simp add: inp_is_act)
(* a~: act B*)
apply (simp add: inp_is_act)
apply (erule_tac x = "a" in allE)
apply (erule_tac x = "a" in allE)
apply simp
apply (erule_tac x = "b" in allE)
apply (erule exE)
apply (rule_tac x = " (aa,s2) " in exI)
apply simp
done

subsection "invariants"

lemma invariantI:
  "[| !!s. s:starts_of(A) ==> P(s);
      !!s t a. [|reachable A s; P(s)|] ==> (s,a,t): trans_of(A) --> P(t) |]
   ==> invariant A P"
apply (unfold invariant_def)
apply (rule allI)
apply (rule impI)
apply (rule_tac x = "s" in reachable.induct)
apply assumption
apply blast
apply blast
done

lemma invariantI1:
 "[| !!s. s : starts_of(A) ==> P(s);
     !!s t a. reachable A s ==> P(s) --> (s,a,t):trans_of(A) --> P(t)
  |] ==> invariant A P"
  apply (blast intro: invariantI)
  done

lemma invariantE: "[| invariant A P; reachable A s |] ==> P(s)"
  apply (unfold invariant_def)
  apply blast
  done

subsection "restrict"

lemmas reachable_0 = reachable.reachable_0
  and reachable_n = reachable.reachable_n

lemma cancel_restrict_a: "starts_of(restrict ioa acts) = starts_of(ioa) &
          trans_of(restrict ioa acts) = trans_of(ioa)"
apply (simp add: restrict_def ioa_projections)
done

lemma cancel_restrict_b: "reachable (restrict ioa acts) s = reachable ioa s"
apply (rule iffI)
apply (erule reachable.induct)
apply (simp add: cancel_restrict_a reachable_0)
apply (erule reachable_n)
apply (simp add: cancel_restrict_a)
(* <--  *)
apply (erule reachable.induct)
apply (rule reachable_0)
apply (simp add: cancel_restrict_a)
apply (erule reachable_n)
apply (simp add: cancel_restrict_a)
done

lemma acts_restrict: "act (restrict A acts) = act A"
apply (simp (no_asm) add: actions_def asig_internals_def
  asig_outputs_def asig_inputs_def externals_def asig_of_def restrict_def restrict_asig_def)
apply auto
done

lemma cancel_restrict: "starts_of(restrict ioa acts) = starts_of(ioa) &
          trans_of(restrict ioa acts) = trans_of(ioa) &
          reachable (restrict ioa acts) s = reachable ioa s &
          act (restrict A acts) = act A"
  apply (simp (no_asm) add: cancel_restrict_a cancel_restrict_b acts_restrict)
  done

subsection "rename"

lemma trans_rename: "s -a--(rename C f)-> t ==> (? x. Some(x) = f(a) & s -x--C-> t)"
apply (simp add: Let_def rename_def trans_of_def)
done

lemma reachable_rename: "[| reachable (rename C g) s |] ==> reachable C s"
apply (erule reachable.induct)
apply (rule reachable_0)
apply (simp add: rename_def ioa_projections)
apply (drule trans_rename)
apply (erule exE)
apply (erule conjE)
apply (erule reachable_n)
apply assumption
done

subsection "trans_of(A||B)"

lemma trans_A_proj: "[|(s,a,t):trans_of (A||B); a:act A|]
              ==> (fst s,a,fst t):trans_of A"
apply (simp add: Let_def par_def trans_of_def)
done

lemma trans_B_proj: "[|(s,a,t):trans_of (A||B); a:act B|]
              ==> (snd s,a,snd t):trans_of B"
apply (simp add: Let_def par_def trans_of_def)
done

lemma trans_A_proj2: "[|(s,a,t):trans_of (A||B); a~:act A|]
              ==> fst s = fst t"
apply (simp add: Let_def par_def trans_of_def)
done

lemma trans_B_proj2: "[|(s,a,t):trans_of (A||B); a~:act B|]
              ==> snd s = snd t"
apply (simp add: Let_def par_def trans_of_def)
done

lemma trans_AB_proj: "(s,a,t):trans_of (A||B)
               ==> a :act A | a :act B"
apply (simp add: Let_def par_def trans_of_def)
done

lemma trans_AB: "[|a:act A;a:act B;
       (fst s,a,fst t):trans_of A;(snd s,a,snd t):trans_of B|]
   ==> (s,a,t):trans_of (A||B)"
apply (simp add: Let_def par_def trans_of_def)
done

lemma trans_A_notB: "[|a:act A;a~:act B;
       (fst s,a,fst t):trans_of A;snd s=snd t|]
   ==> (s,a,t):trans_of (A||B)"
apply (simp add: Let_def par_def trans_of_def)
done

lemma trans_notA_B: "[|a~:act A;a:act B;
       (snd s,a,snd t):trans_of B;fst s=fst t|]
   ==> (s,a,t):trans_of (A||B)"
apply (simp add: Let_def par_def trans_of_def)
done

lemmas trans_of_defs1 = trans_AB trans_A_notB trans_notA_B
  and trans_of_defs2 = trans_A_proj trans_B_proj trans_A_proj2 trans_B_proj2 trans_AB_proj

lemma trans_of_par4:
"((s,a,t) : trans_of(A || B || C || D)) =
  ((a:actions(asig_of(A)) | a:actions(asig_of(B)) | a:actions(asig_of(C)) |
    a:actions(asig_of(D))) &
   (if a:actions(asig_of(A)) then (fst(s),a,fst(t)):trans_of(A)
    else fst t=fst s) &
   (if a:actions(asig_of(B)) then (fst(snd(s)),a,fst(snd(t))):trans_of(B)
    else fst(snd(t))=fst(snd(s))) &
   (if a:actions(asig_of(C)) then
      (fst(snd(snd(s))),a,fst(snd(snd(t)))):trans_of(C)
    else fst(snd(snd(t)))=fst(snd(snd(s)))) &
   (if a:actions(asig_of(D)) then
      (snd(snd(snd(s))),a,snd(snd(snd(t)))):trans_of(D)
    else snd(snd(snd(t)))=snd(snd(snd(s)))))"
  apply (simp (no_asm) add: par_def actions_asig_comp prod_eq_iff Let_def ioa_projections)
  done

subsection "proof obligation generator for IOA requirements"

(* without assumptions on A and B because is_trans_of is also incorporated in ||def *)
lemma is_trans_of_par: "is_trans_of (A||B)"
apply (unfold is_trans_of_def)
apply (simp add: Let_def actions_of_par trans_of_par)
done

lemma is_trans_of_restrict:
"is_trans_of A ==> is_trans_of (restrict A acts)"
apply (unfold is_trans_of_def)
apply (simp add: cancel_restrict acts_restrict)
done

lemma is_trans_of_rename:
"is_trans_of A ==> is_trans_of (rename A f)"
apply (unfold is_trans_of_def restrict_def restrict_asig_def)
apply (simp add: Let_def actions_def trans_of_def asig_internals_def
  asig_outputs_def asig_inputs_def externals_def asig_of_def rename_def rename_set_def)
apply blast
done

lemma is_asig_of_par: "[| is_asig_of A; is_asig_of B; compatible A B|]
          ==> is_asig_of (A||B)"
apply (simp add: is_asig_of_def asig_of_par asig_comp_def compatible_def
  asig_internals_def asig_outputs_def asig_inputs_def actions_def is_asig_def)
apply (simp add: asig_of_def)
apply auto
done

lemma is_asig_of_restrict:
"is_asig_of A ==> is_asig_of (restrict A f)"
apply (unfold is_asig_of_def is_asig_def asig_of_def restrict_def restrict_asig_def
           asig_internals_def asig_outputs_def asig_inputs_def externals_def o_def)
apply simp
apply auto
done

lemma is_asig_of_rename: "is_asig_of A ==> is_asig_of (rename A f)"
apply (simp add: is_asig_of_def rename_def rename_set_def asig_internals_def
  asig_outputs_def asig_inputs_def actions_def is_asig_def asig_of_def)
apply auto
apply (drule_tac [!] s = "Some ?x" in sym)
apply auto
done

lemmas [simp] = is_asig_of_par is_asig_of_restrict
  is_asig_of_rename is_trans_of_par is_trans_of_restrict is_trans_of_rename

lemma compatible_par:
"[|compatible A B; compatible A C |]==> compatible A (B||C)"
apply (unfold compatible_def)
apply (simp add: internals_of_par outputs_of_par actions_of_par)
apply auto
done

(*  better derive by previous one and compat_commute *)
lemma compatible_par2:
"[|compatible A C; compatible B C |]==> compatible (A||B) C"
apply (unfold compatible_def)
apply (simp add: internals_of_par outputs_of_par actions_of_par)
apply auto
done

lemma compatible_restrict:
"[| compatible A B; (ext B - S) Int ext A = {}|]
      ==> compatible A (restrict B S)"
apply (unfold compatible_def)
apply (simp add: ioa_triple_proj asig_triple_proj externals_def
  restrict_def restrict_asig_def actions_def)
apply auto
done

declare split_paired_Ex [simp]

end