section \<open>UGraph - undirected graph with Uprod edges\<close>

theory UGraph
  imports
    "Automatic_Refinement.Misc"
    "Collections.Partial_Equivalence_Relation"
    "HOL-Library.Uprod"
begin

subsection "Edge path"

fun epath :: "'a uprod set \<Rightarrow> 'a \<Rightarrow> ('a uprod) list \<Rightarrow> 'a \<Rightarrow> bool"  where
  "epath E u [] v = (u = v)"
| "epath E u (x#xs) v \<longleftrightarrow> (\<exists>w. u\<noteq>w \<and> Upair u w = x \<and> epath E w xs v) \<and> x\<in>E"

lemma [simp,intro!]: "epath E u [] u" by simp

lemma path_append_conv[simp]: "epath E u (p@q) v \<longleftrightarrow> (\<exists>w. epath E u p w \<and> epath E w q v)"
  apply(induct p arbitrary: u) by auto

lemma "epath E x p y \<Longrightarrow> \<exists>p. epath E y p x"
  apply(rule exI[where x="rev p"]) by simp

lemma epath_mono: "E \<subseteq> E' \<Longrightarrow> epath E u p v \<Longrightarrow> epath E' u p v"
  apply(induct p arbitrary: u) by auto

lemma epath_restrict: "set p \<subseteq> I \<Longrightarrow> epath E u p v \<Longrightarrow> epath (E\<inter>I) u p v"
  apply(induct p arbitrary: u)
  by auto

lemma assumes "A\<subseteq>A'" "~ epath A u p v" "epath A' u p v"
  shows epath_diff_edge: "(\<exists>e. e\<in>set p - A)"
proof (rule ccontr)
  assume "\<not>(\<exists>e. e \<in> set p - A)"
  then have i: "set p \<subseteq> A"
    by auto
  have ii: "A = A' \<inter> A" using assms(1) by auto
  have "epath A u p v"
    apply(subst ii)
    apply(rule epath_restrict  ) by fact+
  with assms(2) show "False" by auto
qed

lemma epath_restrict': "epath (insert e E) u p v \<Longrightarrow>  e\<notin>set p \<Longrightarrow> epath E u p v"
proof -
  assume a: "epath (insert e E) u p v" and "e\<notin>set p"
  then have b: "set p \<subseteq> E" by(auto dest: epath_subset_E)
  have e: "insert e E \<inter> E = E " by auto
  show ?thesis apply(rule epath_restrict[where I=E and E="insert e E", simplified e] )
    using a b by auto
qed

lemma epath_not_direct:
  assumes ep: "epath E u p v" and unv: "u \<noteq> v"
    and edge_notin: "Upair u v \<notin> E"
  shows "length p \<ge> 2"
proof (rule ccontr)
  from ep have setp: "set p \<subseteq> E" using epath_subset_E by fast
  assume "\<not>length p \<ge> 2"
  then have "length p <2" by auto
  moreover
  {
    assume "length p = 0"
    then have "p=[]" by auto
    with ep unv have "False" by auto
  } moreover {
    assume "length p = 1"
    then obtain e where p: "p = [e]"
      using list_decomp_1 by blast
    with ep have i: "e=Upair u v" by auto
    from p i setp and edge_notin have "False" by auto
  }
  ultimately show "False" by linarith
qed

lemma epath_decompose:
  assumes e: "epath G v p v'"
    and elem :"Upair a b \<in> set p"
  shows  "\<exists> u u' p' p'' . u \<in> {a, b} \<and> u' \<in> {a, b} \<and> epath G v p' u \<and> epath G u' p'' v' \<and>
          length p' < length p \<and> length p'' < length p"
proof -
  from elem obtain p' p'' where p: "p = p' @ (Upair a b) # p''" using in_set_conv_decomp
    by metis
  from p have "epath G v (p' @ (Upair a b) # p'') v'" using e by auto
  then obtain z z' where pr: "epath G v p' z"  "epath G z' p'' v'" and u: "Upair z z'=Upair a b"   by auto
  from u have u': "z \<in> {a, b} \<and> z' \<in> {a, b}" by auto
  have len: "length p' < length p"  "length p'' < length p" using p by auto
  from len pr u' show ?thesis by auto
qed

lemma epath_decompose':
  assumes e: "epath G v p v'"
    and elem :"Upair a b \<in> set p"
  shows  "\<exists> u u' p' p'' . Upair a b = Upair u u' \<and> epath G v p' u \<and> epath G u' p'' v' \<and>
          length p' < length p \<and> length p'' < length p"
proof -
  from elem obtain p' p'' where p: "p = p' @ (Upair a b) # p''" using in_set_conv_decomp
    by metis
  from p have "epath G v (p' @ (Upair a b) # p'') v'" using e by auto
  then obtain z z' where pr: "epath G v p' z"  "epath G z' p'' v'" and u: "Upair z z'=Upair a b"   by auto
  have len: "length p' < length p"  "length p'' < length p" using p by auto
  from len pr u show ?thesis by auto
qed

(* adapted from Julian's is_path_undir_split_distinct *)
lemma epath_split_distinct:
  assumes "epath G v p v'"
  assumes "Upair a b \<in> set p"
  shows "(\<exists>p' p'' u u'.
            epath G v p' u \<and> epath G u' p'' v' \<and>
            length p' < length p \<and> length p'' < length p \<and>
            (u \<in> {a, b} \<and> u' \<in> {a, b}) \<and>
            Upair a b \<notin> set p' \<and> Upair a b \<notin> set p'')"
  using assms
proof (induction n == "length p" arbitrary: p v v' rule: nat_less_induct)
  case 1
  obtain u u' p' p'' where u: "u \<in> {a, b} \<and> u' \<in> {a, b}"
    and p': "epath G v p' u" and p'': "epath G u' p'' v'"
    and len_p': "length p' < length p" and len_p'': "length p'' < length p"
    using epath_decompose[OF 1(2,3)] by blast
  from 1 len_p' p' have "Upair a b \<in> set p' \<longrightarrow> (\<exists>p'2 u2.
            epath G v p'2 u2 \<and>
            length p'2 < length p' \<and>
            u2 \<in> {a, b} \<and>
            Upair a b \<notin> set p'2)"
    by metis
  with len_p' p' u have p': "\<exists>p' u. epath G v p' u \<and> length p' < length p \<and>
      u \<in> {a,b} \<and> Upair a b \<notin> set p' \<and> Upair a b \<notin> set p'"
    by fastforce
  from 1 len_p'' p'' have "Upair a b \<in> set p'' \<longrightarrow> (\<exists>p''2 u'2.
            epath G u'2 p''2 v' \<and>
            length p''2 < length p'' \<and>
            u'2 \<in> {a, b} \<and>
            Upair a b \<notin> set p''2 \<and> Upair a b \<notin> set p''2)"
    by metis
  with len_p'' p'' u have "\<exists>p'' u'. epath G u' p'' v'\<and> length p'' < length p \<and>
      u' \<in> {a,b} \<and> Upair a b \<notin> set p'' \<and> Upair a b \<notin> set p''"
    by fastforce
  with p' show ?case by auto
qed

subsection "Distinct edge path"

definition "depath E u dp v \<equiv> epath E u dp v \<and> distinct dp"

lemma epath_to_depath: "set p \<subseteq> I \<Longrightarrow> epath E u p v \<Longrightarrow> \<exists>dp. depath E u dp v \<and> set dp \<subseteq> I"
proof (induction p rule: length_induct)
  case (1 p)
  hence IH: "\<And>p'. \<lbrakk>length p' < length p; set p' \<subseteq> I; epath E u p' v\<rbrakk>
    \<Longrightarrow> \<exists>p'. depath E u p' v \<and> set p' \<subseteq> I"
    and PATH: "epath E u p v"
    and set: "set p \<subseteq> I"
    by auto

  show "\<exists>p. depath E u p v \<and> set p \<subseteq> I"
  proof cases
    assume "distinct p"
    thus ?thesis using PATH set by (auto simp: depath_def)
  next
    assume "\<not>(distinct p)"
    then obtain pv1 pv2 pv3 w where p: "p = pv1@w#pv2@w#pv3"
      by (auto dest: not_distinct_decomp)
    with PATH obtain a where 1: "epath E u pv1 a" and 2:"epath E a (w#pv2@w#pv3) v" by auto
    then obtain b where ab: "w=Upair a b" "a\<noteq>b" by auto
    with 2 have "epath E b (pv2@w#pv3) v" by auto
    then obtain c where 3: "epath E b pv2 c" and 4: "epath E c (w#pv3) v" by auto
    then have cw: "c\<in>set_uprod w" by auto
    { assume "c=a"
      then have "length (pv1@w#pv3) < length p" "set (pv1@w#pv3) \<subseteq> I" "epath E u (pv1@w#pv3) v"
        using 1 4 p set by auto
      hence "\<exists>p'. depath E u p' v \<and> set p' \<subseteq> I" by (rule IH)
    }
    moreover
    { assume "c\<noteq>a"
      with ab cw have "c=b" by auto
      with 4 ab have "epath E a pv3 v" by auto
      then have "length (pv1@pv3) < length p" "set (pv1@pv3) \<subseteq> I" "epath E u (pv1@pv3) v" using p 1 set by auto
      hence "\<exists>p'. depath E u p' v \<and> set p' \<subseteq> I" by (rule IH)
    }
    ultimately show ?case by auto
  qed
qed

lemma epath_to_depath': "epath E u p v \<Longrightarrow> \<exists>dp. depath E u dp v"
  using epath_to_depath[where I="set p"] by blast

definition "decycle E u p == epath E u p u \<and> length p > 2 \<and> distinct p"

subsection "Connectivity in undirected Graphs"

definition "uconnected E \<equiv> {(u,v). \<exists>p. epath E u p v}"

lemma uconnectedempty: "uconnected {} = {(a,a)|a. True}"
  unfolding uconnected_def
  using epath.elims(2) by fastforce

lemma uconnected_refl: "refl (uconnected E)"
  by(auto simp: refl_on_def uconnected_def)

lemma uconnected_sym: "sym (uconnected E)"
  apply(clarsimp simp: sym_def uconnected_def)
  subgoal for x y p apply (rule exI[where x="rev p"]) by (auto) done

lemma uconnected_symI: "(u,v) \<in> uconnected E \<Longrightarrow> (v,u) \<in> uconnected E"
  using uconnected_sym sym_def by fast

lemma "equiv UNIV (uconnected E)"
  apply (rule equivI)
  subgoal by (auto simp: refl_on_def uconnected_def)
  subgoal apply(clarsimp simp: sym_def uconnected_def) subgoal for x y p apply (rule exI[where x="rev p"]) by auto done
  by (fact uconnected_trans)

lemma uconnected_refcl: "(uconnected E)\<^sup>* = (uconnected E)\<^sup>="
  apply(rule trans_rtrancl_eq_reflcl)
  by (fact uconnected_trans)

lemma uconnected_transcl: "(uconnected E)\<^sup>* = uconnected E"
  apply (simp only: uconnected_refcl)
  by (auto simp: uconnected_def)

lemma uconnected_mono: "A\<subseteq>A' \<Longrightarrow> uconnected A \<subseteq> uconnected A'"
  unfolding uconnected_def apply(auto)
    using epath_mono by metis

lemma findaugmenting_edge: assumes "epath E1 u p v"
  and "\<not>(\<exists>p. epath E2 u p v)"
shows "\<exists>a b. (a,b) \<notin> uconnected E2 \<and> Upair a b \<notin> E2 \<and> Upair a b \<in> E1"
  using assms
proof (induct p arbitrary: u)
  case Nil
  then show ?case by auto
next
  case (Cons a p)
  then obtain w where axy: "a=Upair u w" "u\<noteq>w" and e': "epath E1 w p v"
      and uwE1: "Upair u w \<in> E1" by auto
  show ?case
  proof (cases "a\<in>E2")
    case True
    have e2': "\<not>(\<exists>p. epath E2 w p v)"
    proof (rule ccontr, clarsimp)
      fix p2
      assume "epath E2 w p2 v"
      with True axy have "epath E2 u (a#p2) v" by auto
      with Cons(3) show False by blast
    qed
    from Cons(1)[OF e' e2'] show ?thesis .
  next
    case False
    {
      assume e2': "\<not>(\<exists>p. epath E2 w p v)"
      from Cons(1)[OF e' e2'] have ?thesis .
    } moreover {
      assume e2': "\<exists>p. epath E2 w p v"
      then obtain p1 where p1: "epath E2 w p1 v" by auto

      from False axy have "Upair u w\<notin>E2" by auto
      moreover
      have "(u,w) \<notin> uconnected E2"
      proof(rule ccontr, auto simp add: uconnected_def)
        fix p2
        assume "epath E2 u p2 w"
        with p1 have "epath E2 u (p2@p1) v" by auto
        then show "False" using Cons(3) by blast
      qed
      moreover
      note uwE1
      ultimately have ?thesis by auto
    }
    ultimately show ?thesis by auto
  qed
qed

subsection "Forest"

definition "forest E \<equiv> ~(\<exists>u p. decycle E u p)"

lemma forest_mono: "Y \<subseteq> X \<Longrightarrow> forest X \<Longrightarrow> forest Y"
  unfolding forest_def decycle_def apply (auto) using epath_mono by metis

lemma forrest2_E: assumes "(u,v) \<in> uconnected E"
  and "Upair u v \<notin> E"
  and "u \<noteq> v"
shows "~ forest (insert (Upair u v) E)"
proof -
  from assms[unfolded uconnected_def] obtain p' where "epath E u p' v" by blast
  then obtain p where ep: "epath E u p v" and dep: "distinct p" using epath_to_depath' unfolding depath_def by fast
  from ep have setp: "set p \<subseteq> E" using epath_subset_E by fast

  have lengthp: "length p \<ge> 2" apply(rule epath_not_direct) by fact+

  from epath_mono[OF _ ep] have ep': "epath (insert (Upair u v) E) u p v" by auto

  have "epath (insert (Upair u v) E) v ((Upair u v)#p) v" "length ((Upair u v)#p) > 2"  "distinct ((Upair u v)#p)"
    using ep' assms(3) lengthp dep setp assms(2) by auto
  then have "decycle (insert (Upair u v) E) v ((Upair u v)#p)" unfolding decycle_def by auto
  then show ?thesis unfolding forest_def by auto
qed

lemma insert_stays_forest_means_not_connected: assumes "forest (insert (Upair u v) E)"
  and "(Upair u v) \<notin> E"
  and "u \<noteq> v"
shows "~ (u,v) \<in> uconnected E"
  using forrest2_E assms by metis

lemma epath_singleton: "epath F a [e] b \<Longrightarrow> e = Upair a b"
  by auto

lemma forest_alt1:
  assumes " Upair a b \<in> F" "forest F" "\<And>e. e\<in>F \<Longrightarrow> proper_uprod e"
  shows "(a,b) \<notin>  uconnected (F - {Upair a b})"
proof (rule ccontr)
  from assms(1,3) have anb: "a\<noteq>b" by force
  assume "\<not> (a, b) \<notin> uconnected (F - {Upair a b})"
  then obtain p where "epath (F - {Upair a b}) a p b" unfolding uconnected_def  by blast
  then obtain p' where dp: "depath (F - {Upair a b}) a p' b" using epath_to_depath' by force
  then have ab: "Upair a b \<notin> set p'" by(auto simp: depath_def dest: epath_subset_E)
  from anb dp have n0: "length p' \<noteq> 0" by (auto simp: depath_def)
  from ab dp have n1: "length p' \<noteq> 1" by (auto simp: depath_def simp del: One_nat_def dest!: list_decomp_1)
  from n0 n1 have l: "length p' \<ge> 2" by linarith
  from dp have "epath F a p' b" by (auto intro: epath_mono simp: depath_def)
  then have e: "epath F b (Upair a b#p') b" using assms(1) anb by auto
  from dp ab have d: "distinct (Upair a b#p')" by (auto simp: depath_def)
  from d e l have "decycle F b (Upair a b#p')" by (auto simp: decycle_def)
  with assms(2) show "False" by (simp add: forest_def)
qed

lemma forest_alt2:
  assumes "\<And>e. e\<in>F \<Longrightarrow> proper_uprod e"
    and "\<And>a b. Upair a b \<in> F \<Longrightarrow> (a,b) \<notin>  uconnected (F - {Upair a b})"
  shows "forest F"
proof (rule ccontr)
  assume "\<not> forest F"
  then obtain a p where e: "epath F a p a" "length p > 2" "distinct p"
    unfolding decycle_def forest_def by auto
  then obtain b p' where p': "p = Upair a b # p'"
    by (metis Suc_1 epath.simps(2) less_imp_not_less list.size(3) neq_NilE zero_less_Suc)
  then have u: "Upair a b\<in>F" using e(1) by auto
  then have F: "(insert (Upair a b) F) = F" by auto
  have "epath (F - {Upair a b}) b p' a"
    apply(rule epath_restrict'[where e="Upair a b"]) using e  p' by (auto simp: F)
  then have "epath (F - {Upair a b}) a (rev p') b" by auto
  with   assms(2)[OF u]
  show "False" unfolding uconnected_def by blast
qed

lemma forest_alt:
  assumes "\<And>e. e\<in>F \<Longrightarrow> proper_uprod e"
  shows "forest F \<longleftrightarrow> (\<forall>a b. Upair a b \<in> F \<longrightarrow> (a,b) \<notin>  uconnected (F - {Upair a b})) "
  using assms forest_alt1 forest_alt2
  by metis

lemma augment_forest_overedges:
  assumes "F\<subseteq>E" "forest F" "(Upair u v) \<in> E" "(u,v) \<notin> uconnected F"
    and notsame: "u\<noteq>v"
  shows "forest (insert (Upair u v) F)"
  unfolding forest_def
proof (rule ccontr, clarsimp simp: decycle_def )
  fix w p
  assume d: "distinct p" and v: "epath (insert (Upair u v) F) w p w" and p: "2 < length p"

  have setep: "set p \<subseteq> insert (Upair u v) F" using epath_subset_E v
    by metis

  have uvF: "(Upair u v)\<notin>F"
  proof(rule ccontr, clarsimp)
    assume "(Upair u v) \<in> F"
    then have "epath F u [(Upair u v)] v" using notsame by auto
    then have "(u,v) \<in> uconnected F" unfolding  uconnected_def by blast
    then show "False" using assms(4) by auto
  qed
  have k: "insert (Upair u v) F \<inter> F = F" by auto

  show False
  proof (cases)
    assume "(Upair u v) \<in> set p"
    then obtain as bs where ep: "p = as @ (Upair u v) # bs" using in_set_conv_decomp
      by metis
    then have "epath (insert (Upair u v) F) w (as @ (Upair u v) # bs) w" using v by auto
    then obtain z where pr: "epath (insert (Upair u v) F) w as z"   "epath (insert (Upair u v) F) z ((Upair u v) # bs) w"   by auto
    from d ep have uvas: "(Upair u v) \<notin> set (as@bs)" by auto
    then have setasbs: "set (bs@as) \<subseteq> F" using ep setep by auto
    { assume "z=u"
      with pr have "epath (insert (Upair u v) F) w as u"   "epath (insert(Upair u v) F) v bs w" by auto
      then have "epath (insert (Upair u v) F) v (bs@as) u" by auto
      from epath_restrict[where I=F, OF setasbs this] have "epath F v (bs@as) u" using uvF by auto
      then have "(v,u) \<in> uconnected F" using uconnected_def
        by blast
      then have "(u,v) \<in> uconnected F" by (rule uconnected_symI)
    } moreover
    { assume "z\<noteq>u"
      then have "z=v" using pr(2) by auto
      with pr have "epath (insert (Upair u v) F) w as v"   "epath (insert (Upair u v) F) u bs w" by auto
      then have "epath (insert (Upair u v) F) u (bs@as) v" by auto
      from epath_restrict[where I=F, OF setasbs this] have "epath F u (bs@as) v" using uvF by auto
      then have "(u,v) \<in> uconnected F" using uconnected_def
        by fast
    }
    ultimately have "(u,v) \<in> uconnected F" by auto
    then show "False" using assms by auto
  next
    assume "(Upair u v) \<notin> set p"
    with setep have "set p \<subseteq> F" by auto
    then have "epath (insert (Upair u v) F \<inter> F) w p w" using epath_restrict[OF _ v, where I="F"] by auto
    then have "epath F w p w" using k by auto
    with \<open>forest F\<close> show "False" unfolding forest_def decycle_def using p d
      by auto
  qed
qed

subsection "uGraph locale"

locale uGraph =
  fixes E :: "'a uprod set"
    and w :: "'a uprod \<Rightarrow> 'c::{linorder, ordered_comm_monoid_add}"
  assumes ecard2: "\<And>e. e\<in>E \<Longrightarrow> proper_uprod e"
    and finiteE[simp]: "finite E"
begin

abbreviation "uconnected_on E' V \<equiv> uconnected E' \<inter> (V\<times>V)"

abbreviation "verts \<equiv> \<Union>(set_uprod ` E)"

lemma set_uprod_nonemptyY[simp]: "set_uprod x  \<noteq> {}" apply(cases x) by auto

abbreviation "uconnectedV E' \<equiv> Restr (uconnected E') verts"

lemma equiv_unconnected_on: "equiv V (uconnected_on E' V)"
  apply (rule equivI)
  subgoal by (auto simp: refl_on_def uconnected_def)
  subgoal apply(clarsimp simp: sym_def uconnected_def) subgoal for x y p apply (rule exI[where x="rev p"]) by (auto) done
  subgoal apply(clarsimp simp: trans_def uconnected_def) subgoal for x y z p q apply (rule exI[where x="p@q"]) by auto done
  done

lemma uconnectedV_refl: "E'\<subseteq>E \<Longrightarrow> refl_on verts (uconnectedV E')"
  by(auto simp: refl_on_def uconnected_def)

lemma uconnectedV_trans: "trans (uconnectedV E')"
  apply(clarsimp simp: trans_def uconnected_def) subgoal for x y z p a b c q apply (rule exI[where x="p@q"]) by auto done
lemma uconnectedV_sym: "sym (uconnectedV E')"
  apply(clarsimp simp: sym_def uconnected_def) subgoal for x y p apply (rule exI[where x="rev p"]) by (auto) done

lemma equiv_vert_uconnected: "equiv verts (uconnectedV E')"
  using equiv_unconnected_on by auto

lemma uconnectedV_tracl: "(uconnectedV F)\<^sup>* = (uconnectedV F)\<^sup>="
  apply(rule trans_rtrancl_eq_reflcl)
  by (fact uconnectedV_trans)

lemma uconnectedV_cl: "(uconnectedV F)\<^sup>+ = (uconnectedV F)"
  apply(rule trancl_id)
  by (fact uconnectedV_trans)

lemma uconnectedV_Restrcl: "Restr ((uconnectedV F)\<^sup>*) verts = (uconnectedV F)"
  apply(simp only: uconnectedV_tracl)
  apply auto unfolding uconnected_def by auto

lemma restr_ucon: "F \<subseteq> E \<Longrightarrow> uconnected F = uconnectedV F \<union> Id"
  unfolding uconnected_def apply auto
proof (goal_cases)
  case (1 a b p)
  then have "p\<noteq>[]" by auto
  then obtain e es where "p=e#es"
    using list.exhaust by blast
  with 1(2) have "a\<in> set_uprod e" "e\<in>F" by auto
  then show ?case using 1(1)
    by blast
next
  case (2 a b p)
  then have "rev p\<noteq>[]" "epath F b (rev p) a" by auto
  then obtain e es where "rev p=e#es"
    using list.exhaust by metis
  with 2(2) have "b\<in> set_uprod e" "e\<in>F" by auto
  then show ?case using 2(1)
    by blast
qed

lemma relI:
  assumes "\<And>a b. (a,b) \<in> F \<Longrightarrow> (a,b) \<in> G"
    and "\<And>a b. (a,b) \<in> G \<Longrightarrow> (a,b) \<in> F" shows "F=G"
  using assms by auto

lemma in_per_union: "u \<in> {x, y} \<Longrightarrow>  u' \<in> {x, y} \<Longrightarrow>  x\<in>V \<Longrightarrow> y\<in>V \<Longrightarrow>
    refl_on V R \<Longrightarrow> part_equiv R  \<Longrightarrow> (u, u') \<in> per_union R x y"
  by (auto simp: per_union_def dest: refl_onD)

lemma uconnectedV_mono: " (a,b)\<in>uconnectedV F \<Longrightarrow> F\<subseteq>F' \<Longrightarrow> (a,b)\<in>uconnectedV F'"
  unfolding uconnected_def by (auto intro: epath_mono)

lemma per_union_subs: "x \<in> S \<Longrightarrow> y\<in>S \<Longrightarrow> R\<subseteq>S \<times> S \<Longrightarrow> per_union R x y \<subseteq> S \<times> S"
  unfolding per_union_def by auto

(* adapted preserve_corresponding_union_find_add by Julian Biendarra *)
lemma insert_uconnectedV_per:
  assumes  "x\<noteq>y" and inV: "x\<in>verts" "y\<in>verts" and subE: "F\<subseteq>E"
  shows "uconnectedV (insert (Upair x y) F) = per_union (uconnectedV F) x y"
    (is "uconnectedV ?F' = per_union ?uf x y")
proof -
  have PER: "part_equiv (uconnectedV F)" unfolding part_equiv_def
    using uconnectedV_sym uconnectedV_trans by auto
  from PER have PER': "part_equiv (per_union (uconnectedV F) x y)"
    by (auto simp: union_part_equivp)
  have ref: "refl_on verts (uconnectedV F)" using uconnectedV_refl assms(4) by auto

  show ?thesis
  proof (rule relI)
    fix a b
    assume "(a,b) \<in> uconnectedV ?F'"
    then obtain p where p: "epath ?F' a p b" and ab: "a\<in>verts" "b\<in>verts"
      unfolding uconnected_def
      by blast
    show "(a,b)\<in>per_union (uconnectedV F) x y"
    proof (cases "Upair x y\<in>set p")
      case True
      obtain p' p'' u u' where
        "epath ?F' a p' u" "epath ?F' u' p'' b"and
        u: "u\<in>{x,y} \<and> u'\<in>{x,y}" and
        "Upair x y \<notin> set p'" "Upair x y \<notin> set p''"
        using epath_split_distinct[OF p True] by blast
      then have "epath F a p' u" "epath F u' p'' b" by(auto intro: epath_restrict')
      then have a: "(a,u)\<in>(uconnectedV F)" and b: "(u',b)\<in>(uconnectedV F)"
        unfolding uconnected_def using u ab assms by auto

      from a
      have "(a,u)\<in>per_union ?uf x y" by (auto simp: per_union_def)
      also
      have "(u,u')\<in>per_union ?uf x y" apply (rule in_per_union) using u inV ref PER by auto
      also (part_equiv_trans[OF PER'])
      have "(u',b)\<in>per_union ?uf x y" using b by (auto simp: per_union_def)
      finally (part_equiv_trans[OF PER'])
      show "(a,b)\<in>per_union ?uf x y" .
    next
      case False
      with p have "epath F a p b" by(auto intro: epath_restrict')
      then have "(a,b)\<in>uconnectedV F" using ab by (auto simp: uconnected_def)
      then show ?thesis unfolding per_union_def by auto
    qed
  next
    fix a b
    assume asm: "(a,b)\<in>per_union ?uf x y"
    have "per_union ?uf x y \<subseteq> verts \<times> verts" apply(rule per_union_subs)
      using inV by auto
    with asm have ab: "a\<in>verts" "b\<in>verts" by auto
    have "Upair x y \<in> ?F'" by simp
    show "(a,b) \<in> uconnectedV ?F'"
    proof (cases "(a, b) \<in> ?uf")
      case True
      then show ?thesis using uconnectedV_mono by blast
    next
      case False
      with asm part_equiv_sym[OF PER]
      have "(a,x) \<in> ?uf \<and> (y,b) \<in> ?uf  \<or>  (a,y) \<in> ?uf \<and> (x,b) \<in> ?uf"
        by (auto simp: per_union_def)
      with assms(1) \<open>x\<in>verts\<close> \<open>y\<in>verts\<close> inV  obtain p q p' q'
        where "epath F a p x \<and> epath F y q b  \<or>  epath F a p' y \<and> epath F x q' b"
        unfolding uconnected_def
        by fastforce
      then have "epath ?F' a p x \<and> epath ?F' y q b  \<or>  epath ?F' a p' y \<and> epath ?F' x q' b"
        by (auto intro: epath_mono)
      then have 2: "epath ?F' a (p @ Upair x y # q) b \<or>  epath ?F' a (p' @ Upair x y # q') b"
        using assms(1) by auto
      then show ?thesis unfolding uconnected_def
        using ab by blast
    qed
  qed
qed

lemma epath_filter_selfloop: "epath (insert (Upair x x) F) a p b \<Longrightarrow> \<exists>p. epath F a p b"
proof (induction n == "length p" arbitrary: p  rule: nat_less_induct)
  case 1
  from 1(1) have indhyp:
      "\<And>xa. length xa < length p \<Longrightarrow> epath (insert (Upair x x) F) a xa b \<Longrightarrow> (\<exists>p. epath F a p b)" by auto

  from 1(2) have k: "set p \<subseteq> (insert (Upair x x) F)" using epath_subset_E by fast
  { assume a: "set p \<subseteq> F"
    have F: "(insert (Upair x x) F \<inter> F) = F" by auto
    from epath_restrict[OF a 1(2)] F have "epath F a p b" by simp
    then have "(\<exists>p. epath F a p b)" by auto
  } moreover
  { assume "\<not> set p \<subseteq> F"
    with k have "Upair x x \<in> set p" by auto
    then obtain xs ys where p: "p = xs @ Upair x x # ys"
      by (meson split_list_last)
    then have "epath (insert (Upair x x) F) a xs x"  "epath (insert (Upair x x) F) x ys b"
      using "1.prems" by auto
    then have "epath (insert (Upair x x) F) a (xs@ys) b" by auto
    from indhyp[OF _ this] p have "(\<exists>p. epath F a p b)" by simp
  }
  ultimately show ?thesis by auto
qed

lemma uconnectedV_insert_selfloop: "x\<in>verts \<Longrightarrow> uconnectedV (insert (Upair x x) F) = uconnectedV F"
  apply(rule)
   apply auto
  subgoal unfolding uconnected_def apply auto using epath_filter_selfloop by metis
  subgoal by (meson subsetCE subset_insertI uconnected_mono)
  done

lemma equiv_selfloop_per_union_id: "equiv S F \<Longrightarrow> x\<in>S \<Longrightarrow> per_union F x x = F"
  apply rule
  subgoal unfolding per_union_def
    using equiv_class_eq_iff by fastforce
  subgoal unfolding per_union_def by auto
  done

lemma insert_uconnectedV_per_eq:
  assumes    inV: "x\<in>verts"   and subE: "F\<subseteq>E"
  shows "uconnectedV (insert (Upair x x) F) = per_union (uconnectedV F) x x"
  using assms
  by(simp add: uconnectedV_insert_selfloop equiv_selfloop_per_union_id[OF equiv_vert_uconnected])

lemma insert_uconnectedV_per':
  assumes  inV: "x\<in>verts" "y\<in>verts" and subE: "F\<subseteq>E"
  shows "uconnectedV (insert (Upair x y) F) = per_union (uconnectedV F) x y"
  apply(cases "x=y")
  subgoal using assms insert_uconnectedV_per_eq by simp
  subgoal using assms insert_uconnectedV_per by simp
  done

definition "subforest F \<equiv> forest F \<and> F \<subseteq> E"

definition spanningForest where "spanningForest X \<longleftrightarrow> subforest X \<and> (\<forall>x \<in> E - X. \<not> subforest (insert x X))"

definition "minSpanningForest F \<equiv> spanningForest F \<and> (\<forall>F'. spanningForest F' \<longrightarrow> sum w F \<le> sum w F')"

end

end


theory RRC_2T
imports OpSem
begin

datatype PC =
  L1
| L2
| L3

consts t1 :: T
consts t2 :: T
consts x :: L

definition "thrdsvars \<equiv>  t1 \<noteq> t2 "

record mp_state =
  pc :: "T \<Rightarrow> PC"
  state :: surrey_state
  a :: V
  b :: V

definition
  "update_pc t nv pcf \<equiv> pcf (t := nv)"

definition prog :: "T \<Rightarrow>  mp_state \<Rightarrow> mp_state \<Rightarrow> bool " where
"prog t s s' \<equiv>
(
if t = t1
then
  if (pc s) t = L1
    then
      pc s' = update_pc t L2 (pc s) \<and>
      (state s) [x := 1]\<^sub>t (state s') \<and>
      a s' = a s \<and> b s' = b s

else
if (pc s) t = L2
then
      pc s' = update_pc t L3 (pc s) \<and>
      (state s) [x := 2]\<^sub>t (state s') \<and>
      a s' = a s \<and> b s' = b s
else
    False
else
if t = t2
then
  if (pc s) t = L1
    then
      pc s' = update_pc t L2 (pc s) \<and>
      (state s) [a s' \<leftarrow> x]\<^sub>t (state s') \<and>
      b s' = b s
  else
  if (pc s) t = L2
    then
      pc s' = update_pc t L3 (pc s) \<and>
      (state s) [b s' \<leftarrow> x]\<^sub>t (state s') \<and>
      a s' = a s
else
  False
else
  False
)"

definition prog_inv :: "T \<Rightarrow> PC \<Rightarrow> mp_state \<Rightarrow> bool " where
"prog_inv t p s \<equiv>
  if t = t1
  then
    (case p of
          L1 \<Rightarrow> [\<zero>\<^sub>x 1]\<^sub>0 (state s) \<and> [\<one>\<^sub>x 1] (state s) \<and> [\<zero>\<^sub>x 2]\<^sub>0 (state s) \<and>  [\<one>\<^sub>x 2] (state s)
        | L2 \<Rightarrow> [\<zero>\<^sub>x 2]\<^sub>0 (state s) \<and> enc_t (state s) t x 1 \<and> [\<one>\<^sub>x 1] (state s) \<and> [\<one>\<^sub>x 2] (state s)
        | L3 \<Rightarrow> [\<one>\<^sub>x 1] (state s) \<and> [\<one>\<^sub>x 2] (state s) \<and>  [1 \<hookrightarrow>\<^sub>x 2] (state s)

    )
  else
    if t = t2 then
      (case p of
          L1 \<Rightarrow> init_val (state s) x 0 \<and> [\<one>\<^sub>x 1] (state s) \<and>  [\<one>\<^sub>x 2] (state s)
        | L2 \<Rightarrow> init_val (state s) x 0 \<and> enc_t (state s) t x (a s)
        | L3 \<Rightarrow> (a s \<noteq> b s \<longrightarrow> [(a s) \<leadsto>\<^sub>x (b s)] (state s))
      )
  else
    False
"

lemma goal:
  assumes "prog_inv t1 L3 s"
  and "prog_inv t2 L3 s"
  and "thrdsvars"
shows "a s = 2 \<longrightarrow> b s \<noteq> 1"
  using assms
  apply(simp add: prog_inv_def thrdsvars_def)
  apply(elim conjE)
  apply(case_tac " a s = 2", simp)
   defer
  apply simp
  apply(case_tac "b s \<noteq> 0")
  apply(case_tac "b s \<noteq> Suc 0")
  apply(case_tac "b s \<noteq> 2")
     apply simp
    apply simp
  apply(elim impE)
    apply simp
  apply(unfold opsem_def)
  apply (metis diff_self diff_strict_mono less_numeral_extra(3))
  by linarith

(*initial_state \<sigma> I*)
definition init_map  :: "(L \<Rightarrow> V) \<Rightarrow> bool" where
  "init_map \<phi> \<equiv> \<phi> x = 0"

definition init_s  :: "surrey_state  \<Rightarrow> bool"
  where
    "init_s ss \<equiv> \<exists> \<phi>. initial_state ss \<phi> \<and> init_map \<phi>"

definition init  :: "mp_state  \<Rightarrow> bool"
  where
    "init s \<equiv> (pc s) t1 = L1
      \<and> (pc s) t2 = L1 \<and>
      a s = 0  \<and> b s = 0
    \<and> init_s (state s) \<and> thrdsvars"

lemma init_inv : "init s \<Longrightarrow> thrdsvars \<Longrightarrow> prog_inv t1 L1 s \<and>
                                           prog_inv t2 L1 s"
  apply(simp add: init_def prog_inv_def thrdsvars_def opsem_def)
  apply(cases "pc s t1")
  apply simp
  apply(elim conjE)
  apply (intro conjI)
  apply(unfold  value_def init_s_def init_map_def initial_state_def writes_on_def init_val_def)
  by clarsimp+

lemma t1_local :
  assumes "prog_inv t1 ((pc s) t1) s"
  and "thrdsvars"
  and "prog t1 s s'"
shows  "prog_inv t1 ((pc s') t1) s'"
  using assms
  apply(unfold prog_inv_def prog_def thrdsvars_def  update_pc_def)
  apply simp
  apply(cases "(pc s) t1")
    apply simp
  apply(intro conjI, elim conjE)
  using enc_write_intro
  apply (metis WrX_def init_val_pres isWr.simps(2) n_not_Suc_n no_val_def not_pvorder_pres_step_wr numeral_2_eq_2 option.inject wr_val.simps(1))
  apply(elim conjE)
  apply (metis WrX_def avar.simps(2) enc_write_intro isWr.simps(2) wr_val.simps(1))
  apply (elim conjE)
  using amo_intro_step no_val_def apply blast
    apply (elim conjE)
  using amo_intro_step no_val_def zero_neq_numeral apply blast
  apply (simp add: amo_intro_step)
   apply(cases "(pc s) t1", auto)
  apply (metis One_nat_def amo_Wr_diff_val_pres nat.inject numeral_2_eq_2 zero_neq_one)
  using amo_intro_step no_val_def zero_neq_numeral apply blast
  by (metis WrX_def avar.simps(2) d_vorder_intro_w isWr.simps(2) n_not_Suc_n no_val_def numeral_2_eq_2 wr_val.simps(1) zero_neq_numeral)

lemma t1_global :
  assumes "prog_inv t1 ((pc s) t1) s"
      and "prog_inv t2 ((pc s) t2) s"
      and "thrdsvars"
      and "prog t2 s s'"
    shows "prog_inv t1 ((pc s') t1) s'"
  using assms
  apply(unfold prog_inv_def prog_def thrdsvars_def  update_pc_def)
  apply clarsimp
  apply(cases "pc s t2", auto)
   apply(cases "pc s t1")
  apply simp
     apply (intro conjI)
  apply (metis RdX_def init_val_pres isRd.simps(1) no_val_def read_pres_not_p_vorder)
  using amo_intro_step no_val_def apply blast
  apply (metis RdX_def init_val_pres isRd.simps(1) no_val_def read_pres_not_p_vorder)
  apply (simp add: amo_intro_step no_val_def)
  apply(cases "pc s t1", auto)
  apply (metis RdX_def init_val_pres isRd.simps(1) no_val_def read_pres_not_p_vorder)
  using enc_pres apply blast
  apply (metis RdX_def amo_read_pres isRd.simps(1))
  using amo_intro_step no_val_def zero_neq_numeral apply blast
  apply (metis RdX_def amo_read_pres isRd.simps(1))
    apply (metis RdX_def amo_def isRd.simps(1) read_pres_not_p_vorder)
  using d_vorder_RdX_pres apply blast
  apply(cases "pc s t1", auto)
  apply (metis RdX_def init_val_pres isRd.simps(1) no_val_def read_pres_not_p_vorder)
  using amo_intro_step no_val_def apply blast
  apply (metis RdX_def init_val_pres isRd.simps(1) no_val_def read_pres_not_p_vorder)
  using amo_intro_step no_val_def zero_neq_numeral apply blast
  apply (metis RdX_def init_val_pres isRd.simps(1) no_val_def read_pres_not_p_vorder)
  using enc_pres apply blast
  apply (metis RdX_def amo_read_pres isRd.simps(1))
  apply (metis RdX_def amo_def isRd.simps(1) read_pres_not_p_vorder)
  apply (metis RdX_def amo_read_pres isRd.simps(1))
   apply (metis RdX_def amo_def isRd.simps(1) read_pres_not_p_vorder)
  using d_vorder_RdX_pres by blast

lemma t2_local :
  assumes "prog_inv t2 ((pc s) t2) s"
  and "thrdsvars"
  and "prog t2 s s'"
shows  "prog_inv t2 ((pc s') t2) s'"
  using assms
  apply(unfold prog_inv_def prog_def thrdsvars_def update_pc_def, simp)
  apply(cases "pc s t2", auto)
  using init_val_pres apply blast
  using enc_RdX_intro apply blast
  apply(simp add: prog_inv_def prog_def update_pc_def)
  using enc_pvord_step
  by (metis RdX_def avar.simps(1) isRd.simps(1) rd_val.simps(1))

lemma t2_global :
  assumes "prog_inv t2 ((pc s) t2) s"
  and "prog_inv t1 ((pc s) t1) s"
  and "thrdsvars"
  and "prog t1 s s'"
shows  "prog_inv t2 ((pc s') t2) s'"
  using assms
  apply(unfold prog_inv_def prog_def thrdsvars_def  update_pc_def)
  apply clarsimp
  apply(cases "pc s t1", auto)
   apply(cases "pc s t2", simp_all)
     apply(intro conjI)
  using init_val_pres apply blast
  using amo_intro_step no_val_def apply blast
  apply (simp add: amo_intro_step no_val_def)
    using assms(3) assms(4) prog_inv_def t1_local
  apply (simp add: enc_pres init_val_pres)
   apply(cases "pc s t2", simp_all)
  using enc_pres init_val_pres apply blast
    apply (metis WrX_def  isWr.simps(2) p_vorder_write_pres)
     apply(cases "pc s t2", simp)
  apply (smt One_nat_def PC.simps(9) assms(2) assms(3) assms(4) fun_upd_same init_val_pres prog_inv_def t1_local)
  apply simp
  using enc_pres init_val_pres apply blast
   apply simp
   apply (intro impI)
   apply simp
  using p_vorder_write_pres
  by (metis WrX_def isWr.simps(2))

end


(*  Title:      ZF/UNITY/Comp.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   1998  University of Cambridge

From Chandy and Sanders, "Reasoning About Program Composition",
Technical Report 2000-003, University of Florida, 2000.

Revised by Sidi Ehmety on January  2001

Added: a strong form of the order relation over component and localize

Theory ported from HOL.

*)

section\<open>Composition\<close>

theory Comp imports Union Increasing begin

definition
  component :: "[i,i]=>o"  (infixl \<open>component\<close> 65)  where
  "F component H == (\<exists>G. F \<squnion> G = H)"

definition
  strict_component :: "[i,i]=>o" (infixl \<open>strict'_component\<close> 65)  where
  "F strict_component H == F component H & F\<noteq>H"

definition
  (* A stronger form of the component relation *)
  component_of :: "[i,i]=>o"   (infixl \<open>component'_of\<close> 65)  where
  "F component_of H  == (\<exists>G. F ok G & F \<squnion> G = H)"

definition
  strict_component_of :: "[i,i]=>o" (infixl \<open>strict'_component'_of\<close> 65)  where
  "F strict_component_of H  == F component_of H  & F\<noteq>H"

definition
  (* Preserves a state function f, in particular a variable *)
  preserves :: "(i=>i)=>i"  where
  "preserves(f) == {F:program. \<forall>z. F: stable({s:state. f(s) = z})}"

definition
  fun_pair :: "[i=>i, i =>i] =>(i=>i)"  where
  "fun_pair(f, g) == %x. <f(x), g(x)>"

definition
  localize  :: "[i=>i, i] => i"  where
  "localize(f,F) == mk_program(Init(F), Acts(F),
                       AllowedActs(F) \<inter> (\<Union>G\<in>preserves(f). Acts(G)))"

(*** component and strict_component relations ***)

lemma componentI:
     "H component F | H component G ==> H component (F \<squnion> G)"
apply (unfold component_def, auto)
apply (rule_tac x = "Ga \<squnion> G" in exI)
apply (rule_tac [2] x = "G \<squnion> F" in exI)
apply (auto simp add: Join_ac)
done

lemma component_eq_subset:
     "G \<in> program ==> (F component G) \<longleftrightarrow>
   (Init(G) \<subseteq> Init(F) & Acts(F) \<subseteq> Acts(G) & AllowedActs(G) \<subseteq> AllowedActs(F))"
apply (unfold component_def, auto)
apply (rule exI)
apply (rule program_equalityI, auto)
done

lemma component_SKIP [simp]: "F \<in> program ==> SKIP component F"
apply (unfold component_def)
apply (rule_tac x = F in exI)
apply (force intro: Join_SKIP_left)
done

lemma component_refl [simp]: "F \<in> program ==> F component F"
apply (unfold component_def)
apply (rule_tac x = F in exI)
apply (force intro: Join_SKIP_right)
done

lemma SKIP_minimal: "F component SKIP ==> programify(F) = SKIP"
apply (rule program_equalityI)
apply (simp_all add: component_eq_subset, blast)
done

lemma component_Join1: "F component (F \<squnion> G)"
by (unfold component_def, blast)

lemma component_Join2: "G component (F \<squnion> G)"
apply (unfold component_def)
apply (simp (no_asm) add: Join_commute)
apply blast
done

lemma Join_absorb1: "F component G ==> F \<squnion> G = G"
by (auto simp add: component_def Join_left_absorb)

lemma Join_absorb2: "G component F ==> F \<squnion> G = F"
by (auto simp add: Join_ac component_def)

lemma JOIN_component_iff:
     "H \<in> program==>(JOIN(I,F) component H) \<longleftrightarrow> (\<forall>i \<in> I. F(i) component H)"
apply (case_tac "I=0", force)
apply (simp (no_asm_simp) add: component_eq_subset)
apply auto
apply blast
apply (rename_tac "y")
apply (drule_tac c = y and A = "AllowedActs (H)" in subsetD)
apply (blast elim!: not_emptyE)+
done

lemma component_JOIN: "i \<in> I ==> F(i) component (\<Squnion>i \<in> I. (F(i)))"
apply (unfold component_def)
apply (blast intro: JOIN_absorb)
done

lemma component_trans: "[| F component G; G component H |] ==> F component H"
apply (unfold component_def)
apply (blast intro: Join_assoc [symmetric])
done

lemma component_antisym:
     "[| F \<in> program; G \<in> program |] ==>(F component G & G  component F) \<longrightarrow> F = G"
apply (simp (no_asm_simp) add: component_eq_subset)
apply clarify
apply (rule program_equalityI, auto)
done

lemma Join_component_iff:
     "H \<in> program ==>
      ((F \<squnion> G) component H) \<longleftrightarrow> (F component H & G component H)"
apply (simp (no_asm_simp) add: component_eq_subset)
apply blast
done

lemma component_constrains:
     "[| F component G; G \<in> A co B; F \<in> program |] ==> F \<in> A co B"
apply (frule constrainsD2)
apply (auto simp add: constrains_def component_eq_subset)
done

(*** preserves ***)

lemma preserves_is_safety_prop [simp]: "safety_prop(preserves(f))"
apply (unfold preserves_def safety_prop_def)
apply (auto dest: ActsD simp add: stable_def constrains_def)
apply (drule_tac c = act in subsetD, auto)
done

lemma preservesI [rule_format]:
     "\<forall>z. F \<in> stable({s \<in> state. f(s) = z})  ==> F \<in> preserves(f)"
apply (auto simp add: preserves_def)
apply (blast dest: stableD2)
done

lemma preserves_imp_eq:
     "[| F \<in> preserves(f);  act \<in> Acts(F);  <s,t> \<in> act |] ==> f(s) = f(t)"
apply (unfold preserves_def stable_def constrains_def)
apply (subgoal_tac "s \<in> state & t \<in> state")
 prefer 2 apply (blast dest!: Acts_type [THEN subsetD], force)
done

lemma Join_preserves [iff]:
"(F \<squnion> G \<in> preserves(v)) \<longleftrightarrow>
      (programify(F) \<in> preserves(v) & programify(G) \<in> preserves(v))"
by (auto simp add: preserves_def INT_iff)

lemma JOIN_preserves [iff]:
     "(JOIN(I,F): preserves(v)) \<longleftrightarrow> (\<forall>i \<in> I. programify(F(i)):preserves(v))"
by (auto simp add: JOIN_stable preserves_def INT_iff)

lemma SKIP_preserves [iff]: "SKIP \<in> preserves(v)"
by (auto simp add: preserves_def INT_iff)

lemma fun_pair_apply [simp]: "fun_pair(f,g,x) = <f(x), g(x)>"
apply (unfold fun_pair_def)
apply (simp (no_asm))
done

lemma preserves_fun_pair:
     "preserves(fun_pair(v,w)) = preserves(v) \<inter> preserves(w)"
apply (rule equalityI)
apply (auto simp add: preserves_def stable_def constrains_def, blast+)
done

lemma preserves_fun_pair_iff [iff]:
     "F \<in> preserves(fun_pair(v, w))  \<longleftrightarrow> F \<in> preserves(v) \<inter> preserves(w)"
by (simp add: preserves_fun_pair)

lemma fun_pair_comp_distrib:
     "(fun_pair(f, g) comp h)(x) = fun_pair(f comp h, g comp h, x)"
by (simp add: fun_pair_def metacomp_def)

lemma comp_apply [simp]: "(f comp g)(x) = f(g(x))"
by (simp add: metacomp_def)

lemma preserves_type: "preserves(v)<=program"
by (unfold preserves_def, auto)

lemma preserves_into_program [TC]: "F \<in> preserves(f) ==> F \<in> program"
by (blast intro: preserves_type [THEN subsetD])

lemma subset_preserves_comp: "preserves(f) \<subseteq> preserves(g comp f)"
apply (auto simp add: preserves_def stable_def constrains_def)
apply (drule_tac x = "f (xb)" in spec)
apply (drule_tac x = act in bspec, auto)
done

lemma imp_preserves_comp: "F \<in> preserves(f) ==> F \<in> preserves(g comp f)"
by (blast intro: subset_preserves_comp [THEN subsetD])

lemma preserves_subset_stable: "preserves(f) \<subseteq> stable({s \<in> state. P(f(s))})"
apply (auto simp add: preserves_def stable_def constrains_def)
apply (rename_tac s' s)
apply (subgoal_tac "f (s) = f (s') ")
apply (force+)
done

lemma preserves_imp_stable:
     "F \<in> preserves(f) ==> F \<in> stable({s \<in> state. P(f(s))})"
by (blast intro: preserves_subset_stable [THEN subsetD])

lemma preserves_imp_increasing:
 "[| F \<in> preserves(f); \<forall>x \<in> state. f(x):A |] ==> F \<in> Increasing.increasing(A, r, f)"
apply (unfold Increasing.increasing_def)
apply (auto intro: preserves_into_program)
apply (rule_tac P = "%x. <k, x>:r" in preserves_imp_stable, auto)
done

lemma preserves_id_subset_stable:
 "st_set(A) ==> preserves(%x. x) \<subseteq> stable(A)"
apply (unfold preserves_def stable_def constrains_def, auto)
apply (drule_tac x = xb in spec)
apply (drule_tac x = act in bspec)
apply (auto dest: ActsD)
done

lemma preserves_id_imp_stable:
     "[| F \<in> preserves(%x. x); st_set(A) |] ==> F \<in> stable(A)"
by (blast intro: preserves_id_subset_stable [THEN subsetD])

(** Added by Sidi **)
(** component_of **)

(*  component_of is stronger than component *)
lemma component_of_imp_component:
"F component_of H ==> F component H"
apply (unfold component_def component_of_def, blast)
done

(* component_of satisfies many of component's properties *)
lemma component_of_refl [simp]: "F \<in> program ==> F component_of F"
apply (unfold component_of_def)
apply (rule_tac x = SKIP in exI, auto)
done

lemma component_of_SKIP [simp]: "F \<in> program ==>SKIP component_of F"
apply (unfold component_of_def, auto)
apply (rule_tac x = F in exI, auto)
done

lemma component_of_trans:
     "[| F component_of G; G component_of H |] ==> F component_of H"
apply (unfold component_of_def)
apply (blast intro: Join_assoc [symmetric])
done

(** localize **)
lemma localize_Init_eq [simp]: "Init(localize(v,F)) = Init(F)"
by (unfold localize_def, simp)

lemma localize_Acts_eq [simp]: "Acts(localize(v,F)) = Acts(F)"
by (unfold localize_def, simp)

lemma localize_AllowedActs_eq [simp]:
 "AllowedActs(localize(v,F)) = AllowedActs(F) \<inter> (\<Union>G \<in> preserves(v). Acts(G))"
apply (unfold localize_def)
apply (rule equalityI)
apply (auto dest: Acts_type [THEN subsetD])
done

(** Theorems used in ClientImpl **)

lemma stable_localTo_stable2:
 "[| F \<in> stable({s \<in> state. P(f(s), g(s))});  G \<in> preserves(f);  G \<in> preserves(g) |]
      ==> F \<squnion> G \<in> stable({s \<in> state. P(f(s), g(s))})"
apply (auto dest: ActsD preserves_into_program simp add: stable_def constrains_def)
apply (case_tac "act \<in> Acts (F) ")
apply auto
apply (drule preserves_imp_eq)
apply (drule_tac [3] preserves_imp_eq, auto)
done

lemma Increasing_preserves_Stable:
     "[| F \<in> stable({s \<in> state. <f(s), g(s)>:r});  G \<in> preserves(f);
         F \<squnion> G \<in> Increasing(A, r, g);
         \<forall>x \<in> state. f(x):A & g(x):A |]
      ==> F \<squnion> G \<in> Stable({s \<in> state. <f(s), g(s)>:r})"
apply (auto simp add: stable_def Stable_def Increasing_def Constrains_def all_conj_distrib)
apply (simp_all add: constrains_type [THEN subsetD] preserves_type [THEN subsetD])
apply (blast intro: constrains_weaken)
(*The G case remains*)
apply (auto dest: ActsD simp add: preserves_def stable_def constrains_def ball_conj_distrib all_conj_distrib)
(*We have a G-action, so delete assumptions about F-actions*)
apply (erule_tac V = "\<forall>act \<in> Acts (F). P (act)" for P in thin_rl)
apply (erule_tac V = "\<forall>k\<in>A. \<forall>act \<in> Acts (F) . P (k,act)" for P in thin_rl)
apply (subgoal_tac "f (x) = f (xa) ")
apply (auto dest!: bspec)
done

(** Lemma used in AllocImpl **)

lemma Constrains_UN_left:
     "[| \<forall>x \<in> I. F \<in> A(x) Co B; F \<in> program |] ==> F:(\<Union>x \<in> I. A(x)) Co B"
by (unfold Constrains_def constrains_def, auto)

lemma stable_Join_Stable:
 "[| F \<in> stable({s \<in> state. P(f(s), g(s))});
     \<forall>k \<in> A. F \<squnion> G \<in> Stable({s \<in> state. P(k, g(s))});
     G \<in> preserves(f); \<forall>s \<in> state. f(s):A|]
  ==> F \<squnion> G \<in> Stable({s \<in> state. P(f(s), g(s))})"
apply (unfold stable_def Stable_def preserves_def)
apply (rule_tac A = "(\<Union>k \<in> A. {s \<in> state. f(s)=k} \<inter> {s \<in> state. P (f (s), g (s))})" in Constrains_weaken_L)
prefer 2 apply blast
apply (rule Constrains_UN_left, auto)
apply (rule_tac A = "{s \<in> state. f(s)=k} \<inter> {s \<in> state. P (f (s), g (s))} \<inter> {s \<in> state. P (k, g (s))}" and A' = "({s \<in> state. f(s)=k} \<union> {s \<in> state. P (f (s), g (s))}) \<inter> {s \<in> state. P (k, g (s))}" in Constrains_weaken)
 prefer 2 apply blast
 prefer 2 apply blast
apply (rule Constrains_Int)
apply (rule constrains_imp_Constrains)
apply (auto simp add: constrains_type [THEN subsetD])
apply (blast intro: constrains_weaken)
apply (drule_tac x = k in spec)
apply (blast intro: constrains_weaken)
done

end


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

theory Effectively_Acyclic_Sourced_Path
imports Effectively_Acyclic Effectively_Acyclic_Approximations
begin

paragraph \<open>Summary\<close>
text \<open>This theory culminates in a lemma that constructs a path within a flow graph h' = h1' + h2'
by using an effectively acyclic flow graph h = h1 + h2 and subflow-preserving extensions
h1 <=S h1' and h2 <= h2'. This path is guaranteed to have flow starting with some inflow from the
outside of h'. h' is explicitly not effectively acyclic.

This result is purely technical in order to conduct a proof by contradiction in
@{term maintain_eff_acyclic_dom_eq}\<close>

paragraph \<open>Major Lemmas\<close>

text \<open>
@{term eff_acyclic_flow_is_sourced}: find some path xs to a given node y such that
  there is inflow to hd xs and flow along xs to y.
@{term eff_acyclic_sourced_path_in_bigraph}: lemma described in summary.
\<close>

section \<open>Sourced Paths in Simple Flow Graphs\<close>

text \<open>Given a node with flow, there must be a path to this node such that the starting node of
that path has inflow.\<close>

lemma eff_acyclic_flow_is_sourced:
  fixes E :: "('b \<Rightarrow> 'b :: pos_cancel_comm_monoid_add) set"
  assumes "eff_acyclic' h" "f (flow_fg h x) \<noteq> 0" "End_closed E" "\<forall>x y. edge_fg h x y \<in> E"
    "f \<in> E" "id \<in> E" "(\<lambda>_. 0) \<in> E"
  shows "\<exists>xs. f (chain (edge_fg h) xs x (inf_fg h (if xs \<noteq> [] then hd xs else x))) \<noteq> 0 \<and>
              set xs \<subseteq> dom_fg h"
proof (rule ccontr)
  assume "\<nexists>xs. f (chain (edge_fg h) xs x (inf_fg h (if xs \<noteq> [] then hd xs else x))) \<noteq> 0 \<and>
               set xs \<subseteq> dom_fg h"
  then have **: "\<forall>xs. set xs \<subseteq> dom_fg h \<longrightarrow>
    f (chain (edge_fg h) xs x (inf_fg h (if xs \<noteq> [] then hd xs else x))) = 0"
    by blast
  then have ***: "f (inf_fg h x) = 0"
    by (smt bot.extremum chain.simps(1) empty_set id_apply)

  have "flow_fg h x \<noteq> 0"
    using endo_f_n0_n0_closed assms by auto
  then have X: "x \<in> dom_fg h" "h \<noteq> bot"
    using pos_flow_nbot pos_flow_dom[of h x] by auto

  have "flow_eq2' (dom_fg h) (edge_fg h) (flow_fg h) (inf_fg h)"
    using X nbot_fg_to_flow_eq2' by blast
  then have "\<forall>x \<in> dom_fg h. flow_fg h x = inf_fg h x +
    (\<Sum>xs\<in>l_lists (dom_fg h) (card (dom_fg h) + 1). chain (edge_fg h) xs x (inf_fg h (hd xs)))"
    using assms unroll_flow_eq_eff_acyclic[of "dom_fg h" "edge_fg h" "flow_fg h"] dom_fg_finite[of h]
    unfolding eff_acyclic'_def
    by auto
  then have "f (flow_fg h x) = f (inf_fg h x) +
    f (\<Sum>xs\<in>l_lists (dom_fg h) (card (dom_fg h) + 1). chain (edge_fg h) xs x (inf_fg h (hd xs)))"
    using X assms unfolding endo_def End_closed_def by auto
  also have "... = f (inf_fg h x) +
    (\<Sum>xs\<in>l_lists (dom_fg h) (card (dom_fg h) + 1). f (chain (edge_fg h) xs x (inf_fg h (hd xs))))"
    apply (subst fun_dist_right''[where g="f"])
    using l_lists_finite[OF dom_fg_finite] assms by simp_all
  also have "... = f (inf_fg h x)"
    apply (subst sum.neutral)
    unfolding l_lists_def
     apply (auto simp: ** assms split: if_splits)
    subgoal for xs
      apply (cases xs, simp)
      using **
      by (smt Suc_le_lessD length_greater_0_conv)
    done
  also have "... = 0"
    using *** by simp
  finally show False
    using assms by simp
qed

section \<open>Sourced Paths in Flow Graph Sums\<close>

text \<open> Proof structure of @{term eff_acyclic_sourced_path_in_bigraph}:
- two cases, both solved with @{term eff_acyclic_sourced_path_in_bigraph_case}
- @{term eff_acyclic_sourced_path_in_bigraph_case} prepares all assumptions required by
  @{term eff_acyclic_sourced_path_in_bigraph'}
- then @{term eff_acyclic_sourced_path_in_bigraph'} finds the path
\<close>

lemma eff_acyclic_sourced_path_in_bigraph':
  fixes E :: "('b \<Rightarrow> 'b :: pos_cancel_comm_monoid_add) set"
  assumes "chain (edge_fg h') as b (chain (edge_fg h) xs (hd (as @ [b])) (outf_fg h2 (hd (xs @ as @ [b])))) \<noteq> 0"
      "set xs \<subseteq> dom_fg h" "b \<in> dom_fg h"
      "eff_acyclic' h" "eff_acyclic' h1" "eff_acyclic' h1'" "eff_acyclic' h2" "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"
      "h = h1 + h2" "h' = h1' + h2'" "hd (xs @ as @ [b]) \<in> dom_fg h1" "h \<noteq> bot" "h' \<noteq> bot"
      "\<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 h1 x y \<in> E"
      "\<forall>x y. edge_fg h2 x y \<in> E" "End_closed E" "id \<in> E" "int_fg h1 = int_fg h1'"
      "int_fg h2 = int_fg h2'" "dom_fg h1 = dom_fg h1'" "dom_fg h2 = dom_fg h2'"
      "inf_fg h' = inf_fg h" "card (dom_fg h) \<le> k" "card (dom_fg h') \<le> k"
      "\<forall>x y. edge_fg h2' x y \<in> E" "set as \<subseteq> dom_fg h" "\<forall>x y. edge_fg h' x y \<in> E"
      "\<forall>x y. edge_fg h x y \<in> E" "(\<lambda>_. 0) \<in> E" "id \<in> E"
    shows "\<exists>ys. chain (edge_fg h') as b (chain (edge_fg h) xs (hd (as @ [b])) (chain (edge_fg h') ys (hd (xs @ as @ [b])) (inf_fg h' (hd (ys @ xs @ as @ [b]))))) \<noteq> 0 \<and>
            chain (edge_fg h') ys (hd (xs @ as @ [b])) (inf_fg h' (hd (ys @ xs @ as @ [b]))) \<le> inf_fg h1 (hd (xs @ as @ [b])) \<and>
            set ys \<subseteq> dom_fg h'"
  using assms
proof (induction "length xs" arbitrary: xs h h' h1 h1' h2 h2' rule: nat_descend_induct[where n="k"])
  case base

  let ?N = "dom_fg h" let ?e = "edge_fg h" let ?f = "flow_fg h" let ?i = "inf_fg h"
  let ?N1 = "dom_fg h1" let ?f1 = "flow_fg h1" let ?i1 = "inf_fg h1"
  let ?o2 = "outf_fg h2" let ?e2 = "edge_fg h2" let ?f2 = "flow_fg h2" let ?N2 = "dom_fg h2"
  let ?N' = "dom_fg h'" let ?e' = "edge_fg h'" let ?f' = "flow_fg h'" let ?i' = "inf_fg h'"
  let ?y = "hd (xs @ as @ [b])"

  have L: "length xs \<ge> card ?N + 1" using \<open>k < length xs\<close> \<open>card ?N \<le> k\<close>
    by simp
  then obtain x xs1 xs2 xs3 where *: "xs = xs1 @ x # xs2 @ x # xs3"
    using pigeonhole_split_list[of ?N xs] base by auto
  moreover have "chain ?e xs (hd (as @ [b])) (?o2 ?y) \<noteq> 0"
    apply (rule endo_f_n0_n0_closed[of "chain (edge_fg h') as b" E "chain ?e xs (hd (as @ [b])) (?o2 ?y)"])
    using base(2) apply simp_all
    using endo_chain_closed[of ?e' E as b] \<open>id \<in> E\<close> \<open>End_closed E\<close> \<open>\<forall>x y. edge_fg h' x y \<in> E\<close> by auto
  ultimately have A1: "chain ?e (x # xs2) x (chain ?e xs1 x (?o2 ?y)) \<noteq> 0"
    using chain_append_not_zero3(2)[of xs xs1 "x # xs2" "x # xs3" ?e "hd (as @ [b])" "?o2 ?y" E] base *
    by (metis append_Cons list.sel(1) list.simps(3))

  have "chain ?e xs1 x (?o2 ?y) \<le> chain ?e xs1 x (?i1 ?y)"
    apply (rule pos_endo_mono'_closed[OF outf_fg_le_inf_fg[of h]])
    using \<open>End_closed E\<close> \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close> \<open>hd (xs @ as @ [b]) \<in> ?N1\<close> \<open>\<forall>x y. edge_fg h x y \<in> E\<close> \<open>id \<in> E\<close>
    by (auto simp: algebra_simps elim!: endo_chain_closed)
  also have "... \<le> chain ?e xs1 x (?f1 ?y)"
    apply (rule pos_endo_mono'_closed[OF inf_fg_le_flow_fg])
    using \<open>End_closed E\<close> \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close> \<open>hd (xs @ as @ [b]) \<in> ?N1\<close> \<open>\<forall>x y. edge_fg h x y \<in> E\<close> \<open>id \<in> E\<close>
    by (auto simp: algebra_simps elim!: endo_chain_closed)
  also have "... = chain ?e xs1 x (?f ?y)"
    using flow_fg_plus_fg_on1'[of h1 h2 ?y] base by metis
  also have "... \<le> ?f x"
    using chain_flow_fg_le_flow_fg[of h E x xs1] base * apply simp
    by (metis append_self_conv2 hd_append2 list.sel(1))
  finally have B: "chain ?e xs1 x (?o2 ?y) \<le> ?f x" .

  have C: "chain ?e (x # xs2) x \<in> E"
    using endo_chain_closed[of ?e E "x # xs2" x] base by metis

  have "x # xs2 \<in> k_lists ?N (length xs2 + 1)"
    using base * unfolding k_lists_def
    by (smt One_nat_def insert_subset le_sup_iff list.set(2) list.size(4) mem_Collect_eq set_append)
  then have "chain ?e (x # xs2) x (?f (hd (x # xs2))) = 0"
    using base
    by (metis eff_acyclic'_def eff_acyclic_def le_add2 list.sel(1))
  then have A2: "chain ?e (x # xs2) x (chain ?e xs1 x (?o2 ?y)) = 0"
    using pos_endo_mono'_closed[OF B C] base
    by (metis add_eq_0_iff_both_eq_0 le_iff_add list.sel(1))

  show ?case
    using A1 A2
    by simp
next
  case descend

  let ?N1 = "dom_fg h1" let ?e1 = "edge_fg h1" let ?f1 = "flow_fg h1" let ?i1 = "inf_fg h1"
  let ?N1' = "dom_fg h1'" let ?e1' = "edge_fg h1'" let ?f1' = "flow_fg h1'" let ?i1' = "inf_fg h1'"
  let ?o2 = "outf_fg h2" let ?o2' = "outf_fg h2'" let ?o1 = "outf_fg h1"
  let ?e2' = "edge_fg h2'" let ?f2' = "flow_fg h2'"
  let ?N = "dom_fg h" let ?e = "edge_fg h" let ?f = "flow_fg h" let ?i = "inf_fg h"
  let ?N2 = "dom_fg h2" let ?e2 = "edge_fg h2" let ?f2 = "flow_fg h2" let ?i2 = "inf_fg h2"
  let ?N2' = "dom_fg h2'" let ?e2' = "edge_fg h2'" let ?f2' = "flow_fg h2'" let ?i2' = "inf_fg h2'"
  let ?N' = "dom_fg h'" let ?e' = "edge_fg h'" let ?f' = "flow_fg h'" let ?i' = "inf_fg h'"
  let ?o' = "outf_fg h'"
  let ?y = "hd (as @ [b])" let ?y' = "hd (xs @ as @ [b])"
  let ?b = "chain ?e' as b"

  have "?i1 ?y' = (\<lambda>x. ?i x + ?o2 x) ?y'"
    using flow_eq_to_sum[of h1 h2] \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close> \<open>?y' \<in> ?N1\<close> by blast
  then have "chain ?e xs ?y (?i1 ?y') = ((chain ?e xs ?y) o (\<lambda>x. ?i x + ?o2 x)) ?y'"
    by simp
  then have **: "chain ?e xs ?y (?i ?y') + chain ?e xs ?y (?o2 ?y') \<noteq> 0"
    using descend(3) fun_dist_right[of "chain ?e xs ?y"]
    by (metis (no_types, lifting) add_eq_0_iff_both_eq_0 append_Nil chain.simps(1)
        chain_append_not_zero(1) descend.prems(20) descend.prems(21) descend.prems(31)
        endo_f_n0_n0_closed)

  have nez: "?b (chain ?e xs ?y (?o2 ?y')) \<noteq> 0"
    using descend by blast

  have "?b (chain ?e xs ?y (?o2 ?y')) = ?b (chain ?e xs ?y (\<Sum>z \<in> ?N2. ?e2 z ?y' (?f2 z)))"
    apply (subst outf_fg_unfold[of h2 ?y'])
    using \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close> plus_fg_ops_exist[of h1 h2] \<open>?y' \<in> ?N1\<close> plus_fg_dom_disj[of h1 h2] by blast+
  also have "... = ?b (\<Sum>z \<in> ?N2. chain ?e xs ?y (?e2 z ?y' (?f2 z)))"
    apply (subst fun_dist_right''[where g="chain ?e xs ?y" and E="E"])
    using dom_fg_finite endo_chain_closed[of ?e E xs ?y] descend by blast+
  also have "... = ?b (\<Sum>z \<in> ?N2. chain ?e xs ?y (?e2 z ?y' (\<Sum>xs'\<in>l_lists' ?N2 (card ?N2). chain ?e2 xs' z (?i2 (hd (xs' @ [z]))))))"
    apply (subst sum.cong, simp)
    apply (subst unroll_flow_eq_eff_acyclic'[of ?N2 ?e2 ?f2 ?i2 E "card ?N2"], simp_all add: descend)
    using \<open>?N2 = ?N2'\<close> \<open>eff_acyclic' h2\<close> unfolding eff_acyclic'_def apply simp
     apply (metis descend.prems(23) disjoint_iff_not_equal dom_fg_bot dom_fi_int_fg inf_bot_right nbot_fg_to_flow_eq2')
    by (metis Suc_leI card_gt_0_iff dom_fg_finite equals0D)
  also have "... = ?b (\<Sum>z \<in> ?N2. \<Sum>xs'\<in>l_lists' ?N2 (card ?N2). chain ?e xs ?y (?e2 z ?y' (chain ?e2 xs' z (?i2 (hd (xs' @ [z]))))))"
    apply (subst (2) sum.cong, simp)
    apply (subst fun_dist_right''[where xs="l_lists' ?N2 (card ?N2)" and E="E" and g="?e2 _ ?y'"], simp, simp add: descend, simp add: descend)
     apply (subst fun_dist_right''[where xs="l_lists' ?N2 (card ?N2)" and E="E" and g="chain ?e xs ?y"], simp_all add: descend)
    apply (rule endo_chain_closed, simp_all add: descend)
    using descend by blast
  also have "... = ?b (\<Sum>z \<in> ?N2. \<Sum>xs'\<in>l_lists' ?N2 (card ?N2). chain ?e xs ?y (?e z ?y' (chain ?e2 xs' z (?i2 (hd (xs' @ [z]))))))"
    using edge_fg_plus_fg_on2'[of h1 h2, symmetric] \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close>  by simp
  also have "... = ?b (\<Sum>z \<in> ?N2. \<Sum>xs'\<in>l_lists' ?N2 (card ?N2). chain ?e xs ?y (?e z ?y' (chain ?e xs' z (?i2 (hd (xs' @ [z]))))))"
    apply (subst sum.cong, simp, subst sum.cong, simp)
    apply (subst chain_cong'[where f="?e2" and g="?e" and N="?N2"])
    using edge_fg_plus_fg_on2[of h1 h2] \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close>
    unfolding l_lists'_def by simp_all
  also have "... = ?b (\<Sum>z \<in> ?N2. \<Sum>xs'\<in>l_lists' ?N2 (card ?N2). chain ?e xs ?y (chain ?e (xs' @ [z]) ?y' (?i2 (hd (xs' @ [z])))))"
    by (subst sum_cong2, auto, subst chain_extend_right[symmetric], auto)
  also have "... = ?b (\<Sum>z \<in> ?N2. \<Sum>xs'\<in>l_lists' ?N2 (card ?N2). chain ?e (xs' @ [z] @ xs) ?y (?i2 (hd (xs' @ [z]))))"
    apply (subst sum_cong2, auto)
    subgoal for z xs'
    using chain_append_nonempty[where f="?e" and xs="xs' @ [z]" and ys="xs"] by simp
    done
  also have "... = ?b (\<Sum>xs'\<in>l_lists ?N2 (card ?N2 + 1). chain ?e (xs' @ xs) ?y (?i2 (hd xs')))"
    apply (subst sum.cartesian_product)
    apply (subst sum.reindex_cong[where l="\<lambda>xs. (last xs, butlast xs)" and A="?N2 \<times> l_lists' ?N2 (card ?N2)" and B="l_lists ?N2 (card ?N2 + 1)"], intro inj_onI)
    unfolding l_lists_def apply auto[1]  apply (metis Suc_le_lessD append_butlast_last_id length_greater_0_conv)
    unfolding l_lists'_def l_lists_def image_def
      apply auto
    subgoal for a b by (rule exI[where x="b @ [a]"], simp)
    using Suc_le_lessD last_in_set apply blast
     apply (simp add: in_set_butlastD subsetD)
    by (smt One_nat_def append_Cons append_butlast_last_id append_eq_append_conv2 append_self_conv list.size(3) not_one_le_zero)
  finally have "?b (\<Sum>xs'\<in>l_lists ?N2 (card ?N2 + 1). chain ?e (xs' @ xs) ?y (?i2 (hd xs'))) \<noteq> 0"
    using nez by simp
  then have "(\<Sum>xs'\<in>l_lists ?N2 (card ?N2 + 1). ?b (chain ?e (xs' @ xs) ?y (?i2 (hd xs')))) \<noteq> 0"
    apply (subst (asm) fun_dist_right''[where xs="l_lists ?N2 (card ?N2 + 1)" and E=E])
    using l_lists_finite[of ?N2] dom_fg_finite[of h2] apply auto[1]
    using endo_chain_closed[of ?e' E] \<open>End_closed E\<close> \<open>id \<in> E\<close> \<open>\<forall>x y. edge_fg h' x y \<in> E\<close> by blast+
  then obtain xs' where xs'props:
    "xs' \<in> l_lists ?N2 (card ?N2 + 1)" "?b (chain ?e (xs' @ xs) ?y (?i2 (hd xs'))) \<noteq> 0"
    using sum.not_neutral_contains_not_neutral by blast
  then have "length xs' \<ge> 1" "length xs' \<le> card ?N2" "xs' \<noteq> []" "set xs' \<subseteq> ?N2"
    unfolding l_lists_def by auto

  have xsin: "hd xs' \<in> ?N2"
    using xs'props set_hd_in unfolding l_lists_def by blast

  have "\<exists>ys. ?b (chain ?e (xs' @ xs) ?y (chain ?e' ys (hd ((xs' @ xs) @ as @ [b])) (?i' (hd (ys @ (xs' @ xs) @ as @ [b]))))) \<noteq> 0
              \<and> chain ?e' ys (hd ((xs' @ xs) @ as @ [b])) (?i' (hd (ys @ (xs' @ xs) @ as @ [b]))) \<le> ?i2' (hd ((xs' @ xs) @ as @ [b])) \<and>
             set ys \<subseteq> dom_fg h'"
  proof (cases "?b (chain ?e (xs' @ xs) ?y (?i' (hd (xs' @ xs @ as @ [b])))) \<noteq> 0")
    case True
    show ?thesis
      apply (rule exI[where x="[]"])
      using True \<open>h' = h1' + h2'\<close>  apply simp
      apply (rule inf_fg_le_inf_fg2[of h1' h2'])
      using descend.prems(15) apply blast
      using \<open>xs' \<noteq> []\<close> descend.prems(25) xsin(1) apply auto[1]
      by auto
  next
    case False
    then have Y': "?b (chain (edge_fg h) (xs' @ xs) ?y (?i' (hd xs'))) = 0"
      using \<open>xs' \<noteq> []\<close> by simp
    have Y: "?i2 (hd xs') = ?i (hd xs') + ?o1 (hd xs')"
      using flow_eq_to_sum[of h2 h1] \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close> \<open>hd xs' \<in> ?N2\<close> \<open>xs' \<noteq> []\<close>
      by (simp add: algebra_simps)
    have X: "?b (chain ?e (xs' @ xs) ?y (?o1 (hd xs'))) \<noteq> 0"
      using xs'props(2)
      apply (subst (asm) Y)
      apply (subst (asm) endo_sum_closed[where E=E])
        apply (fold comp_def, rule End_closedE(2), simp_all add: descend)
        apply (rule endo_chain_closed, auto simp: descend)
      using descend apply blast
        apply (rule endo_chain_closed, auto simp: descend)
      using descend apply blast
      using Y' descend by auto
    have inf2: "?i2 = ?i2'"
      by (metis descend.prems(23) int_fg_to_inf_fg)
    show ?thesis
      apply (subst inf2[symmetric])
      apply (rule descend(2)[of "xs' @ xs" h' h h1 h2 h2' h1'])
      using \<open>xs' \<noteq> []\<close> X apply auto[2]
      using plus_fg_dom_un[of h1 h2] \<open>h = h1 + h2\<close> \<open>h \<noteq> bot\<close> \<open>set xs' \<subseteq> ?N2\<close> \<open>set xs \<subseteq> ?N\<close> apply auto[1]
      using descend apply blast+
      using \<open>h = h1 + h2\<close> apply (simp add: algebra_simps)
      using \<open>h' = h1' + h2'\<close> apply (simp add: algebra_simps)
      using \<open>xs' \<noteq> []\<close> \<open>set xs' \<subseteq> ?N2\<close> apply auto[1]
      using descend apply blast+
      done
  qed
  then obtain ys' where ys'def: "?b (chain ?e (xs' @ xs) ?y (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b]))))) \<noteq> 0"
      "chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b]))) \<le> ?i2' (hd (xs' @ xs @ as @ [b]))" "set ys' \<subseteq> dom_fg h'"
    using append_assoc by auto

  have xsin: "hd (xs @ [?y]) \<in> -?N2" "hd xs' \<in> ?N2"
    using xsin \<open>hd (xs @ as @ [b]) \<in> ?N1\<close>
     apply simp_all
    by (metis descend.prems(11) descend.prems(14) dom_fg_plus_fg_iff dom_fg_plus_fg_subs1 subsetD)

  have S1: "hd xs' \<noteq> hd (xs @ [?y])"
    using xsin by auto

  have "?e' = ?e2' on ?N2'"
    using edge_fg_plus_fg_on2[of h1' h2']
    using descend by blast

  let ?m = "chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b])))"
  have "\<forall>m\<le>inf_fg h2 (hd xs'). cap_fg h2 (hd xs') (hd (xs @ [?y])) m = cap_fg h2' (hd xs') (hd (xs @ [?y])) m"
    using xsin \<open>\<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\<close>
      \<open>dom_fg h2 = dom_fg h2'\<close> by blast
  moreover have inf2eq: "inf_fg h2' = inf_fg h2" "inf_fg h1' = inf_fg h1"
    using \<open>int_fg h1 = int_fg h1'\<close> \<open>int_fg h2 = int_fg h2'\<close> by (metis int_fg_to_inf_fg)+
  ultimately have cap_eq: "cap_fg h2 (hd xs') (hd (xs @ [?y])) ?m = cap_fg h2' (hd xs') (hd (xs @ [?y])) ?m"
    using  ys'def(2) \<open>xs' \<noteq> []\<close> by auto

  from ys'def have "0 < ?b (chain ?e xs ?y (chain ?e xs' (hd (xs @ [?y])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b]))))))"
    apply (subst (asm) chain_append_nonempty)
    unfolding comp_def
    using gr_zeroI by blast
  also have "... \<le> ?b (chain ?e xs ?y (cap_fg h2 (hd (xs' @ [(hd (xs @ [?y]))])) (hd (xs @ [?y])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b]))))))"
    apply (rule pos_endo_mono'_closed[where f="?b" and E=E])
      apply (rule pos_endo_mono'_closed[where f="chain ?e xs ?y" and E=E])
        apply (subst \<open>h = h1 + h2\<close>, subst chain_cong''[OF edge_fg_plus_fg_on2])
    using descend apply blast
    using xs'props unfolding l_lists_def apply blast
       apply (rule chain_le_cap'[where E=E])
    using xs'props unfolding l_lists_def apply blast
    using xs'props unfolding l_lists_def apply auto[1]
    using xs'props unfolding l_lists_def apply auto[1]
            apply (fact dom_fg_finite)
    using descend apply blast
          apply simp
    using descend apply blast+
    apply (rule endo_chain_closed)
    using descend apply blast+
    apply (rule endo_chain_closed)
    using descend by blast+
  also have "... = ?b (chain ?e xs ?y (cap_fg h2' (hd xs') (hd (xs @ [?y])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b]))))))"
    using cap_eq \<open>xs' \<noteq> []\<close> by simp
  also have "... = ?b (chain ?e xs ?y ((\<delta> (hd xs') (hd (xs @ [?y])) + (\<Sum>ns\<in>l_lists' ?N2' (card ?N2'). chain2 ?e2' (hd xs') ns (hd (xs @ [?y])))) (chain ?e' ys' (hd (xs' @ xs @ as @ [b]))(?i' (hd (ys' @ xs' @ xs @ as @ [b]))))))"
    apply (subst cap_unrolled_closed[where E=E], simp_all)
    using descend apply blast+
    using descend.prems(25) xsin(2) by blast
  also have "... = ?b (chain ?e xs ?y (((\<Sum>ns\<in>l_lists' ?N2' (card ?N2'). chain2 ?e2' (hd xs') ns (hd (xs @ [?y])))) (chain ?e' ys' (hd (xs' @ xs @ as @ [b]))(?i' (hd (ys' @ xs' @ xs @ as @ [b]))))))"
    using \<open>hd xs' \<noteq> hd (xs @ [?y])\<close> \<open>xs' \<noteq> []\<close> unfolding \<delta>_def by simp
  also have "... = ?b (\<Sum>ns\<in>l_lists' ?N2' (card ?N2'). chain ?e xs ?y (chain2 ?e2' (hd xs') ns (hd (xs @ [?y])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b]))))))"
    apply (subst fun_dist_right''[symmetric, where E=E and xs="l_lists' ?N2' (card ?N2')" and g="chain ?e xs ?y"], simp_all)
      apply (rule endo_chain_closed)
    using descend apply blast+
    by (subst plus_fun_apply_iterated[OF l_lists'_finite[OF dom_fg_finite]], simp)
  also have "... = (\<Sum>ns\<in>l_lists' ?N2' (card ?N2'). ?b (chain ?e xs ?y (chain2 ?e2' (hd xs') ns (hd (xs @ [?y])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b])))))))"
    apply (subst fun_dist_right''[where E=E and xs="l_lists' ?N2' (card ?N2')"], simp_all)
    using endo_chain_closed[of "edge_fg h'" E as b] descend by blast+
  finally have "(\<Sum>ns\<in>l_lists' ?N2' (card ?N2').  ?b (chain ?e xs ?y (chain2 ?e2' (hd xs') ns (hd (xs @ [?y])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b]))))))) \<noteq> 0"
    using zero_less_iff_neq_zero by blast
  then obtain ys where ys: "ys \<in> l_lists' ?N2' (card ?N2')" "?b (chain ?e xs ?y (chain2 ?e2' (hd xs') ys (hd (xs @ [?y])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b])))))) \<noteq> 0"
    by auto
  then have "?b (chain ?e xs ?y (chain2 ?e2' (hd xs') ys (hd (xs @ [?y])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b])))))) \<noteq> 0"
    by simp
  then have "?b (chain ?e xs ?y (chain ?e2' (hd xs' # ys) (hd (xs @ [?y])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b])))))) \<noteq> 0"
    by (simp add: chain_chain2)
  then have "?b (chain ?e xs ?y (chain ?e' (hd xs' # ys) (hd (xs @ [?y])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b])))))) \<noteq> 0"
    apply (subst (asm) chain_cong[symmetric, OF on_eq_superset[of "set (hd xs' # ys)", OF _ edge_fg_plus_fg_on2[of h1' h2']]])
    using \<open>h' = h1' + h2'\<close> \<open>h' \<noteq> bot\<close> \<open>set xs' \<subseteq> dom_fg h2\<close> \<open>?N2 = ?N2'\<close> ys xsin unfolding l_lists'_def by auto
  then have T: "?b (chain ?e xs ?y (chain ?e' (ys' @ hd xs' # ys) (hd (xs @ [?y])) (?i' (hd (ys' @ xs' @ xs @ as @ [b]))))) \<noteq> 0"
    by (subst chain_append, simp_all add: \<open>xs' \<noteq> []\<close>)

  have "chain ?e' (hd xs' # ys) (hd (xs @ as @ [b])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b])))) =
            chain ?e2' (hd xs' # ys) (hd (xs @ as @ [b])) (chain ?e' ys' (hd (xs' @ xs @ as @ [b])) (?i' (hd (ys' @ xs' @ xs @ as @ [b]))))"
    apply (subst \<open>h' = h1' + h2'\<close>)
    apply (subst chain_cong[OF on_eq_superset[of "set (hd xs' # ys)", OF _ edge_fg_plus_fg_on2]])
    using \<open>h' = h1' + h2'\<close> \<open>h' \<noteq> bot\<close> apply simp_all
    using \<open>set xs' \<subseteq> dom_fg h2\<close> \<open>?N2 = ?N2'\<close> ys xsin unfolding l_lists'_def by auto
  also have "... \<le> chain ?e2' (hd xs' # ys) (hd (xs @ as @ [b])) (inf_fg h2' (hd (xs' @ xs @ as @ [b])))"
    apply (rule pos_endo_mono'_closed[OF ys'def(2), where f="chain ?e2' (hd xs' # ys) (hd (xs @ as @ [b]))" and E=E])
    using endo_chain_closed[of ?e2' E] descend by blast+
  also have "... \<le> inf_fg h1' (hd (xs @ as @ [b]))"
    using \<open>xs' \<noteq> []\<close> apply simp
    apply (subst chain_inf_fg_le_inf_fg[of h' E h2' "hd xs' # ys" "hd (xs @ as @ [b])" h1', simplified])
    using \<open>h' = h1' + h2'\<close> \<open>h' \<noteq> bot\<close> apply (simp add: algebra_simps)
    using descend apply blast+
    using \<open>set xs' \<subseteq> dom_fg h2\<close> \<open>?N2 = ?N2'\<close> ys unfolding l_lists'_def apply auto[1]
    using descend.prems(13,24) \<open>h' = h1' + h2'\<close> \<open>h' \<noteq> bot\<close> plus_fg_comm descend by blast+
  finally have T': "chain (edge_fg h') (ys' @ hd xs' # ys) (hd (xs @ as @ [b])) (inf_fg h' (hd ((ys' @ xs') @ xs @ as @ [b]))) \<le> inf_fg h1' (hd (xs @ as @ [b]))"
    by (simp add: \<open>xs' \<noteq> []\<close> chain_append_nonempty)

  have S2: "hd ((ys' @ xs') @ xs @ as @ [b]) = hd ((ys' @ hd xs' # ys) @ xs @ as @ [b])"
    using \<open>xs' \<noteq> []\<close> by (simp add: hd_append)

  show ?case
    apply (rule exI[where x="ys' @ hd xs' # ys"], intro conjI)
    using T \<open>xs' \<noteq> []\<close> ys'def
      apply (smt Nil_is_append_conv append_self_conv2 hd_append2 list.discI list.sel(1))
    using T' inf2eq S2 apply auto
    using \<open>set xs' \<subseteq> ?N2\<close> \<open>h' = h1' + h2'\<close> \<open>h' \<noteq> bot\<close> \<open>xs' \<noteq> []\<close> ys'def ys descend.prems(25) xsin(2)
    unfolding l_lists'_def by auto
qed

lemma eff_acyclic_sourced_path_in_bigraph_case:
  fixes E :: "('m \<Rightarrow> 'm :: pos_cancel_comm_monoid_add) set"
  assumes ea: "\<not> eff_acyclic' (h1' + h2')" "eff_acyclic' (h1 + h2)" "eff_acyclic' h1"
    "eff_acyclic' h2" "eff_acyclic' h1'" "eff_acyclic' h2'"
    and def: "h1 + h2 \<noteq> bot" "h1' + h2' \<noteq> bot"
    and dom: "End_closed E" "\<forall>x y. edge_fg (h1' + h2') x y \<in> E" "\<forall>x y. edge_fg h1' x y \<in> E" "id \<in> E"
      "\<forall>x y. edge_fg h1 x y \<in> E" "\<forall>x y. edge_fg h2 x y \<in> E" "\<forall>x y. edge_fg h1' x y \<in> E"
      "\<forall>x y. edge_fg h2' x y \<in> E" "\<forall>x y. edge_fg (h1 + h2) x y \<in> E" "(\<lambda>_. 0) \<in> E"
    and inf: "inf_fg (h1 + h2) = inf_fg (h1' + h2')" "int_fg h1 = int_fg h1'" "int_fg h2 = int_fg h2'"
    and ext:
      "\<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"
    and cycle_ne0: "k \<ge> 1" "xs \<in> k_lists (dom_fg (h1' + h2')) k"
      "chain (edge_fg (h1' + h2')) xs (hd xs) (flow_fg (h1' + h2') (hd xs)) \<noteq> 0"
    and True: "hd xs \<in> dom_fg h1'"
  shows "\<exists>xs y. chain (edge_fg (h1' + h2')) xs y (inf_fg (h1 + h2) (hd xs)) \<noteq> 0 \<and>
                y \<in> set  xs \<and> set xs \<subseteq> dom_fg (h1' + h2')"
proof -
  let ?h' = "h1' + h2'" let ?h = "h1 + h2"
  let ?N' = "dom_fg ?h'"
  let ?e' = "edge_fg ?h'" let ?e = "edge_fg ?h"
  let ?f' = "flow_fg ?h'"
  let ?N1' = "dom_fg h1'" let ?N2' = "dom_fg h2'"
  let ?e1' = "edge_fg h1'" let ?f1' = "flow_fg h1'"
  let ?i' = "inf_fg ?h'" let ?o' = "outf_fg ?h'" let ?i = "inf_fg ?h" let ?o2' = "outf_fg h2'"
  let ?i1' = "inf_fg h1'" let ?i2 = "inf_fg h2"
  let ?e1' = "edge_fg h1'" let ?e2 = "edge_fg h2"
  let ?o2 = "outf_fg h2" let ?N2' = "dom_fg h2'" let ?N2 = "dom_fg h2" let ?N1 = "dom_fg h1"
  let ?N1' = "dom_fg h1'"

  have xs_ne: "xs \<noteq> []" "length xs \<ge> 1"
    using cycle_ne0 unfolding k_lists_def by auto

  have domeq: "?N2 = ?N2'" "?N1 = ?N1'"
    by (metis dom_fi_int_fg inf)+

  have "?N1' \<inter> ?N2' = {}" "set xs \<subseteq> ?N1' \<union> ?N2'"
    using def cycle_ne0 unfolding k_lists_def by auto
  moreover have "?f' (hd xs) = ?f1' (hd xs)"
    using flow_fg_plus_fg_on1[of h1' h2'] True assms by simp
  moreover have "chain (edge_fg (h1' + h2')) xs (hd xs) \<in> E"
    using endo_chain_closed assms by simp
  ultimately obtain xs' where xs':
    "chain ?e' xs (hd xs) (chain ?e1' xs' (hd xs) (?i1' (if xs' \<noteq> [] then hd xs' else hd xs))) \<noteq> 0"
    "set xs' \<subseteq> ?N1'"
    using cycle_ne0 eff_acyclic_flow_is_sourced[of h1' "chain ?e' xs (hd xs)" "hd xs" E] ea dom
    by auto
  moreover have "?i1' = (\<lambda>x. ?i' x + ?o2' x) on ?N1'"
    using flow_eq_to_sum[of h1' h2'] assms by simp
  ultimately have
    "chain ?e' xs (hd xs) (chain ?e' xs' (hd xs) (?i' (hd (xs' @ xs)) + ?o2' (hd (xs' @ xs)))) \<noteq> 0"
    apply (subst chain_cong[of xs' ?e' ?e1'])
     apply (simp add: True def(2) edge_fg_plus_fg_on1 subsetD)
    by (smt True hd_append2 hd_in_set self_append_conv2 subsetD)
  then have "chain ?e' xs (hd xs) (chain ?e' xs' (hd xs) (?i' (hd (xs' @ xs)))) +
                 chain ?e' xs (hd xs) (chain ?e' xs' (hd xs) (?o2' (hd (xs' @ xs)))) \<noteq> 0"
    apply (subst (asm) endo_sum_closed[where f="chain ?e' xs' (hd xs)" and E=E])
      apply (simp add: dom endo_chain_closed)
    using assms apply simp
    using \<open>chain (edge_fg (h1' + h2')) xs (hd xs) \<in> E\<close> dom(1) endo_sum_closed by fastforce
  then consider (a) "chain ?e' xs (hd xs) (chain ?e' xs' (hd xs) (?i' (hd (xs' @ xs)))) \<noteq> 0" |
    (b) "chain ?e' xs (hd xs) (chain ?e' xs' (hd xs) (?o2' (hd (xs' @ xs)))) \<noteq> 0" by auto
  then show ?thesis
  proof cases
    case a
    then have *: "chain ?e' (xs' @  xs) (hd xs) (?i' (hd (xs' @ xs))) \<noteq> 0"
      using chain_append[of  xs ?e' xs' "last xs"]
      unfolding comp_def
      by (simp add: chain_append_nonempty xs_ne)
    show ?thesis
      apply (rule exI[where x="xs' @ xs"])
      apply (rule exI[where x="hd xs"])
      apply (intro conjI)
      using * xs_ne inf \<open>xs \<noteq> []\<close> apply simp
      using \<open>xs \<noteq> []\<close> apply simp
      using \<open>set xs \<subseteq> ?N1' \<union> ?N2'\<close> \<open>h1' + h2' \<noteq> bot\<close> xs' by auto
  next
    case b
    then have X: "chain ?e' (xs' @ xs) (hd xs) (?o2 (hd (xs' @ xs))) \<noteq> 0"
      apply (subst chain_append_nonempty) using \<open>xs \<noteq> []\<close>
      by (metis def hd_append2 inf(3) outf_fg_eqI plus_fg_ops_exist)
    have "\<exists>ys. chain ?e' (xs' @ xs) (hd xs) (chain ?e' ys (hd (xs' @ xs @ [hd xs])) (?i (hd (ys @ xs' @ xs @ [hd xs])))) \<noteq> 0 \<and>
     chain (edge_fg (h1' + h2')) ys (hd (xs' @ xs @ [hd xs])) (inf_fg (h1 + h2) (hd (ys @ xs' @ xs @ [hd xs]))) \<le> inf_fg h1 (hd (xs' @ xs @ [hd xs])) \<and>
     set ys \<subseteq> dom_fg h1' \<union> dom_fg h2'"
      apply (rule eff_acyclic_sourced_path_in_bigraph'[of ?h' "xs' @ xs" "hd xs" ?h "[]" h2 h1 h1' h2' E "card (dom_fg (h1 + h2))", simplified])
      using X \<open>xs \<noteq> []\<close> apply (metis hd_append2 self_append_conv2)
      using True apply blast
      using ea dom apply blast+
      using \<open>?N1 = ?N1'\<close> ext apply simp
      using \<open>?N2 = ?N2'\<close>[symmetric] ext apply simp
                      apply (metis True \<open>set xs' \<subseteq> dom_fg h1'\<close> hd_append2 hd_in_set self_append_conv2 subsetD xs_ne(1))
      using ea dom def inf apply blast+
           apply (metis dom_fi_int_fg inf(2))
          apply (metis dom_fi_int_fg inf(3))
      using inf dom apply simp_all
      by (metis \<open>set xs \<subseteq> dom_fg h1' \<union> dom_fg h2'\<close> \<open>set xs' \<subseteq> dom_fg h1'\<close> sup.coboundedI1)
    then obtain ys where ys: "chain ?e' (xs' @ xs) (hd xs) (chain ?e' ys (hd (xs' @ xs @ [hd xs])) (?i (hd (ys @ xs' @ xs @ [hd xs])))) \<noteq> 0"
      "set ys \<subseteq> dom_fg h1' \<union> dom_fg h2'"
      by blast
    then have T: "chain ?e' (ys @ xs' @ xs) (hd xs) (?i (hd (ys @ xs' @ xs @ [hd xs]))) \<noteq> 0"
      using chain_append_nonempty[symmetric, of ?e' "xs' @ xs" "hd xs" ys "?i (hd (ys @ xs' @ xs @ [hd xs]))"]
      by simp
    show ?thesis
      apply (rule exI[where x="ys @ xs' @ xs"])
      apply (rule exI[where x="hd xs"])
      apply (intro conjI)
      using T \<open>xs \<noteq> []\<close> apply (metis append_self_conv2 hd_append2)
      using \<open>xs \<noteq> []\<close> \<open>set xs \<subseteq> dom_fg h1' \<union> dom_fg h2'\<close> \<open>set xs' \<subseteq> dom_fg h1'\<close> \<open>h1' + h2' \<noteq> bot\<close> ys by auto
  qed
qed

lemma eff_acyclic_sourced_path_in_bigraph:
  fixes E :: "('m \<Rightarrow> 'm :: pos_cancel_comm_monoid_add) set"
  assumes ea: "\<not> eff_acyclic' (h1' + h2')" "eff_acyclic' (h1 + h2)" "eff_acyclic' h1"
    "eff_acyclic' h2" "eff_acyclic' h1'" "eff_acyclic' h2'"
    and def: "h1 + h2 \<noteq> bot" "h1' + h2' \<noteq> bot"
    and dom: "End_closed E" "\<forall>x y. edge_fg (h1' + h2') x y \<in> E"
      "\<forall>x y. edge_fg h1' x y \<in> E" "id \<in> E"
      "\<forall>x y. edge_fg h1 x y \<in> E" "\<forall>x y. edge_fg h2 x y \<in> E"
      "\<forall>x y. edge_fg h1' x y \<in> E" "\<forall>x y. edge_fg h2' x y \<in> E"
      "\<forall>x y. edge_fg (h1 + h2) x y \<in> E" "(\<lambda>_. 0) \<in> E"
    and inf: "inf_fg (h1 + h2) = inf_fg (h1' + h2')"
      "int_fg h1 = int_fg h1'" "int_fg h2 = int_fg h2'"
    and ext: "\<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 "\<exists>xs y. chain (edge_fg (h1' + h2')) xs y (inf_fg (h1 + h2) (hd xs)) \<noteq> 0 \<and>
    y \<in> set  xs \<and> set xs \<subseteq> dom_fg (h1' + h2')"
proof -
  let ?h' = "h1' + h2'"
  let ?N' = "dom_fg ?h'" let ?e' = "edge_fg ?h'" let ?f' = "flow_fg ?h'"

  obtain k xs where cycle_ne0: "k \<ge> 1" "xs \<in> k_lists ?N' k" "chain ?e' xs (hd xs) (?f' (hd xs)) \<noteq> 0"
    using ea unfolding eff_acyclic'_def eff_acyclic_def by blast

  show ?thesis
  proof (cases "hd xs \<in> dom_fg h1'")
    case True
    show ?thesis
      using eff_acyclic_sourced_path_in_bigraph_case[of h1' h2' h1 h2] assms True cycle_ne0
      by blast
  next
    case False
    then have "hd xs \<in> dom_fg h2'"
      by (metis (mono_tags, lifting) UnE cycle_ne0 def k_lists_def mem_Collect_eq plus_fg_dom_un
          set_hd_in)
    then show ?thesis
      using eff_acyclic_sourced_path_in_bigraph_case[of h2' h1' h2 h1] assms cycle_ne0
      by (smt add.commute)
  qed
qed

end


theory PrefixMatch
imports IPv4Addr "autocorres-0.98/lib/WordLemmaBucket"
begin

subsection{*Definition*}

record prefix_match =
  pfxm_prefix :: ipv4addr
  pfxm_length :: nat
abbreviation "pfxm_mask x \<equiv> mask (32 - pfxm_length x)"

definition valid_prefix :: "prefix_match \<Rightarrow> bool" where
  "valid_prefix pf = ((pfxm_mask pf) AND pfxm_prefix pf = 0)"
lemma valid_prefix_E: "valid_prefix pf \<Longrightarrow> ((pfxm_mask pf) AND pfxm_prefix pf = 0)"
  unfolding valid_prefix_def .
lemma valid_preifx_alt_def: "valid_prefix p = (pfxm_prefix p AND (2 ^ (32 - pfxm_length p) - 1) = 0)"
  unfolding valid_prefix_def
  unfolding mask_def
  using word_bw_comms(1)
   arg_cong[where f = "\<lambda>x. (pfxm_prefix p && x - 1 = 0)"]
   shiftl_1
  by metis

subsection{*Address Semantics*}

definition prefix_match_semantics :: "prefix_match \<Rightarrow> ipv4addr \<Rightarrow> bool" where
(*"prefix_match_semantics m a = (pfxm_prefix m \<le> a \<and> a \<le> pfxm_prefix m OR ((1 << (32 - pfxm_length m)) - 1))"*)
"prefix_match_semantics m a = (pfxm_prefix m = (NOT pfxm_mask m) AND a)"

lemma zero_prefix_match_all: "valid_prefix m \<Longrightarrow> pfxm_length m = 0 \<Longrightarrow> prefix_match_semantics m ip"
  apply(unfold prefix_match_semantics_def)
  apply(simp)
  apply(subgoal_tac "pfxm_prefix m = 0")
   apply(metis mask_32_max_word word_bool_alg.compl_one word_bool_alg.conj_zero_left)
  apply(simp add: mask_32_max_word valid_prefix_def)
done

subsection{*Set Semantics*}

definition prefix_to_ipset :: "prefix_match \<Rightarrow> ipv4addr set" where
  "prefix_to_ipset pfx = {pfxm_prefix pfx .. pfxm_prefix pfx OR pfxm_mask pfx}"

lemma pfx_not_empty: "valid_prefix pfx \<Longrightarrow> prefix_to_ipset pfx \<noteq> {}"
  unfolding valid_prefix_def prefix_to_ipset_def by(simp add: le_word_or2)

definition ipset_prefix_match where
  "ipset_prefix_match pfx rg = (let pfxrg = prefix_to_ipset pfx in (rg \<inter> pfxrg, rg - pfxrg))"
lemma ipset_prefix_match_m[simp]:  "fst (ipset_prefix_match pfx rg) = rg \<inter> (prefix_to_ipset pfx)" by(simp only: Let_def ipset_prefix_match_def, simp)
lemma ipset_prefix_match_nm[simp]: "snd (ipset_prefix_match pfx rg) = rg - (prefix_to_ipset pfx)" by(simp only: Let_def ipset_prefix_match_def, simp)
lemma ipset_prefix_match_distinct: "rpm = ipset_prefix_match pfx rg \<Longrightarrow>
  (fst rpm) \<inter> (snd rpm) = {}" by force
lemma ipset_prefix_match_complete: "rpm = ipset_prefix_match pfx rg \<Longrightarrow>
  (fst rpm) \<union> (snd rpm) = rg" by force

subsection{*Equivalence Proofs*}

lemma helper1: "NOT (0\<Colon>32 word) = x\<^sub>1\<^sub>9 OR NOT x\<^sub>1\<^sub>9" using word_bool_alg.double_compl by simp
lemma helper2: "(x\<^sub>0\<Colon>32 word) AND NOT 0 = x\<^sub>0" by simp
lemma helper3: "(x\<^sub>4\<^sub>8\<Colon>32 word) OR x\<^sub>4\<^sub>9 = x\<^sub>4\<^sub>8 OR x\<^sub>4\<^sub>9 AND NOT x\<^sub>4\<^sub>8" using helper1 helper2 by (metis word_oa_dist2)

lemma pfx_match_addr_ipset: "valid_prefix rr \<Longrightarrow> prefix_match_semantics rr addr \<Longrightarrow> (addr \<in> prefix_to_ipset rr)"
  by(simp add: prefix_match_semantics_def prefix_to_ipset_def valid_prefix_def)
    (metis helper3 le_word_or2 word_and_le2 word_bool_alg.conj_commute word_bool_alg.disj_commute)
(* inversion should hold\<dots> *)

lemma packet_ipset_prefix_eq1:
  assumes "addr \<in> addrrg"
  assumes "valid_prefix match"
  assumes "\<not>prefix_match_semantics match addr"
  shows "addr \<in> (snd (ipset_prefix_match match addrrg))"
using assms
proof -
  have "pfxm_prefix match \<le> addr \<Longrightarrow> \<not> addr \<le> pfxm_prefix match || pfxm_mask match"
  proof -
    case goal1
    have a1: "pfxm_mask match AND pfxm_prefix match = 0"
      using assms(2) unfolding valid_prefix_def .
    have a2: "pfxm_prefix match \<noteq> NOT pfxm_mask match AND addr"
      using assms(3) unfolding prefix_match_semantics_def .
    have f1: "pfxm_prefix match = pfxm_prefix match AND NOT pfxm_mask match"
      using a1 by (metis mask_eq_0_eq_x word_bw_comms(1))
    hence f2: "\<forall>x\<^sub>1\<^sub>1. (pfxm_prefix match OR x\<^sub>1\<^sub>1) AND NOT pfxm_mask match = pfxm_prefix match OR x\<^sub>1\<^sub>1 AND NOT pfxm_mask match"
      by (metis word_bool_alg.conj_disj_distrib2)
    moreover
    { assume "\<not> pfxm_prefix match \<le> addr AND NOT pfxm_mask match"
      hence "\<not> (pfxm_prefix match \<le> addr \<and> addr \<le> pfxm_prefix match OR pfxm_mask match)"
        using f1 by (metis neg_mask_mono_le) }
    moreover
    { assume "pfxm_prefix match \<le> addr AND NOT pfxm_mask match \<and> addr AND NOT pfxm_mask match \<noteq> (pfxm_prefix match OR pfxm_mask match) AND NOT pfxm_mask match"
      hence "\<exists>x\<^sub>0. \<not> addr AND NOT mask x\<^sub>0 \<le> (pfxm_prefix match OR pfxm_mask match) AND NOT mask x\<^sub>0"
        using f2 by (metis dual_order.antisym word_bool_alg.conj_cancel_right word_log_esimps(3))
      hence "\<not> (pfxm_prefix match \<le> addr \<and> addr \<le> pfxm_prefix match OR pfxm_mask match)"
        using neg_mask_mono_le by auto }
    ultimately show "?case"
      using a2 by (metis goal1 word_bool_alg.conj_cancel_right word_bool_alg.conj_commute word_log_esimps(3))
  qed
  from this show ?thesis using assms(1)
    unfolding ipset_prefix_match_def Let_def snd_conv prefix_to_ipset_def
    by simp
qed

lemma packet_ipset_prefix_eq2:
  assumes "addr \<in> addrrg"
  assumes "valid_prefix match"
  assumes "prefix_match_semantics match addr"
  shows "addr \<in> (fst (ipset_prefix_match match addrrg))"
using assms
  apply(subst ipset_prefix_match_def)
  apply(simp only: Let_def fst_def Case_def)
  apply(simp add: prefix_to_ipset_def)
  apply(transfer)
  apply(simp only: prefix_match_semantics_def valid_prefix_def)
  apply(simp add: word_and_le1)
  apply(metis helper3 le_word_or2 word_bw_comms(1) word_bw_comms(2))
done

lemma packet_ipset_prefix_eq3:
  assumes "addr \<in> addrrg"
  assumes "valid_prefix match"
  assumes "addr \<in> (snd (ipset_prefix_match match addrrg))"
  shows "\<not>prefix_match_semantics match addr"
using assms
  apply(subst(asm) ipset_prefix_match_def)
  apply(simp only: Let_def fst_def Case_def)
  apply(simp)
  apply(subst(asm) prefix_to_ipset_def)
  apply(transfer)
  apply(simp only: prefix_match_semantics_def valid_prefix_def Set_Interval.ord_class.atLeastAtMost_iff prefix_to_ipset_def)
  apply(simp)
  apply(metis helper3 le_word_or2 word_and_le2 word_bw_comms(1) word_bw_comms(2))
done

lemma packet_ipset_prefix_eq4:
  assumes "addr \<in> addrrg"
  assumes "valid_prefix match"
  assumes "addr \<in> (fst (ipset_prefix_match match addrrg))"
  shows "prefix_match_semantics match addr"
using assms
proof -
  have "pfxm_prefix match = ~~ pfxm_mask match && addr"
  proof -
    have a1: "pfxm_mask match && pfxm_prefix match = 0" using assms(2) unfolding valid_prefix_def .
    have a2: "pfxm_prefix match \<le> addr \<and> addr \<le> pfxm_prefix match || pfxm_mask match"
      using assms(3) unfolding ipset_prefix_match_def Let_def fst_conv prefix_to_ipset_def by simp
    have f2: "\<forall>x\<^sub>0. pfxm_prefix match && ~~ mask x\<^sub>0 \<le> addr && ~~ mask x\<^sub>0"
      using a2 neg_mask_mono_le by blast
    have f3: "\<forall>x\<^sub>0. addr && ~~ mask x\<^sub>0 \<le> (pfxm_prefix match || pfxm_mask match) && ~~ mask x\<^sub>0"
      using a2 neg_mask_mono_le by blast
    have f4: "pfxm_prefix match = pfxm_prefix match && ~~ pfxm_mask match"
      using a1 by (metis mask_eq_0_eq_x word_bw_comms(1))
    hence f5: "\<forall>x\<^sub>6. (pfxm_prefix match || x\<^sub>6) && ~~ pfxm_mask match = pfxm_prefix match || x\<^sub>6 && ~~ pfxm_mask match"
      using word_ao_dist by (metis)
    have f6: "\<forall>x\<^sub>2 x\<^sub>3. addr && ~~ mask x\<^sub>2 \<le> x\<^sub>3 \<or> \<not> (pfxm_prefix match || pfxm_mask match) && ~~ mask x\<^sub>2 \<le> x\<^sub>3"
      using f3 dual_order.trans by auto
    have "pfxm_prefix match = (pfxm_prefix match || pfxm_mask match) && ~~ pfxm_mask match"
      using f5 by auto
    hence "pfxm_prefix match = addr && ~~ pfxm_mask match"
      using f2 f4 f6 by (metis eq_iff)
    thus "pfxm_prefix match = ~~ pfxm_mask match && addr"
      by (metis word_bw_comms(1))
  qed
  from this show ?thesis unfolding prefix_match_semantics_def .
qed

lemma packet_ipset_prefix_eq24:
  assumes "addr \<in> addrrg"
  assumes "valid_prefix match"
  shows "prefix_match_semantics match addr = (addr \<in> (fst (ipset_prefix_match match addrrg)))"
using packet_ipset_prefix_eq2[OF assms] packet_ipset_prefix_eq4[OF assms] by fast

lemma packet_ipset_prefix_eq13:
  assumes "addr \<in> addrrg"
  assumes "valid_prefix match"
  shows "\<not>prefix_match_semantics match addr = (addr \<in> (snd (ipset_prefix_match match addrrg)))"
using packet_ipset_prefix_eq1[OF assms] packet_ipset_prefix_eq3[OF assms] by fast

lemma prefix_match_if_in_my_set: "valid_prefix pfx \<Longrightarrow>
  prefix_match_semantics pfx (a :: ipv4addr) \<longleftrightarrow> a \<in> prefix_to_ipset pfx"
  using packet_ipset_prefix_eq24 by auto

lemma prefix_match_if_in_corny_set:
  assumes "valid_prefix pfx"
  shows "prefix_match_semantics pfx (a :: ipv4addr) \<longleftrightarrow> a \<in> ipv4range_set_from_netmask (pfxm_prefix pfx) (NOT pfxm_mask pfx)"
  unfolding prefix_match_if_in_my_set[OF assms]
  unfolding prefix_to_ipset_def ipv4range_set_from_netmask_def Let_def
  unfolding word_bool_alg.double_compl
  proof -
    case goal1
    have *: "pfxm_prefix pfx && ~~ pfxm_mask pfx = pfxm_prefix pfx"
      unfolding mask_eq_0_eq_x[symmetric] using valid_prefix_E[OF assms] word_bw_comms(1)[of "pfxm_prefix pfx"] by simp
    hence **: "pfxm_prefix pfx && ~~ pfxm_mask pfx || pfxm_mask pfx = pfxm_prefix pfx || pfxm_mask pfx"
      by simp
    show ?case unfolding * ** ..
  qed

subsection{*Range stuff*}

definition prefix_to_range :: "prefix_match \<Rightarrow> ipv4rq" where
  "prefix_to_range pfx = [pfxm_prefix pfx; pfxm_prefix pfx OR pfxm_mask pfx]"
lemma prefix_to_range_set_eq: "ipv4rq_to_set (prefix_to_range pfx) = prefix_to_ipset pfx"
  unfolding prefix_to_range_def prefix_to_ipset_def by transfer simp

definition "range_prefix_match pfx rg \<equiv> (let pfxrg = prefix_to_range pfx in
  (ipv4rq_intersection rg pfxrg, ipv4rq_setminus rg pfxrg))"
lemma range_prefix_match_set_eq:
  "(\<lambda>(r1,r2). (ipv4rq_to_set r1, ipv4rq_to_set r2)) (range_prefix_match pfx rg) = ipset_prefix_match pfx (ipv4rq_to_set rg)"
  unfolding range_prefix_match_def ipset_prefix_match_def Let_def
  using ipv4rq_intersection_set_eq ipv4rq_setminus_set_eq prefix_to_range_set_eq  by simp

end


subsection "Examples"

theory Quant_Examples
imports Quant_VCG
begin

fun sum :: "int \<Rightarrow> int" where
"sum i = (if i \<le> 0 then 0 else sum (i - 1) + i)"

abbreviation "wsum ==
  WHILE Less (N 0) (V ''x'')
  DO (''y'' ::= Plus (V ''y'') (V ''x'');;
      ''x'' ::= Plus (V ''x'') (N (- 1)))"

lemma example: "\<turnstile>\<^sub>2 {\<lambda>s. enat (2 + 3*n) + emb (s ''x'' = int n)} ''y'' ::= N 0;; wsum {\<lambda>s. 0 }"
apply(rule Seq)
 prefer 2
 apply(rule conseq)
 apply(rule While[where I="\<lambda>s. enat (3 * nat (s ''x''))"])
  apply(rule Seq)
   prefer 2
      apply(rule Assign)
      apply(rule Assign')
     apply(simp)
     apply(safe) subgoal for s apply(cases "0 < s ''x''") apply(simp)
    apply (smt Suc_eq_plus1 Suc_nat_eq_nat_zadd1 distrib_left_numeral eSuc_numeral enat_numeral eq_iff iadd_Suc_right nat_mult_1_right one_add_one plus_1_eSuc(1) plus_enat_simps(1) semiring_norm(5))
    apply(simp) done
    apply blast
  apply simp
apply(rule Assign')
apply simp
  apply(safe) subgoal for s apply(cases "s ''x'' = int n") apply(simp)
     apply (simp add: eSuc_enat plus_1_eSuc(2))
    apply simp
    done
  done

end