section {* Abstract syntax for Hybrid CSP. *}

theory HHL_SL
  imports Op_SL
begin

type_synonym now_dash = real
type_synonym dform = "history \<Rightarrow> now \<Rightarrow> now_dash \<Rightarrow> bool"

definition semd :: "history \<Rightarrow> now \<Rightarrow> now_dash \<Rightarrow> dform \<Rightarrow> bool" ("_, [_, _] |= _" 50) where
  "h, [n, m] |= H \<equiv> H h n m"

text \<open>One axiom stating that the dform formula is only decided by the interval between now and now_dash\<close>
axiomatization where
  DC : "now \<le> now' \<Longrightarrow> (\<forall>t. t > now \<and> t < now' \<longrightarrow> h t = h' t) \<Longrightarrow> (df :: dform) h now now' = df h' now now'"

subsection \<open>Duration Calculus operators and lemmas proved\<close>

text \<open>Special assertions \<and> lemmas proved\<close>

text \<open>almost P, P holds everywhere except for the rightmost point, not almost everywhere, over the interval.
The reason is that, for continuous evolution, it escapes whenever a violation is met.
A special case is that, if using almost everywhere, the differential cut rule will not hold anymore.\<close>
definition almost :: "fform \<Rightarrow> dform" where
(*"almost P \<equiv> % h n nd. (nd-n>0) & (\<not>(\<exists> a b.(n\<le>a & a<b & b\<le>nd) & (\<forall> t. t>a & t<b \<longrightarrow> \<not>P(h(t)))))"*)
(*An alternative definition of almost*)
(*"almost P \<equiv> \<lambda>h n nd. (nd-n>0) \<and> (\<forall>a\<ge>n. \<forall>b\<le>nd. a < b \<longrightarrow> (\<exists>t. t>a \<and> t<b \<and> P(h(t))))"*)
"almost P \<equiv> \<lambda>h n nd. (nd-n>0) \<and> (\<forall>t. t\<ge>n \<and> t < nd \<longrightarrow> P (h (t)))"

definition chop :: "dform \<Rightarrow> dform \<Rightarrow> dform"  ("_[^]_" 80) where
  "chop H M \<equiv> \<lambda>h n nd. \<exists>nm. nm \<ge> n \<and> nm \<le> nd \<and> H h n nm \<and> M h nm nd"

text \<open>The length of the interval l is equal to, greater than, less than T.\<close>
definition elE :: "real \<Rightarrow> dform" where
  "elE T \<equiv> \<lambda>h n nd. (nd-n) = T"
definition elG :: "real \<Rightarrow> dform" where
  "elG T \<equiv> \<lambda>h n nd. (nd-n) > T"
definition elL :: "real \<Rightarrow> dform" where
  "elL T \<equiv> \<lambda>h n nd. (nd-n) < T"

definition dAnd :: "dform \<Rightarrow> dform \<Rightarrow> dform"  (infixl "[[&]]" 79) where
  "P [[&]] Q \<equiv> \<lambda>h n m. P h n m \<and> Q h n m"
definition dOr :: "dform \<Rightarrow> dform \<Rightarrow> dform"  (infixl "[[|]]" 79) where
  "P [[|]] Q \<equiv> \<lambda>h n m. P h n m \<or> Q h n m"
definition dNot :: "dform \<Rightarrow> dform"  ("[[\<not>]]_" 79) where
  "[[\<not>]]P \<equiv> \<lambda>h n m. \<not> P h n m"
definition dImp :: "dform \<Rightarrow> dform \<Rightarrow> dform"  (infixl "[[\<longrightarrow>]]" 79) where
  "P [[\<longrightarrow>]] Q \<equiv> \<lambda>h n m. P h n m \<longrightarrow> Q h n m"

declare almost_def [simp]
declare chop_def [simp]
declare elE_def [simp]
declare elG_def [simp]
declare elL_def [simp]

text \<open>True holds almost everywhere\<close>
lemma almostf:
  "\<forall>h n nd. nd - n \<le> 0 \<or> almost fTrue h n nd"
  apply simp
  by (metis dense not_le)

text \<open>almost P \<Leftrightarrow> chop almost P almost P\<close>
lemma chopfb:
  "chop (almost P) (almost P) h n nd \<Longrightarrow> almost P h n nd"
  unfolding chop_def almost_def
  apply (rule conjI, auto)
  by (metis (poly_guards_query) less_eq_real_def less_trans not_less)

lemma chopfor:
  "chop (elE 0 [[|]]almost P) (elE 0 [[|]]almost P) h n nd \<Longrightarrow> (elE 0 [[|]]almost P) h n nd"
  unfolding dOr_def
  apply (rule disjCI, auto)
  by (metis less_eq_real_def less_trans not_less)

lemma chopf:
  "almost P h n nd \<Longrightarrow> chop (almost P) (almost P) h n nd"
  unfolding almost_def chop_def
  apply (rule exI[where x = "(n+nd)/2"])
  by auto

lemma chop0L: "chop (almost P) (elE 0) h n nd \<Longrightarrow> almost P h n nd"
  by auto

lemma chop0R: "almost P h n nd \<Longrightarrow> chop (almost P) (elE 0) h n nd"
  by auto

text \<open>Monotonicity: s \<Rightarrow> t \<Longrightarrow> almost s \<Rightarrow> almost t\<close>
lemma almostmono:
  "\<forall>s. P s \<longrightarrow> Q s \<Longrightarrow> \<forall>h n nd. almost P h n nd \<longrightarrow> almost Q h n nd"
  apply auto
  done

lemma almostint:
  "now < nowf \<Longrightarrow> \<forall>t. (t\<ge>now \<and> t<nowf) \<longrightarrow> P (f t) \<Longrightarrow> almost P f now nowf"
  apply auto
  done

subsection \<open>Inference rules for Hybrid CSP: Hybrid Hoare Logic rules\<close>

text \<open>Specification\<close>
definition Valid :: "fform \<Rightarrow> proc \<Rightarrow> fform \<Rightarrow> dform \<Rightarrow> bool" ("{_}_{_; _}" 80) where
  "Valid p c q H \<equiv> \<forall>now h now' h'. semB c now h now' h' \<longrightarrow> p (h now) \<longrightarrow> (q (h' now') \<and> H h' now now')"

definition ValidP :: "fform \<Rightarrow> fform \<Rightarrow> procP \<Rightarrow> fform \<Rightarrow> fform \<Rightarrow> dform \<Rightarrow> dform \<Rightarrow> bool"
  ("{_, _}_{_, _; _, _}" 80) where
  "ValidP pa pb c qa qb Ha Hb == (\<forall> nowp nowq fp fq nowp' nowq' fp' fq'.
    semBP c nowp fp nowq fq nowp' fp' nowq' fq'  \<longrightarrow>
    pa (fp(nowp)) \<longrightarrow>pb (fq(nowq)) \<longrightarrow>
    (qa (fp'(nowp'))\<and> qb (fq'(nowq'))\<and> (Ha fp' nowp nowp') \<and> (Hb fq' nowq nowq')))"

subsection{*Inference rules proved sound*}

(*Skip rule*)
lemma SkipRule : "\<forall> s h now now'. (p s \<longrightarrow> q s) \<and> ((elE 0) h now now'\<longrightarrow> H h now now')
         \<Longrightarrow> {p} Skip {q; H}"
by (auto simp add:Valid_def)

(*Assignment rule*)
lemma AssignRRule  :" (\<forall> s. p s \<longrightarrow> (q (% y. if (y = x) then (evalE f s) else s y)))
                   \<and> (\<forall> h now now'. ((elE 0) h now now'\<longrightarrow> H h now now')) ==>
       {p} ((RVar x) := f) {q; H}"
apply (simp add:Valid_def, auto)
done

(*Sequential rule*)
(*The proof is complicated because of the existence of chop operator.*)
lemma SequentialRule_aux : " {p} P {m; H} \<Longrightarrow> {m} Q {q; G} ==>
             {p} P;  Q {q; H [^] G}"
apply  (simp add:Valid_def, auto)
apply (subgoal_tac "now \<le> now'a \<and> now'a \<le> now'\<and> H h' now now'a = H f' now now'a")
apply metis
apply (rule conjI)
apply (cut_tac P = "P" and now = now and  now'=now'a and f = "h" and f' = "f'" in sem1, simp)
apply metis
apply (rule conjI)
apply (cut_tac P = "Q" and now = now'a and  now'=now' and f = "f'" and f' = "h'" in sem1, simp)
apply metis
apply (cut_tac P = "P" and now = now and  now'=now'a and f = "h" and f' = "f'" in sem1, simp)
apply (cut_tac df = H and now = now and now' = now'a and h = h' and h' = f' in DC, auto)
apply (cut_tac P = Q in  sem2, auto)
done

lemma SequentialRule : " {p} P {m; H} \<Longrightarrow> {m} Q {q; G} ==> (\<forall> h m n. (H [^] G) h m n \<longrightarrow> M h m n) \<Longrightarrow>
             {p} P;  Q {q; M}"
apply (cut_tac P = P and  Q = Q  and  p = p and  q =q and m = m and H = H  and  G = G in  SequentialRule_aux, auto)
apply (simp add:Valid_def)
done

(*Conditional rule*)
lemma ConditionTRule : " ((\<forall> s. p s \<longrightarrow> ( b s)) \<and> {p} P {q; H})
             ==> {p} IF b P {q; H}"
apply (simp add:Valid_def, auto)
done

lemma ConditionFRule : " ((\<forall> s. p s \<longrightarrow> (q s \<and> (\<not>   b s))) \<and> (\<forall> h now now'. ((elE 0) h now now'\<longrightarrow> H h now now')))
                          ==> {p} IF b P {q; H}"
apply (simp add:Valid_def, auto)
done

lemma ConditionGRule : " {p [&] b} P {q; H} \<and> {p [&] ([\<not>]b)} Q {q; H}
             ==> {p} IFELSE b P Q{q; H}"
apply (simp add:Valid_def fAnd_def fNot_def, auto)
done

declare almost_def [simp del]
declare chop_def [simp del]
(*Assume v'=E is the differential equation for the continuous evolution.*)
(*This proof takes most effort for solving the invariant-related constraints, which will be passed to an
external oracle for invariant generation in fact. So don't worry.*)
lemma ContinuousRule :
"\<forall> s u. ( ( \<forall> y. y \<noteq> v \<longrightarrow> s y = u y) \<longrightarrow> (p s) \<longrightarrow> (p u)) \<and>
 ( \<forall> s.  Init s \<longrightarrow>  Inv s)
 \<and> (\<forall> s.  (p [&] (Inv) [&] ([\<not>]b)) s \<longrightarrow> q s)
 \<and> (\<forall> s. (exeFlow (<[v]:E&&Inv&b>) (Inv)) s \<longrightarrow> Inv s)
 \<and>  (\<forall> h now now'. ((elE 0) h now now' \<or> (almost (Inv [&] p  [&] b)) h now now') \<longrightarrow>
                  H h now now')
 ==> {Init [&] (p::fform)} <[v]:E&&Inv&(b)> {q; H}"
apply (simp add:Valid_def) apply clarify
apply (subgoal_tac "\<forall> t. t\<ge>now & t\<le>now' \<longrightarrow> exeFlow (<[v]:E&&Inv&b>) (Inv) (h'(t))")
prefer 2
apply (simp add:exeFlow_def)
apply (metis fAnd_def)
apply auto
apply (metis fAnd_def)
apply (subgoal_tac "(p [&] Inv) (\<lambda> y. if y = v then Solution (Flow [v] E) (h now) (now + d - now) else h now y)")
apply (simp add:fAnd_def)+
apply (rule conjI, auto)
apply (subgoal_tac "\<forall> y.  y \<noteq> v \<longrightarrow> (h(now)) y = ((\<lambda> y. if y = v
   then Solution (Flow [v] E) (h now) (now + d - now) else h now y)) y")
apply smt
apply auto
apply (subgoal_tac "exeFlow (<[v]:E&&Inv&b>) (Inv)
                    (\<lambda> y. if y =  v
        then Solution (Flow [v] E) (h now) (now+d - now) else h now y)")
apply (metis (no_types, lifting))
apply (drule_tac x = "now +d" in spec, auto)
apply (subgoal_tac "almost (Inv [&] p [&] b)
(\<lambda>t. if t \<le> now + d \<and> now < t then \<lambda> y. if y = v
then Solution (Flow [v] E) (h now) (t - now) else h now y else h t) now (now+d)", auto)
apply (rule almostint, auto)
apply (simp add:fAnd_def)
apply (rule conjI)
apply (subgoal_tac "exeFlow (<[v]:E&&Inv&b>) (Inv)
                    (\<lambda> y. if y = v
        then Solution (Flow [v] E) (h now) (t - now) else h now y)")
apply (metis (no_types, lifting))
apply (drule_tac x = "t" in spec, auto)
apply (subgoal_tac "\<forall> y. y \<noteq> v \<longrightarrow> (h(now)) y = ((\<lambda> y. if y = v
   then Solution (Flow [v] E) (h now) (t - now) else h now y)) y")
apply smt
apply auto
by (smt fAnd_def)

(*We simple extend the above rule to the general case where the continuous are a list of variables not just one.
The proof can be given in the same way.*)
primrec notcontain :: "string \<Rightarrow> string list \<Rightarrow> bool"
where
"notcontain a ([]) = True" |
"notcontain a (e # Elist) = (if a = e then False else (notcontain a Elist))"

axiomatization where ContinuousRuleGT:
" (\<forall> s. (p) s --> b s)
\<and> ( \<forall> s.  p s \<longrightarrow>  Inv s)
 \<and> (\<forall> s.  ((Inv) [&] (close (b)) [&] (close([\<not>]b))) s \<longrightarrow> q s)
 \<and> (\<forall> s. (exeFlow (<V:E&&Inv&b>) (Inv)) s \<longrightarrow> Inv s)
 \<and>  (\<forall> h now now'. ((elE 0) h now now' \<or> (almost (Inv [&]  close(b))) h now now') \<longrightarrow>
                  H h now now')
 ==> {p} <V:E&&Inv&(b)> {q; H}"

axiomatization where ContinuousRuleGF:
" \<forall> s. p s \<longrightarrow> (([\<not>] b) [&]q) s
 ==> {p} <V:E&&Inv&(b)> {q; elE 0}"

text \<open>Shallow definition: a variable does not affect the formula \<close>
definition not_in_fform:: "string \<Rightarrow> fform \<Rightarrow> bool"  where
  "not_in_fform w P = (\<forall> s u. ((\<forall> y. y \<noteq> w \<longrightarrow> s y = u y)) \<longrightarrow> (P s \<longleftrightarrow> P u))"

definition not_in_dform:: "string \<Rightarrow> dform \<Rightarrow> bool"  where
  "not_in_dform w Q = (\<forall>h l n nd. ((\<forall> y. y \<noteq> w \<longrightarrow> (\<forall> t. t \<ge> n \<and> t \<le> nd \<longrightarrow> h(t) y = l(t) y)))
  \<longrightarrow> ((Q h n nd \<longrightarrow> Q l n nd) \<and> (Q l n nd \<longrightarrow> Q h n nd)))"

lemma not_in_fform_update:
  "not_in_fform w P \<Longrightarrow> P (\<lambda>y. if y \<noteq> w then s y else c) \<longleftrightarrow> P s"
  by (simp add: not_in_fform_def)

lemma not_in_dform_update:
  "not_in_dform w Q \<Longrightarrow> Q (\<lambda>t. if t \<le> nd \<and> n \<le> t then \<lambda>y. if y \<noteq> w then h t y else l t y else h t) n nd \<longleftrightarrow> Q h n nd"
  apply (simp add:not_in_dform_def)
  by smt

text \<open>Ghost rule for continuous evolution\<close>
lemma GhostRule :
  assumes "(w \<notin> set VL)"
    and "not_in_fform w p"
    and "not_in_fform w q"
    and "not_in_dform w H"
    and "{pre} <(VL@[w]):(EL@[F])&&Inv&(b)> {post; HF}"
    and " \<forall> s. \<exists> a. (let sa = (\<lambda> y. (if y \<noteq> w then s y else a)) in p s \<longleftrightarrow>  pre sa)"
    and "\<forall> s. \<exists> a. (let sa = (\<lambda> y. (if y \<noteq> w then s y else a)) in  q s \<longleftrightarrow> post sa)"
    and "\<forall>h n nd. \<exists> xa. (let ha = (\<lambda>t. if t \<le> nd \<and> n \<le> t then (\<lambda> y. (if y \<noteq> w then h t y else xa t y)) else h t)
           in  H h n nd \<longleftrightarrow> HF ha n nd)"
  shows "{p} <VL:EL&&Inv&(b)> {q; H}"
  sorry
(*
proof -
  have "\<forall>now h now' h'.
       semB (<[v, w]:[E, F]&&Inv&b>) now h now' h' \<longrightarrow>
       (Init [&] p) (h now) \<longrightarrow> q (h' now') \<and> H h' now now'"
    using assms(4) unfolding Valid_def by auto
  have "\<forall>now h now' h'.
       semB (<[v]:[E]&&Inv&b>) now h now' h' \<longrightarrow> (Init [&] p) (h now) \<longrightarrow> q (h' now') \<and> H h' now now'"
  proof -
    {
      fix now h now' h'
      assume semE: "semB (<[v]:[E]&&Inv&b>) now h now' h'"
        and Init: "(Init [&] p) (h now)"
      define nowf where "nowf = now'"

      have semEF: "\<exists> hf. semB (<[v, w]:[E, F]&&Inv&b>) now h nowf hf \<and>
        ((\<forall> y i.(y, i) \<noteq> (fst (w), snd (w)) \<longrightarrow> (\<forall> t. t \<ge> now \<and> t \<le> nowf \<longrightarrow> hf(t) (y, i) = h'(t) (y, i))))"
        sorry
      then obtain hf where
        EF: "semB (<[v, w]:[E, F]&&Inv&b>) now h nowf hf"
        and hfh: "((\<forall> y i.(y, i) \<noteq> (fst (w), snd (w)) \<longrightarrow> (\<forall> t. t \<ge> now \<and> t \<le> nowf \<longrightarrow> hf(t) (y, i) = h'(t) (y, i))))"
        and post: "q (hf nowf) \<and> H hf now nowf"
        using assms(4) Init unfolding Valid_def by auto
      have  "((\<forall> y i.(y, i) \<noteq> (fst (w), snd (w)) \<longrightarrow> hf(nowf) (y, i) = h'(nowf) (y, i)))"
      proof -
        {
          fix y i assume yi: "(y, i) \<noteq> (fst (w), snd (w))"
          have "(\<forall> t. t \<ge> now \<and> t \<le> nowf \<longrightarrow> hf(t) (y, i) = h'(t) (y, i))" using hfh yi by auto
          then have "hf(nowf) (y, i) = h'(nowf) (y, i)" using EF sem1 by auto
        }
        then show ?thesis by auto
      qed
      then have qf: "q (h' now')" using post assms(2) not_in_fform_def unfolding nowf_def by auto
      then have Hf: "q (h' now') \<and> H h' now now'" using assms(3) hfh post unfolding not_in_dform_def nowf_def by blast
    }
    then show ?thesis by auto
  qed
  then show ?thesis unfolding Valid_def by auto
qed
*)

lemma DiffCutRule :
  assumes I: "{p} <[v]:E&&Inv&(b)> {I; almost I [[|]] elE 0}"
    and C: "{p} <[v]:E&&Inv&(b[&]I)> {q; H}"
  shows "{p} <[v]:E&&Inv&(b)> {q; H}"
proof (simp add:Valid_def, clarify)
  have "\<forall>now h now' h'. semB (<[v]:E&&Inv&b>) now h now' h' \<longrightarrow> p (h now)
    \<longrightarrow> I (h' now') \<and> (almost I [[|]] elE 0) h' now now'"
    using I unfolding Valid_def by auto
  have semI: "semB (<[v]:E&&Inv&b>) now h now' h' \<Longrightarrow> p (h now) \<Longrightarrow> semB (<[v]:E&&Inv&b [&] I>) now h now' h'"
    for now h now' h'
    apply (ind_cases "semB (<[v]:E&&Inv&b>) now h now' h'")
    subgoal
    proof -
      assume a: "p (h now)" and b: "now' = now" and c: "h' = h" and d: "([\<not>]b) (h now)"
      show "semB (<[v]:E&&Inv&b [&] I>) now h now' h'"
      proof -
        have "([\<not>] (b [&] I)) (h now)" using d unfolding fNot_def fAnd_def by auto
        then show ?thesis
          by (simp add: b c continuousBF)
      qed
    qed
    subgoal for d
    proof -
      assume a: "p (h now)" and b: "now' = now + d"
        and c: "h' = (\<lambda>t. if t \<le> now + d \<and> now < t then \<lambda> y. if y = v then Solution (Flow [v] E) (h now) (t - now) else h now y else h t)"
        and d: "0 < d" and e: "\<forall>m. m < now + d \<and> now \<le> m \<longrightarrow>
          b (if now < m then \<lambda> y. if y = v then Solution (Flow [v] E) (h now) (m - now) else h now y else h m)"
        and f: "([\<not>]b) (\<lambda> y. if y = v then Solution (Flow [v] E) (h now) (now + d - now) else h now y)"
      show "semB (<[v]:E&&Inv&b [&] I>) now h now' h'"
      proof -
        have "semB (<[v]:E&&Inv&b>) now h (now + d) h'"
          using b c d e f continuousBT[of d now v  E h b Inv] by auto
        then have "I (h' now') \<and> (almost I [[|]] elE 0) h' now now'"
          using a I b unfolding Valid_def by auto
        then have almostI: "I (h' now') \<and> (almost I) h' now now'"
          using b c d unfolding elE_def dOr_def by auto
        have "([\<not>] (b [&] I))(h' (now + d))"
          using f d c unfolding fNot_def fAnd_def by auto
        moreover have "\<forall>m. m < now + d \<and> now \<le> m \<longrightarrow> (b [&] I) (h' (m))"
          using almostI b e c unfolding almost_def fAnd_def by auto
        ultimately show ?thesis using b c d continuousBT[of d now v  E h "b[&]I" Inv] unfolding Let_def
          by auto
      qed
    qed
    done

  have "semB (<[v]:E&&Inv&b>) now h now' h' \<Longrightarrow> p (h now) \<Longrightarrow> q (h' now') \<and> H h' now now'"
    for now h now' h'
    using C semI unfolding Valid_def by meson
  then show "\<And>now h now' h'. semB (<[v]:E&&Inv&b>) now h now' h' \<Longrightarrow> p (h now) \<Longrightarrow> q (h' now') \<and> H h' now now'"
    by auto
qed

(*There are three rules for parallel  composition, which covers all the cases.*)
(*Parallel rule for the case without communication*)
lemma Parallel1Rule : "chanset P = {} \<and> chanset Q = {} \<Longrightarrow> {pp} P {qp; Hp} \<Longrightarrow> {pq} Q {qq; Hq}
                       \<Longrightarrow> {pp, pq} P||Q {qp, qq; Hp, Hq}"
apply (clarsimp simp:Valid_def ValidP_def)
by (meson semB3)

(*Parallel rule for the case with communication at the end.*)
lemma Communication_aux:
"  semBP (P; Cm (ch??(RVar x)) || Q; Cm (ch!!e)) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
    \<forall> nowp nowq fp fq nowp' nowq' fp' fq'.
          semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<longrightarrow>
          px (fp nowp) \<longrightarrow> py (fq nowq) \<longrightarrow> qx (fp' nowp') \<and> qy (fq' nowq') \<and> Hx fp' nowp nowp' \<and> Hy fq' nowq nowq' \<Longrightarrow>
       \<forall>s. qx s \<longrightarrow> rx (\<lambda> y. if y = x then evalE e s else s y) \<Longrightarrow>
       \<forall>s. qy s \<longrightarrow> ry s \<Longrightarrow>
       \<forall>h n m. (Hx[^](elE 0 [[|]]almost qx)) h n m \<longrightarrow> Gx h n m \<Longrightarrow>
       \<forall>h n m. (Hy[^](elE 0 [[|]]almost qy)) h n m \<longrightarrow> Gy h n m \<Longrightarrow>
       px (fp nowp) \<Longrightarrow> py (fq nowq) \<Longrightarrow> rx (fp' nowp') \<and> ry (fq' nowq') \<and> Gx fp' nowp nowp' \<and> Gy fq' nowq nowq'"
apply (ind_cases "semBP (P; Cm (ch??(RVar x)) || Q; Cm (ch!!e)) nowp fp nowq fq nowp' fp' nowq' fq'")
apply (simp add:chanset_def)
apply (simp add:chanset_def)
apply (subgoal_tac " qx (fp'a nowp'a) \<and> qy (fq'a nowq'a) \<and> Hx fp'a nowp nowp'a \<and> Hy fq'a nowq nowq'a")
prefer 2
apply metis
apply (rule conjI)
apply (subgoal_tac "fp' nowp' = (\<lambda> y. if y = x then evalE e (fp'a nowp'a) else (fp'a nowp'a) y)", simp)
apply (metis less_irrefl)
apply (rule conjI)
apply (metis max.cobounded1 max_def_raw not_less)
apply (rule conjI)
(*to prove GX*)
apply (subgoal_tac "(Hx[^](elE 0 [[|]] almost qx)) fp' nowp nowp'", simp)
apply (subgoal_tac "Hx fp' nowp nowp'a",simp)
prefer 2
apply (subgoal_tac "Hx fp'a nowp nowp'a = Hx fp' nowp nowp'a", simp)
apply (smt DC semB1)
apply (smt almostint chop_def dOr_def semB1)
(*to prove Gy, just copy the proof for Gx with a little adaption*)
apply (subgoal_tac "(Hy[^](elE 0 [[|]] almost qy)) fq' nowq nowq'", simp)
apply (subgoal_tac "Hy fq' nowq nowq'a",simp)
prefer 2
apply (subgoal_tac "Hy fq'a nowq nowq'a = Hy fq' nowq nowq'a", simp)
apply (smt DC semB1)
by (smt almostint chop_def dOr_def semB1)

lemma CommunicationRule :
  " ({px, py} (P || Q) {qx, qy; Hx, Hy}) \<Longrightarrow>
   (\<forall> s. qx s \<longrightarrow> (rx (% y. if (y=x) then (evalE e s) else s y)))
 \<and> (\<forall> s. qy s \<longrightarrow> ry s)
 \<and> (\<forall> h n m. (Hx[^](elE 0 [[|]]almost qx)) h n m \<longrightarrow> Gx h n m) \<and>
   (\<forall> h n m. (Hy[^](elE 0 [[|]]almost qy)) h n m \<longrightarrow> Gy h n m)
  ==>
{px, py} (P;Cm (ch??(RVar (x))))||(Q; (Cm (ch!!e))) {rx, ry; Gx, Gy}"
  apply (clarsimp simp:ValidP_def)
  apply (cut_tac P = P and Q = Q and ch = ch and px = px and py = py and rx = rx and ry = ry and
    Gx = Gx and Gy = Gy in Communication_aux, auto)
  done

(*Parallel rule for the case with non-communication process at the end.*)
lemma Parallel2_aux : "semBP (P; U || Q; V) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
        \<forall>nowp nowq fp fq nowp' nowq' fp' fq'.
          semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<longrightarrow>
          pp (fp nowp) \<longrightarrow> pq (fq nowq) \<longrightarrow> qp (fp' nowp') \<and> qq (fq' nowq') \<and>
        Hp fp' nowp nowp' \<and> Hq fq' nowq nowq' \<Longrightarrow>
       \<forall>now h now' h'. semB U now h now' h' \<longrightarrow> qp (h now) \<longrightarrow> qu (h' now') \<and> Hu h' now now' \<Longrightarrow>
       \<forall>now h now' h'. semB V now h now' h' \<longrightarrow> qq (h now) \<longrightarrow> qv (h' now') \<and> Hv h' now now' \<Longrightarrow>
       chanset P \<noteq> {} \<Longrightarrow> chanset Q \<noteq> {} \<Longrightarrow> chanset U = {} \<Longrightarrow> chanset V = {} \<Longrightarrow>
       pp (fp nowp) \<Longrightarrow> pq (fq nowq) \<Longrightarrow> qu (fp' nowp') \<and> qv (fq' nowq') \<and>
             (Hp[^]Hu) fp' nowp nowp' \<and> (Hq[^]Hv) fq' nowq nowq'"
apply (ind_cases "semBP (P; U || Q; V) nowp fp nowq fq nowp' fp' nowq' fq'")
apply (simp add:chanset_def)
prefer 2 apply (simp add:chanset_def)
prefer 2 apply (simp add:chanset_def)
apply (subgoal_tac "qp (fp'a nowp'a) \<and> qq (fq'a nowq'a) \<and> Hp fp'a nowp nowp'a \<and> Hq fq'a nowq nowq'a")
prefer 2
apply metis
apply (rule conjI) apply metis
apply (rule conjI) apply metis
apply (subgoal_tac "(Hu) fp' nowp'a nowp' ")
apply (subgoal_tac "(Hv) fq' nowq'a nowq'")
prefer 2 apply metis prefer 2 apply metis
apply (subgoal_tac " Hq fq' nowq nowq'a")
apply (subgoal_tac " Hp fp' nowp nowp'a ")
apply (rule conjI)
apply (unfold chop_def)
apply (metis sem1 semB1)
apply (metis sem1 semB1)
apply (subgoal_tac "Hp fp'a nowp nowp'a = Hp fp' nowp nowp'a", simp)
apply (smt DC sem2 semB1)
apply (subgoal_tac " Hq fq'a nowq nowq'a =  Hq fq' nowq nowq'a", simp)
by (smt DC sem2 semB1)

lemma Parallel2Rule : "{pp, pq} P||Q {qp, qq; Hp, Hq}  \<Longrightarrow> chanset P \<noteq> {} \<and> chanset Q \<noteq> {} \<Longrightarrow>
                          {qp} U {qu; Hu} \<Longrightarrow> {qq} V {qv; Hv} \<Longrightarrow> chanset U = {} \<and> chanset V = {}
                       \<Longrightarrow> {pp, pq} P; U||Q; V {qu, qv; Hp [^] Hu, Hq [^] Hv}"
apply (clarsimp simp:Valid_def ValidP_def)
apply (rule Parallel2_aux)
apply simp+
done

(*Repetition rule*)

lemma Repetition_aux_1: " semB (P* NUM 0) now h now' h' \<Longrightarrow>
       \<forall>h n m. (H[^]H) h n m \<longrightarrow> H h n m \<Longrightarrow>
       \<forall>now h now' h'. semB P now h now' h' \<longrightarrow> Inv (h now) \<longrightarrow> Inv (h' now') \<and> H h' now now' \<Longrightarrow>
       Inv (h now) \<Longrightarrow> Inv (h' now') \<and> (H h' now now' \<or> now' = now)"
  apply (ind_cases "semB (P* NUM 0) now h now' h'", auto)
  done

lemma Repetition_aux_2: " (\<And>now h now' h'. semB (P* NUM N) now h now' h' \<Longrightarrow> Inv (h now) \<Longrightarrow> Inv (h' now') \<and> (H h' now now' \<or> now' = now)) \<Longrightarrow>
       semB (P* NUM Suc N) now h now' h' \<Longrightarrow>
       \<forall>h n m. (H[^]H) h n m \<longrightarrow> H h n m \<Longrightarrow>
       \<forall>now h now' h'. semB P now h now' h' \<longrightarrow> Inv (h now) \<longrightarrow> Inv (h' now') \<and> H h' now now' \<Longrightarrow>
       Inv (h now) \<Longrightarrow> Inv (h' now') \<and> (H h' now now' \<or> now' = now)"
  apply (ind_cases "semB (P* NUM Suc N) now h now' h'")
  apply simp
  by (smt DC chop_def sem1 sem2)

lemma Repetition_aux: "semB (P* NUM N) now h now' h' \<Longrightarrow>
                     \<forall>h n m. (H[^]H) h n m \<longrightarrow> H h n m \<Longrightarrow>
                     \<forall>now h now' h'. semB P now h now' h' \<longrightarrow> Inv (h now) \<longrightarrow> Inv (h' now') \<and> H h' now now' \<Longrightarrow>
                     Inv (h now) \<Longrightarrow> Inv (h' now') \<and> (H [[|]] (\<lambda>h n nd. nd = n)) h' now now'"
apply (simp add:dOr_def)
apply (induction N arbitrary: now h now' h')
apply (cut_tac H = H and P = P and now = now and h = h and now' = now' and h' = h' in Repetition_aux_1)
apply simp+
apply (cut_tac P = P and N = N and now = now and h = h and h' = h' and Inv = Inv in Repetition_aux_2, auto)
done

lemma RepetitionRule: "\<forall>h n m. (H[^]H) h n m \<longrightarrow> H h n m \<Longrightarrow> {I} P {I; H}
                      ==>  {I} P*&&I {I; (H [[|]] (elE 0))} "
  apply (simp add:Valid_def) apply clarify
  apply (rule Repetition_aux)
   apply simp+
  done

lemma JoinRule : "{p} P {m; H} \<Longrightarrow> {p} Q {q; G} ==>
             {p} P [[ Q {m [|] q; H [[|]] G}"
  apply (simp add:Valid_def fOr_def dOr_def, auto)
    done

(*Consequence rule*)
lemma ConsequenceRule : "{px} P {qx; Hx}
                  \<and> (\<forall> s. p s \<longrightarrow> px s) \<and> (\<forall> s. qx s \<longrightarrow> q s)
                  \<and> (\<forall> h n m. Hx h n m \<longrightarrow> H h n m)
            ==> {p} P {q; H}"
apply (simp add:Valid_def)
done

lemma RepetitionRule_a :  "\<forall>h n m. (H[^]H) h n m \<longrightarrow> H h n m \<Longrightarrow> {I} P {I; H}
                      ==>  {I} P*&&I {I; ((elE 0) [[|]] H)} "
                      apply (cut_tac px = "I" and qx = I and Hx = "(H [[|]] (elE 0))" in ConsequenceRule, auto)
                      apply (cut_tac RepetitionRule, auto)
                      using dOr_def by auto

(*Case analysis rule*)
lemma CaseRule : "{p [&] pb} P {q; H} \<and> {(p [&] ([\<not>]pb))} P {q; H}
   ==> {p} P {q; H}"
apply (simp add:Valid_def fAnd_def fNot_def, auto)
apply metis+
  done

lemma interrupt1R: "{px, py} (P || Q) {qx, qy; Hx, Hy} \<Longrightarrow>
         (\<forall> s. qx s \<longrightarrow> (rx (% y. if (y=x) then (evalE e s) else s y))) \<Longrightarrow>
         (\<forall> s. qy s \<longrightarrow> ry s) \<Longrightarrow>
         (\<forall> h n m. (Hx[^](elE 0 [[|]] almost Inv)) h n m \<longrightarrow> Gx h n m) \<Longrightarrow>
         (\<forall> h n m. (Hy[^](elE 0 [[|]] almost qy)) h n m \<longrightarrow> Gy h n m) \<Longrightarrow>
          {px, py} (P; ((<VL:EL && Inv&b>)[[ ((ch??(RVar x))) \<rightarrow> Skip))||(Q; (Cm (ch!!e))) {rx, ry; Gx, Gy}"
  sorry

lemma interrupt2R: "{px, py} (P || Q) {qx, qy; Hx, Hy} \<Longrightarrow>
         (\<forall> s. qy s \<longrightarrow> (ry (% y. if (y=x) then (evalE e s) else s y))) \<Longrightarrow>
         (\<forall> s. qx s \<longrightarrow> rx s) \<Longrightarrow>
         (\<forall> h n m. (Hx[^](elE 0 [[|]] almost Inv)) h n m \<longrightarrow> Gx h n m) \<Longrightarrow>
         (\<forall> h n m. (Hy[^](elE 0 [[|]] almost qy)) h n m \<longrightarrow> Gy h n m) \<Longrightarrow>
          {px, py} (P; ((<VL:EL && Inv&b>)[[ ((ch!!e)) \<rightarrow> Skip))||(Q; (Cm (ch??(RVar x)))) {rx, ry; Gx, Gy}"
  sorry

end


theory Union_Find2
  imports
    Refine_Imperative_HOL.IICF
begin

section \<open>General definitions\<close>
record 'v node =
  (* node_value :: "'v" *)
  parent :: "'v"
  rank :: "nat"

type_synonym 'v "union_find" = "('v, 'v node) map"

inductive in_component :: "'v union_find \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> bool" where
  in_component_root[simp, intro]: "\<lbrakk>m v = Some node; parent node = v\<rbrakk> \<Longrightarrow> in_component m v v" |
  in_component_suc: "\<lbrakk>m v = Some node; parent node = p; v \<noteq> p; in_component m p c\<rbrakk> \<Longrightarrow> in_component m v c"

definition same_component :: "'v union_find \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> bool"
  where "same_component m a b \<equiv> \<exists>c. in_component m a c \<and> in_component m b c"

definition valid_union_find :: "'v union_find \<Rightarrow> bool"
  where "valid_union_find m \<equiv> \<forall>v\<in>dom m. \<exists>c. in_component m v c"

definition preserve_component :: "'v union_find \<Rightarrow> 'v union_find \<Rightarrow> bool"
  where "preserve_component m m' \<equiv> (\<forall>v\<in>dom m. (\<forall>c. in_component m v c \<longleftrightarrow> in_component m' v c))"

definition preserve_component_union :: "'v union_find \<Rightarrow> 'v union_find \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> bool"
  where "preserve_component_union m m' a b \<equiv> (\<forall>x\<in>dom m. \<forall>y\<in>dom m.
    (same_component m' x y \<longleftrightarrow> (same_component m x y \<or>
                                same_component m x a \<and> same_component m b y \<or>
                                same_component m b x \<and> same_component m y a)))"

section \<open>Helping lemmas\<close>
lemma same_component_simps[simp]:
  assumes "in_component m a c"
  assumes "in_component m b c"
  shows "same_component m a b"
  using assms unfolding same_component_def
  by auto

lemma in_component_unique:
  assumes "in_component m a c"
  assumes "in_component m a c'"
  shows "c = c'"
  using assms
proof (induction m a c rule: in_component.induct)
  case (in_component_root m a)
  with in_component.simps[of m a c']
    show ?case by auto
next
  case (in_component_suc m a p c)
  with in_component.simps[of m a c']
    show ?case by auto
qed

lemma not_same_component:
  assumes "in_component m a c"
  assumes "in_component m b d"
  assumes "c \<noteq> d"
  shows "\<not> same_component m a b"
proof
  assume "same_component m a b"
  then obtain c' where "in_component m a c' \<and> in_component m b c'"
    unfolding same_component_def by auto
  with assms in_component_unique[of m a c c'] in_component_unique[of m b d c']
  show False
    by simp
qed

lemma same_component_refl[simp]:
  assumes "valid_union_find m"
  assumes "v \<in> dom m"
  shows "same_component m v v"
  using assms unfolding same_component_def valid_union_find_def
  by auto

lemma same_component_sym:
  assumes "same_component m a b"
  shows "same_component m b a"
  using assms unfolding same_component_def
  by auto

lemma in_component_dom[simp]:
  assumes "in_component m v c"
  shows "v \<in> dom m" "c \<in> dom m"
  using assms
  by (induction m v c rule: in_component.induct) auto

lemma same_component_dom[simp]:
  assumes "same_component m x y"
  shows "x \<in> dom m" "y \<in> dom m"
  using assms unfolding same_component_def
  by (auto elim: in_component.cases)

lemma preserve_component_refl[simp]: "preserve_component l l"
  unfolding preserve_component_def by auto

lemma same_component_parent:
  assumes "valid_union_find m"
  assumes "m v = Some node"
  shows "same_component m v (parent node)"
proof -
  from assms obtain c where c: "in_component m v c"
    unfolding valid_union_find_def by blast
  with assms(2) have "in_component m (parent node) c"
    by (auto intro:in_component.cases[OF c])
  with c show ?thesis
    unfolding same_component_def by auto
qed

lemma same_component_trans:
  assumes "same_component m a b"
  assumes "same_component m b d"
  shows "same_component m a d"
proof -
  from assms(1) obtain c where c: "in_component m a c \<and> in_component m b c"
    unfolding same_component_def by blast
  from assms(2) obtain c' where c': "in_component m b c' \<and> in_component m d c'"
    unfolding same_component_def by blast
  from c c' have "c = c'"
    by (auto simp: in_component_unique)
  with c c' show ?thesis unfolding same_component_def
    by auto
qed

lemma in_component_same:
  assumes "in_component m v c"
  shows "same_component m v c"
proof -
  from assms have "in_component m c c"
    by (induction m v c rule: in_component.induct) auto
  with assms show ?thesis
    by simp
qed

lemma in_component_parent_root:
  assumes "in_component m v c"
  shows "parent (the (m c)) = c"
  using assms
  by (induction m v c rule: in_component.induct) auto

lemma preserve_component_impl:
  assumes "preserve_component m m'"
  assumes "in_component m v c"
  shows "in_component m' v c"
  using assms
  unfolding preserve_component_def
  by (meson domI in_component.cases)

lemma preserve_component_impl_same:
  assumes "preserve_component m m'"
  shows "\<forall>a \<in> dom m. \<forall>b \<in> dom m. same_component m a b \<longleftrightarrow> same_component m' a b"
  using assms
  unfolding preserve_component_def same_component_def
  by blast

lemma preserve_component_union_impl:
  assumes "preserve_component_union m m' a b"
  assumes "same_component m x y"
  shows "same_component m' x y"
  using assms
  unfolding preserve_component_union_def
  by auto

lemma preserve_component_union_impl_rev:
  assumes "preserve_component_union m m' a b"
  assumes "same_component m' x y"
  assumes "\<not> same_component m x y"
  assumes "dom m = dom m'"
  shows "same_component m x a \<and> same_component m b y \<or>
         same_component m b x \<and> same_component m y a"
  using assms same_component_dom[OF assms(2)]
  unfolding preserve_component_union_def
  by fast

lemma preserve_component_union_same:
  assumes "preserve_component_union m m' root_a root_b"
  assumes "in_component m a root_a"
  assumes "in_component m b root_b"
  shows "same_component m' a b"
  using assms in_component_same[OF assms(2)] in_component_same[OF assms(3)]
  unfolding preserve_component_union_def same_component_def
  by auto

lemma preserve_exists:
  assumes "valid_union_find m"
  assumes "preserve_component m m'"
  shows "dom m \<subseteq> dom m'"
proof
  fix x
  assume asm: "x \<in> dom m"
  with assms(1) obtain c where c: "in_component m x c"
    unfolding valid_union_find_def by auto
  with assms(2) asm in_component_dom(1)[of m' x c] show "x \<in> dom m'"
    unfolding preserve_component_def by blast
qed

lemma preserve_component_trans:
  assumes "valid_union_find m"
  assumes "preserve_component m m'"
  assumes "preserve_component m' m''"
  shows "preserve_component m m''"
  using assms preserve_exists[OF assms(1,2)]
  unfolding preserve_component_def
  by blast

lemma preserve_component_union_trans:
  assumes "preserve_component m m'"
  assumes "a \<in> dom m"
  assumes "b \<in> dom m"
  assumes "dom m = dom m'"
  assumes "preserve_component_union m' m'' a b"
  shows "preserve_component_union m m'' a b"
proof -
  have "same_component m'' x y \<longleftrightarrow>
          (same_component m x y \<or>
           same_component m x a \<and> same_component m b y \<or>
           same_component m b x \<and> same_component m y a)" (is "?lhs \<longleftrightarrow> ?rhs")
    if x: "x\<in>dom m" and y: "y\<in>dom m" for x y
  proof
    assume ?lhs
    with assms(4,5) x y have "same_component m' x y \<or>
           same_component m' x a \<and> same_component m' b y \<or>
           same_component m' b x \<and> same_component m' y a"
      unfolding preserve_component_union_def by simp
    with preserve_component_impl_same[OF assms(1)] x y assms(2,3) show ?rhs
      by blast
  next
    assume ?rhs
    with preserve_component_impl_same[OF assms(1)] x y assms(2,3)
    have "same_component m' x y \<or>
           same_component m' x a \<and> same_component m' b y \<or>
           same_component m' b x \<and> same_component m' y a"
      unfolding preserve_component_union_def by blast
    with assms(4,5) x y show ?lhs
      unfolding preserve_component_union_def by simp
  qed
  then show ?thesis
    unfolding preserve_component_union_def by simp
qed

lemma preserve_component_union_trans':
  assumes "preserve_component_union m m' a b"
  assumes "preserve_component m' m''"
  assumes "dom m = dom m'"
  shows "preserve_component_union m m'' a b"
proof -
  have "same_component m'' x y \<longleftrightarrow>
          (same_component m x y \<or>
           same_component m x a \<and> same_component m b y \<or>
           same_component m b x \<and> same_component m y a)" (is "?lhs \<longleftrightarrow> ?rhs")
    if x: "x\<in>dom m" and y: "y\<in>dom m" for x y
  proof
    assume ?lhs
    with preserve_component_impl_same[OF assms(2)] x y assms(3)
    have "same_component m' x y"
      unfolding preserve_component_union_def by blast
    with assms(1) x y show ?rhs
      unfolding preserve_component_union_def by simp
  next
    assume ?rhs
    with assms(1) x y
    have "same_component m' x y"
      unfolding preserve_component_union_def by simp
    with preserve_component_impl_same[OF assms(2)] x y assms(3) show ?lhs
      unfolding preserve_component_union_def by blast
  qed
  then show ?thesis
    unfolding preserve_component_union_def by simp
qed

lemma preserve_component_union_trans_roots:
  assumes "preserve_component m m'"
  assumes "dom m = dom m'"
  assumes "in_component m' a root_a"
  assumes "in_component m' b root_b"
  assumes "preserve_component_union m' m'' root_a root_b"
  shows "preserve_component_union m m'' a b"
proof -
  from assms(3,4) have a: "a\<in>dom m'" and b: "b\<in>dom m'"
    by auto
  have "same_component m'' x y \<longleftrightarrow>
          (same_component m x y \<or>
           same_component m x a \<and> same_component m b y \<or>
           same_component m b x \<and> same_component m y a)" (is "?lhs \<longleftrightarrow> ?rhs")
    if x: "x\<in>dom m" and y: "y\<in>dom m" for x y
  proof
    assume ?lhs
    with x y assms(2,5) have "same_component m' x y \<or>
           same_component m' x root_a \<and> same_component m' root_b y \<or>
           same_component m' root_b x \<and> same_component m' y root_a"
      unfolding preserve_component_union_def by simp
    with same_component_trans[OF _ same_component_sym[OF in_component_same[OF assms(3)]]]
         same_component_trans[OF in_component_same[OF assms(4)]]
    have "same_component m' x y \<or>
           same_component m' x a \<and> same_component m' b y \<or>
           same_component m' b x \<and> same_component m' y a"
      by auto
    with preserve_component_impl_same[OF assms(1)] x y assms(2) a b show ?rhs
      by blast
  next
    assume ?rhs
    with preserve_component_impl_same[OF assms(1)] x y assms(2) a b
    have "same_component m' x y \<or>
           same_component m' x a \<and> same_component m' b y \<or>
           same_component m' b x \<and> same_component m' y a"
      unfolding preserve_component_union_def by blast
    with same_component_trans[OF same_component_sym[OF in_component_same[OF assms(4)]]]
         same_component_trans[OF _ in_component_same[OF assms(3)]]
    have "same_component m' x y \<or>
           same_component m' x root_a \<and> same_component m' root_b y \<or>
           same_component m' root_b x \<and> same_component m' y root_a"
      by blast
    with assms(2,5) x y show ?lhs
      unfolding preserve_component_union_def by simp
  qed
  then show ?thesis
    unfolding preserve_component_union_def by simp
qed

lemma weaker_preserve_component:
  assumes "preserve_component m m'"
  assumes "same_component m' a b"
  assumes "a \<in> dom m"
  assumes "b \<in> dom m"
  shows "preserve_component_union m m' a b"
proof -
  have "same_component m' x y \<longleftrightarrow>
          (same_component m x y \<or>
           same_component m x a \<and> same_component m b y \<or>
           same_component m b x \<and> same_component m y a)" (is "?lhs \<longleftrightarrow> ?rhs")
    if xy: "x\<in>dom m" "y\<in>dom m" for x y
  proof
    assume ?lhs
    with preserve_component_impl_same[OF assms(1)] xy show ?rhs by blast
  next
    assume ?rhs
    from preserve_component_impl_same[OF assms(1)] assms(2,3,4)
    have "same_component m a b"
      by blast
    with `?rhs` same_component_trans[OF same_component_trans, of m x a b y]
         same_component_sym[OF same_component_trans[OF same_component_trans, of m y a b x]]
    have "same_component m x y"
      by auto
    with preserve_component_impl_same[OF assms(1)] xy show ?lhs
      by blast
  qed
  then show ?thesis
    unfolding preserve_component_union_def by simp
qed

lemma preserve_component_union_sym:
  assumes "preserve_component_union m m' a b"
  shows "preserve_component_union m m' b a"
  using assms same_component_sym[of m]
  unfolding preserve_component_union_def
  by blast

section \<open>Helping functions\<close>
subsection \<open>Update parent\<close>
definition update_parent_spec :: "'v union_find \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> ('v union_find) nres"
  where "update_parent_spec m v p \<equiv> do {
    ASSERT (v \<in> dom m \<and> p \<in> dom m  \<and> parent (the (m v)) = v \<and> parent (the (m p)) = p \<and> valid_union_find m);
    SPEC (\<lambda>m'. valid_union_find m' \<and> preserve_component_union m m' v p \<and> dom m = dom m' \<and> in_component m' v p)
  }"

definition update_parent :: "'v union_find \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> ('v union_find) nres"
  where "update_parent m v p = mop_map_update v \<lparr>
    parent = p,
    rank = rank (the (m v))
  \<rparr> m"

lemma update_parent_new_component:
  assumes "m p = Some node_p"
  assumes "parent node_p = p"
  shows "in_component (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) v p"
proof -
  from assms in_component_root[of "m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)" p node_p]
  have "in_component (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) p p"
    by fastforce
  with in_component_suc[of "m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)" v _ p p]
  show ?thesis
    by fastforce
qed

lemma update_parent_in_component_changed:
  assumes "m p = Some node_p"
  assumes "parent node_p = p"
  assumes "in_component m v' v"
  shows "in_component (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) v' p"
proof -
  from assms(1,2) update_parent_new_component have
    "in_component (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) v p"
    by fast
  with assms(3) show ?thesis
  proof (induction m v' v rule: in_component.induct)
    case (in_component_root m v' node)
    then show ?case
      by auto
  next
    case (in_component_suc m v' node p' v)
    with in_component.in_component_suc[OF _ in_component_suc.hyps(2,3), of "m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)" p]
    show ?case
      by (cases "v = v'") fastforce+
  qed
qed

lemma update_parent_in_component_unchanged:
  assumes "m p = Some node_p"
  assumes "parent node_p = p"
  assumes "in_component m v' c"
  assumes "c \<noteq> v"
  assumes "in_component m v v"
  shows "in_component (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) v' c"
proof -
  from assms(1,2) update_parent_new_component have
    asm: "in_component (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) v p"
    by fast
  with assms(3,4,5) show ?thesis
  proof (induction m v' c rule: in_component.induct)
    case (in_component_root m v' node)
    then show ?case
      by auto
  next
    case (in_component_suc m v' node p' c)
    show ?case
    proof (cases "v = v'")
      case True
      with in_component_unique[OF in_component.in_component_suc[OF in_component_suc.hyps]]
           in_component_suc.prems(1,2)
      show ?thesis by simp
    next
      case False
      with in_component_suc in_component.in_component_suc[OF _ in_component_suc.hyps(2,3), of "m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)" c]
      show ?thesis
        by fastforce
    qed
  qed
qed

lemma update_parent_in_component:
  assumes "m p = Some node_p"
  assumes "parent node_p = p"
  assumes "m v = Some node_v"
  assumes "parent node_v = v"
  assumes "in_component m v' c"
  shows "in_component (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) v' c \<or>
         in_component (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) v' p"
  using update_parent_in_component_changed[OF assms(1,2,5)]
        update_parent_in_component_unchanged[OF assms(1,2,5) _ in_component_root[of m, OF assms(3,4)]]
  by auto

lemma update_parent_same_component:
  assumes "m p = Some node_p"
  assumes "parent node_p = p"
  assumes "m v = Some node_v"
  assumes "parent node_v = v"
  assumes "same_component m a b"
  shows "same_component (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) a b"
proof -
  let ?m = "m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)"
  from assms(5) obtain c where "in_component m a c \<and> in_component m b c"
    unfolding same_component_def by auto
  with update_parent_in_component_changed[of m p node_p _ v, OF assms(1,2)]
       update_parent_in_component_unchanged[of m p node_p _ c, OF assms(1,2) _ _ in_component_root[of m, OF assms(3,4)]]
  have "(in_component ?m a c \<and> in_component ?m b c) \<or>
        (in_component ?m a p \<and> in_component ?m b p)"
    by fast
  then show ?thesis
    unfolding same_component_def by auto
qed

lemma update_parent_valid:
  assumes "m p = Some node_p"
  assumes "parent node_p = p"
  assumes "m v = Some node_v"
  assumes "parent node_v = v"
  assumes "valid_union_find m"
  shows "valid_union_find (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>))"
  unfolding valid_union_find_def
proof
  fix v'
  let ?m = "m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)"
  assume "v' \<in> dom ?m"
  with assms(3) have "v' \<in> dom m"
    by auto
  with assms(5) obtain c where "in_component m v' c"
    unfolding valid_union_find_def by auto
  from update_parent_in_component[OF assms(1,2,3,4) this]
  show "\<exists>c. in_component (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) v' c"
    by auto
qed

lemma update_parent_preserve_component_union:
  assumes "m p = Some node_p"
  assumes "parent node_p = p"
  assumes "m v = Some node_v"
  assumes "parent node_v = v"
  assumes "valid_union_find m"
  shows "preserve_component_union m (m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)) v p"
proof -
  let ?m = "m(v \<mapsto> \<lparr>parent = p, rank = rank (the (m v))\<rparr>)"
  have "same_component ?m x y \<longleftrightarrow>
          (same_component m x y \<or>
           same_component m x v \<and> same_component m p y \<or>
           same_component m p x \<and> same_component m y v)" (is "?lhs \<longleftrightarrow> ?rhs")
    if xy: "x\<in>dom m" "y\<in>dom m" for x y
  proof
    assume ?lhs
    then obtain c where c: "in_component ?m x c" "in_component ?m y c"
      unfolding same_component_def by blast
    from assms(5) xy obtain cx cy where cxy: "in_component m x cx" "in_component m y cy"
      unfolding valid_union_find_def by blast
    show ?rhs
    proof (cases "cx = v")
      case True
      with cxy update_parent_in_component_changed[of m, OF assms(1,2), of x v]
      have cx': "in_component ?m x p"
        by simp
      show ?thesis
      proof (cases "cy = v")
        case True
        with `cx = v` have "cx = cy" by simp
        with cxy show ?thesis
          by simp
      next
        case False
        from update_parent_in_component_unchanged[OF assms(1,2) cxy(2) False in_component_root[of m, OF assms(3,4)]]
        have cy': "in_component ?m y cy" .
        from in_component_unique[OF c(1) cx'] in_component_unique[OF c(2) cy']
        have "p = cy"
          by simp
        with cxy `cx = v` in_component_same same_component_sym
        show ?thesis
          by fast
      qed
    next
      case False
      from update_parent_in_component_unchanged[OF assms(1,2) cxy(1) False in_component_root[of m, OF assms(3,4)]]
      have cx': "in_component ?m x cx" .
      show ?thesis
      proof (cases "cy = v")
        case True
        with cxy update_parent_in_component_changed[of m, OF assms(1,2), of y v]
        have cy': "in_component ?m y p"
          by simp
        from in_component_unique[OF c(1) cx'] in_component_unique[OF c(2) cy']
        have "p = cx"
          by simp
        with cxy `cy = v` in_component_same same_component_sym
        show ?thesis
          by fast
      next
        case False
        from update_parent_in_component_unchanged[OF assms(1,2) cxy(2) False in_component_root[of m, OF assms(3,4)]]
        have cy': "in_component ?m y cy" .
        from in_component_unique[OF c(1) cx'] in_component_unique[OF c(2) cy']
        have "cx = cy"
          by simp
        with cxy show ?thesis
          by simp
      qed
    qed
  next
    assume ?rhs
    with update_parent_same_component[OF assms(1,2,3,4)]
    have "same_component ?m x y \<or>
           same_component ?m x v \<and> same_component ?m p y \<or>
           same_component ?m p x \<and> same_component ?m y v"
      by auto
    with in_component_same[OF update_parent_new_component[of m, OF assms(1,2), of v]]
      same_component_trans[of ?m] same_component_sym[of ?m]
    show ?lhs by blast
  qed
  then show ?thesis
    unfolding preserve_component_union_def by simp
qed

theorem update_parent_correct: "(update_parent, update_parent_spec)\<in>Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding update_parent_spec_def update_parent_def
  apply refine_vcg
  apply (auto intro: update_parent_new_component
                     update_parent_preserve_component_union
                     update_parent_valid)
  done

subsection \<open>Update rank\<close>
definition update_rank_spec :: "'v union_find \<Rightarrow> 'v \<Rightarrow> nat \<Rightarrow> ('v union_find) nres"
  where "update_rank_spec m v r \<equiv> do {
    ASSERT (v \<in> dom m \<and> valid_union_find m);
    SPEC (\<lambda>m'. valid_union_find m' \<and> preserve_component m m' \<and> dom m = dom m')
  }"

definition update_rank :: "'v union_find \<Rightarrow> 'v \<Rightarrow> nat \<Rightarrow> ('v union_find) nres"
  where "update_rank m v r = mop_map_update v \<lparr>
    parent = parent (the (m v)),
    rank = r
  \<rparr> m"

lemma preserve_parents_in_component:
  assumes "dom m = dom m'"
  assumes "\<forall>v' \<in> dom m. parent (the (m v')) = parent (the (m' v'))"
  shows "in_component m v c \<longleftrightarrow> in_component m' v c"
proof
  assume "in_component m v c"
  then show "in_component m' v c" using assms
  proof (induction m v c rule: in_component.induct)
    case (in_component_root m v node)
    then have "v = parent (the (m' v))"
      by force
    with in_component_root in_component.in_component_root[of m' v] show ?case
      by fastforce
  next
    case (in_component_suc m v node p c)
    then have "p = parent (the (m' v))"
      by force
    with in_component_suc in_component.in_component_suc[of m' v _ p] show ?case
      by fastforce
  qed
next
  assume "in_component m' v c"
  then show "in_component m v c" using assms
  proof (induction m' v c rule: in_component.induct)
    case (in_component_root m' v node)
    then have "v = parent (the (m v))"
      by force
    with in_component_root in_component.in_component_root[of m v] show ?case
      by fastforce
  next
    case (in_component_suc m' v node p c)
    then have "p = parent (the (m v))"
      by force
    with in_component_suc in_component.in_component_suc[of m v _ p] show ?case
      by fastforce
  qed
qed

lemma preserve_parents_valid:
  assumes "valid_union_find m"
  assumes "dom m = dom m'"
  assumes "\<forall>v' \<in> dom m. parent (the (m v')) = parent (the (m' v'))"
  shows "valid_union_find m'"
  using assms preserve_parents_in_component[OF assms(2,3)]
  unfolding valid_union_find_def
  by blast

lemma preserve_parents_preserve_component:
  assumes "valid_union_find m"
  assumes "dom m = dom m'"
  assumes "\<forall>v' \<in> dom m. parent (the (m v')) = parent (the (m' v'))"
  shows "preserve_component m m'"
  using preserve_parents_in_component[OF assms(2,3)]
  unfolding valid_union_find_def preserve_component_def
  by blast

lemma update_rank_preserve_parents:
  assumes "valid_union_find m"
  assumes "m v' = Some node"
  assumes "(m(v \<mapsto> \<lparr>parent = parent (the (m v)), rank = r\<rparr>)) v' = Some node'"
  shows "parent node = parent node'"
  using assms by (cases "v = v'") auto

lemma update_rank_valid:
  assumes "valid_union_find m"
  assumes "v \<in> dom m"
  shows "valid_union_find (m(v \<mapsto> \<lparr>parent = parent (the (m v)), rank = r\<rparr>))"
proof -
  from assms(2) have "dom m = dom (m(v \<mapsto> \<lparr>parent = parent (the (m v)), rank = r\<rparr>))"
    by auto
  also from this update_rank_preserve_parents[OF assms(1), of _ "the (m v)" v r]
  have "\<forall>v'\<in>dom m. parent (the (m v')) =
       parent (the ((m(v \<mapsto> \<lparr>parent = parent (the (m v)), rank = r\<rparr>)) v'))"
    by simp
  ultimately show ?thesis using preserve_parents_valid[OF assms(1)]
    by simp
qed

lemma update_rank_preserve_component:
  assumes "valid_union_find m"
  assumes "v \<in> dom m"
  shows "preserve_component m (m(v \<mapsto> \<lparr>parent = parent (the (m v)), rank = r\<rparr>))"
proof -
  from assms(2) have "dom m = dom (m(v \<mapsto> \<lparr>parent = parent (the (m v)), rank = r\<rparr>))"
    by auto
  also from this update_rank_preserve_parents[OF assms(1), of _ "the (m v)" v r]
  have "\<forall>v'\<in>dom m. parent (the (m v')) =
       parent (the ((m(v \<mapsto> \<lparr>parent = parent (the (m v)), rank = r\<rparr>)) v'))"
    by simp
  ultimately show ?thesis using preserve_parents_preserve_component[OF assms(1)]
    by simp
qed

theorem update_rank_correct: "(update_rank, update_rank_spec)\<in>Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding update_rank_spec_def update_rank_def
  by refine_vcg (auto simp: update_rank_valid update_rank_preserve_component)

section \<open>Creating empty data structure\<close>
definition empty_union_find :: "'v union_find"
  where "empty_union_find \<equiv> Map.empty"

lemma empty_union_find_valid[simp]: "valid_union_find empty_union_find"
  unfolding empty_union_find_def valid_union_find_def by simp

lemma empty_union_find_empty[simp]: "dom empty_union_find = {}"
  unfolding empty_union_find_def by simp

section \<open>Add element to data structure\<close>
subsection \<open>Definition\<close>
definition add_node_spec :: "'v union_find \<Rightarrow> 'v \<Rightarrow> ('v union_find) nres"
  where "add_node_spec m v \<equiv> do {
    ASSERT (valid_union_find m \<and> v \<notin> dom m);
    SPEC (\<lambda>m'. valid_union_find m' \<and> preserve_component m m' \<and> dom m' = dom m \<union> {v} \<and> in_component m' v v)
  }"

definition add_node :: "'v union_find \<Rightarrow> 'v \<Rightarrow> ('v union_find) nres"
  where "add_node m v \<equiv> do {
    ASSERT (v \<notin> dom m);
    mop_map_update v \<lparr>parent = v, rank = 0\<rparr> m
  }"

subsection \<open>Helping lemmas\<close>
lemma preserve_add_node:
  assumes "valid_union_find m"
  assumes "v \<notin> dom m"
  shows "preserve_component m (m(v \<mapsto> \<lparr>parent = v, rank = 0\<rparr>))"
proof -
  let ?m' = "m(v \<mapsto> \<lparr>parent = v, rank = 0\<rparr>)"
  have other_dir: "in_component m v' c \<Longrightarrow> in_component ?m' v' c" if v': "v'\<in>dom m" for v' c
  proof -
    assume asm: "in_component m v' c"
    from asm assms(2) show "in_component ?m' v' c"
    proof (induction m v' c rule: in_component.induct)
      case (in_component_root m v' node)
      with in_component.in_component_root[of _ v']
      show ?case by (cases "v' = v") auto
    next
      case (in_component_suc m v' node p c)
      with in_component.in_component_suc[of _ v']
      show ?case by (cases "v' = v") auto
    qed
  qed
  also have "in_component ?m' v' c \<Longrightarrow> in_component m v' c" if v': "v'\<in>dom m" for v' c
  proof -
    assume asm: "in_component ?m' v' c"
    from assms(1) v' obtain c' where c': "in_component m v' c'"
      unfolding valid_union_find_def by auto
    with other_dir v' have "in_component ?m' v' c'"
      by auto
    with asm in_component_unique have "c = c'"
      by force
    with c' show "in_component m v' c"
      by auto
  qed
  ultimately show ?thesis
    unfolding preserve_component_def by blast
qed

lemma add_node_valid:
  assumes "valid_union_find m"
  assumes "v \<notin> dom m"
  shows "valid_union_find (m(v \<mapsto> \<lparr>parent = v, rank = 0\<rparr>))"
proof -
  let ?m' = "m(v \<mapsto> \<lparr>parent = v, rank = 0\<rparr>)"
  have "\<exists>c. in_component ?m' v' c"
    if v': "v'\<in>dom ?m'" for v'
  proof  (cases "v = v'")
    case False
    with assms v' have "v'\<in>dom m"
      by auto
    with assms preserve_add_node[of m] show ?thesis
      unfolding valid_union_find_def preserve_component_def
      by blast
  next
    case True
    with v' in_component_root[of ?m' v "\<lparr>parent = v, rank = 0\<rparr>"]
    show ?thesis by fastforce
  qed
  then show ?thesis
    unfolding valid_union_find_def ..
qed

subsection \<open>Correctness theorem\<close>
theorem add_node_correct: "(add_node, add_node_spec)\<in>Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding add_node_spec_def add_node_def
  apply refine_vcg
  by (auto simp: preserve_add_node add_node_valid)

section \<open>Find element in the data structure\<close>
subsection \<open>Definitions\<close>
definition find_spec :: "'v union_find \<Rightarrow> 'v \<Rightarrow> ('v union_find \<times> 'v) nres"
  where "find_spec m v \<equiv> do {
    ASSERT (v \<in> dom m \<and> valid_union_find m);
    SPEC (\<lambda>(m', p). valid_union_find m' \<and> preserve_component m m' \<and> dom m = dom m' \<and> in_component m v p)
  }"

definition loop_invariant :: "'v union_find \<Rightarrow> 'v \<Rightarrow> 'v union_find \<Rightarrow> 'v \<Rightarrow> bool"
  where "loop_invariant m v m' p \<equiv> preserve_component m m' \<and>
    valid_union_find m' \<and> p \<in> dom m' \<and> dom m = dom m' \<and> same_component m' v p"

function find_set :: "'v union_find \<Rightarrow> 'v \<Rightarrow> ('v union_find \<times> 'v) nres"
  where "find_set m v = do {
    ASSERT (v \<in> dom m \<and> valid_union_find m);
    let node = the (m v);
    let p = parent node;
    if p \<noteq> v then do {
        (m, p) \<leftarrow> find_set m p;
        m \<leftarrow> update_parent m v p;
        RETURN (m, p)
    } else
        RETURN (m, p)
  }"
  by auto
  termination sorry (* TODO prove termination *)

definition find_set_while :: "'v union_find \<Rightarrow> 'v \<Rightarrow> ('v union_find \<times> 'v) nres"
  where "find_set_while m v \<equiv> do {
    ASSERT (v \<in> dom m \<and> valid_union_find m);
    (m, p) \<leftarrow> WHILEI
      (\<lambda>(m', p). loop_invariant m v m' p)
      (\<lambda>(m', p). parent (the (m' p)) \<noteq> p) (\<lambda>(m', p). RETURN (m', parent (the (m' p)))) (m, v);
    RETURN (m, p)
  }"

subsection \<open>Helping lemmas\<close>
lemma in_component_parent[simp]:
  assumes "in_component m v c"
  shows "in_component m (parent (the (m v))) c"
  using assms by (auto intro:in_component.cases[OF assms])

lemma parent_valid:
  assumes "valid_union_find m"
  assumes "m v = Some node"
  shows "m (parent node) \<noteq> None"
proof -
  from assms obtain c where c: "in_component m v c"
    unfolding valid_union_find_def by auto
  with assms in_component_parent[OF this] have "in_component m (parent node) c"
    by auto
  from in_component_dom(1)[OF this] show ?thesis
    by blast
qed

lemma same_component_root:
  assumes "same_component m v p"
  assumes "parent (the (m p)) = p"
  shows "in_component m v p"
proof -
  from assms(1) obtain c where vc: "in_component m v c" and pc: "in_component m p c"
    unfolding same_component_def by blast
  then have "p \<in> dom m"
    by (auto simp:in_component.cases[OF pc])
  with assms(2) have "in_component m p p"
    by auto
  with vc in_component_unique[OF pc] show ?thesis
    by auto
qed

subsection \<open>Correctness theorem\<close>
theorem find_correct: "(find_set_while, find_spec)\<in>Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding find_spec_def find_set_while_def loop_invariant_def preserve_component_def
  apply refine_vcg
  apply (auto simp: parent_valid)
  apply (simp add: same_component_trans[OF _ same_component_parent])
  apply (simp add: same_component_root)
  done

corollary find_correct': "find_set_while m v \<le> (find_spec m v)"
  using nres_relD[OF fun_relE1[OF fun_relE1[OF find_correct, of _ m]]]
  by auto

section \<open>Union two elements\<close>
subsection \<open>Definitions\<close>
definition union_spec :: "'v union_find \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> ('v union_find) nres"
  where "union_spec m a b \<equiv> do {
    ASSERT (a \<in> dom m \<and> b \<in> dom m \<and> valid_union_find m);
    SPEC (\<lambda>m'. valid_union_find m' \<and> preserve_component_union m m' a b \<and>  dom m = dom m' \<and> same_component m' a b)
  }"

definition union_sets :: "'v union_find \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> ('v union_find) nres"
  where "union_sets m a b \<equiv> do {
    ASSERT (a \<in> dom m \<and> b \<in> dom m \<and> valid_union_find m);
    (m', root_a) \<leftarrow> find_set_while m a;
    ASSERT (in_component m' a root_a \<and> valid_union_find m);
    (m'', root_b) \<leftarrow> find_set_while m' b;
    ASSERT (in_component m'' a root_a \<and> in_component m'' b root_b \<and>
            preserve_component m m'' \<and> valid_union_find m'');
    let rank_a = rank (the (m'' root_a));
    let rank_b = rank (the (m'' root_b));
    if root_b = root_a then do {
      RETURN m''
    } else if rank_a < rank_b then
      update_parent m'' root_a root_b
    else if rank_a > rank_b then
      update_parent m'' root_b root_a
    else do {
      m''' \<leftarrow> update_parent m'' root_a root_b;
      ASSERT(valid_union_find m''' \<and> same_component m''' a b \<and>
        preserve_component_union m m''' a b);
      m'''' \<leftarrow> update_rank m''' root_b (rank_b + 1);
      ASSERT(same_component m''' a b);
      RETURN m''''
    }
  }"

definition union_sets' :: "'v union_find \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> ('v union_find) nres"
  where "union_sets' m a b \<equiv> do {
    ASSERT (a \<in> dom m \<and> b \<in> dom m \<and> valid_union_find m);
    (m', root_a) \<leftarrow> find_spec m a;
    (m'', root_b) \<leftarrow> find_spec m' b;
    ASSERT (in_component m'' a root_a \<and> in_component m'' b root_b \<and>
            preserve_component m m'');
    let rank_a = rank (the (m'' root_a));
    let rank_b = rank (the (m'' root_b));
    if root_b = root_a then do {
      RETURN m''
    } else if rank_a < rank_b then
      update_parent_spec m'' root_a root_b
    else if rank_a > rank_b then
      update_parent_spec m'' root_b root_a
    else do {
      m''' \<leftarrow> update_parent_spec m'' root_a root_b;
      ASSERT(same_component m''' a b);
      m'''' \<leftarrow> update_rank_spec m''' root_b (rank_b + 1);
      RETURN m''''
    }
  }"

subsection \<open>Correctness theorem\<close>
theorem union_refine1: "(union_sets', union_spec)\<in>Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding union_sets'_def union_spec_def find_spec_def update_parent_spec_def update_rank_spec_def
  apply (refine_vcg)
  apply clarsimp_all
  apply (simp add: preserve_component_impl)+
  apply (fast elim: preserve_component_trans)
  apply (simp add: weaker_preserve_component)
  apply (simp add: domD[OF in_component_dom(2)])+
  apply (simp add: in_component_parent_root)+
  apply (simp add: preserve_component_union_trans_roots)
  apply (simp add: preserve_component_union_same)
  apply (simp add: domD[OF in_component_dom(2)])+
  apply (simp add: in_component_parent_root)+
  apply (simp add: preserve_component_union_sym[OF preserve_component_union_trans_roots])
  apply (simp add: same_component_sym[OF preserve_component_union_same])
  apply (simp add: domD[OF in_component_dom(2)])+
  apply (simp add: in_component_parent_root)+
  apply (simp add: preserve_component_union_same)
  apply (simp add: preserve_component_union_trans'[OF preserve_component_union_trans_roots])
  using preserve_component_impl_same
  apply blast
  done

lemma union_refine2: "(union_sets, union_sets')\<in>Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding union_sets_def union_sets'_def
  apply (refine_vcg)
  using find_correct update_parent_correct update_rank_correct
  apply auto
  sorry (* TODO refinement with actual functions *)

theorem union_correct: "(union_sets, union_spec)\<in>Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  using union_refine1 union_refine2
  sorry (* TODO overall correctness  *)

end


(* Author: Xingyuan Zhang, Chunhan Wu, Christian Urban *)
theory Myhill_1
imports Folds
        "HOL-Library.While_Combinator"
begin

section \<open>First direction of MN: \<open>finite partition \<Rightarrow> regular language\<close>\<close>

notation
  conc (infixr "\<cdot>" 100) and
  star ("_\<star>" [101] 102)

lemma Pair_Collect [simp]:
  shows "(x, y) \<in> {(x, y). P x y} \<longleftrightarrow> P x y"
by simp

text \<open>Myhill-Nerode relation\<close>

definition
  str_eq :: "'a lang \<Rightarrow> ('a list \<times> 'a list) set" ("\<approx>_" [100] 100)
where
  "\<approx>A \<equiv> {(x, y).  (\<forall>z. x @ z \<in> A \<longleftrightarrow> y @ z \<in> A)}"

abbreviation
  str_eq_applied :: "'a list \<Rightarrow> 'a lang \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<approx>_ _")
where
  "x \<approx>A y \<equiv> (x, y) \<in> \<approx>A"

lemma str_eq_conv_Derivs:
  "str_eq A = {(u,v). Derivs u A = Derivs v A}"
  by (auto simp: str_eq_def Derivs_def)

definition
  finals :: "'a lang \<Rightarrow> 'a lang set"
where
  "finals A \<equiv> {\<approx>A `` {s} | s . s \<in> A}"

lemma lang_is_union_of_finals:
  shows "A = \<Union>(finals A)"
unfolding finals_def
unfolding Image_def
unfolding str_eq_def
by (auto) (metis append_Nil2)

lemma finals_in_partitions:
  shows "finals A \<subseteq> (UNIV // \<approx>A)"
unfolding finals_def quotient_def
by auto

subsection \<open>Equational systems\<close>

text \<open>The two kinds of terms in the rhs of equations.\<close>

datatype 'a trm =
   Lam "'a rexp"            (* Lambda-marker *)
 | Trn "'a lang" "'a rexp"     (* Transition *)

fun
  lang_trm::"'a trm \<Rightarrow> 'a lang"
where
  "lang_trm (Lam r) = lang r"
| "lang_trm (Trn X r) = X \<cdot> lang r"

fun
  lang_rhs::"('a trm) set \<Rightarrow> 'a lang"
where
  "lang_rhs rhs = \<Union> (lang_trm ` rhs)"

lemma lang_rhs_set:
  shows "lang_rhs {Trn X r | r. P r} = \<Union>{lang_trm (Trn X r) | r. P r}"
by (auto)

lemma lang_rhs_union_distrib:
  shows "lang_rhs A \<union> lang_rhs B = lang_rhs (A \<union> B)"
by simp

text \<open>Transitions between equivalence classes\<close>

definition
  transition :: "'a lang \<Rightarrow> 'a \<Rightarrow> 'a lang \<Rightarrow> bool" ("_ \<Turnstile>_\<Rightarrow>_" [100,100,100] 100)
where
  "Y \<Turnstile>c\<Rightarrow> X \<equiv> Y \<cdot> {[c]} \<subseteq> X"

text \<open>Initial equational system\<close>

definition
  "Init_rhs CS X \<equiv>
      if ([] \<in> X) then
          {Lam One} \<union> {Trn Y (Atom c) | Y c. Y \<in> CS \<and> Y \<Turnstile>c\<Rightarrow> X}
      else
          {Trn Y (Atom c)| Y c. Y \<in> CS \<and> Y \<Turnstile>c\<Rightarrow> X}"

definition
  "Init CS \<equiv> {(X, Init_rhs CS X) | X.  X \<in> CS}"

subsection \<open>Arden Operation on equations\<close>

fun
  Append_rexp :: "'a rexp \<Rightarrow> 'a trm \<Rightarrow> 'a trm"
where
  "Append_rexp r (Lam rexp)   = Lam (Times rexp r)"
| "Append_rexp r (Trn X rexp) = Trn X (Times rexp r)"

definition
  "Append_rexp_rhs rhs rexp \<equiv> (Append_rexp rexp) ` rhs"

definition
  "Arden X rhs \<equiv>
     Append_rexp_rhs (rhs - {Trn X r | r. Trn X r \<in> rhs}) (Star (\<Uplus> {r. Trn X r \<in> rhs}))"

subsection \<open>Substitution Operation on equations\<close>

definition
  "Subst rhs X xrhs \<equiv>
        (rhs - {Trn X r | r. Trn X r \<in> rhs}) \<union> (Append_rexp_rhs xrhs (\<Uplus> {r. Trn X r \<in> rhs}))"

definition
  Subst_all :: "('a lang \<times> ('a trm) set) set \<Rightarrow> 'a lang \<Rightarrow> ('a trm) set \<Rightarrow> ('a lang \<times> ('a trm) set) set"
where
  "Subst_all ES X xrhs \<equiv> {(Y, Subst yrhs X xrhs) | Y yrhs. (Y, yrhs) \<in> ES}"

definition
  "Remove ES X xrhs \<equiv>
      Subst_all  (ES - {(X, xrhs)}) X (Arden X xrhs)"

subsection \<open>While-combinator and invariants\<close>

definition
  "Iter X ES \<equiv> (let (Y, yrhs) = SOME (Y, yrhs). (Y, yrhs) \<in> ES \<and> X \<noteq> Y
                in Remove ES Y yrhs)"

lemma IterI2:
  assumes "(Y, yrhs) \<in> ES"
  and     "X \<noteq> Y"
  and     "\<And>Y yrhs. \<lbrakk>(Y, yrhs) \<in> ES; X \<noteq> Y\<rbrakk> \<Longrightarrow> Q (Remove ES Y yrhs)"
  shows "Q (Iter X ES)"
unfolding Iter_def using assms
by (rule_tac a="(Y, yrhs)" in someI2) (auto)

abbreviation
  "Cond ES \<equiv> card ES \<noteq> 1"

definition
  "Solve X ES \<equiv> while Cond (Iter X) ES"

definition
  "distinctness ES \<equiv>
     \<forall> X rhs rhs'. (X, rhs) \<in> ES \<and> (X, rhs') \<in> ES \<longrightarrow> rhs = rhs'"

definition
  "soundness ES \<equiv> \<forall>(X, rhs) \<in> ES. X = lang_rhs rhs"

definition
  "ardenable rhs \<equiv> (\<forall> Y r. Trn Y r \<in> rhs \<longrightarrow> [] \<notin> lang r)"

definition
  "ardenable_all ES \<equiv> \<forall>(X, rhs) \<in> ES. ardenable rhs"

definition
  "finite_rhs ES \<equiv> \<forall>(X, rhs) \<in> ES. finite rhs"

lemma finite_rhs_def2:
  "finite_rhs ES = (\<forall> X rhs. (X, rhs) \<in> ES \<longrightarrow> finite rhs)"
unfolding finite_rhs_def by auto

definition
  "rhss rhs \<equiv> {X | X r. Trn X r \<in> rhs}"

definition
  "lhss ES \<equiv> {Y | Y yrhs. (Y, yrhs) \<in> ES}"

definition
  "validity ES \<equiv> \<forall>(X, rhs) \<in> ES. rhss rhs \<subseteq> lhss ES"

lemma rhss_union_distrib:
  shows "rhss (A \<union> B) = rhss A \<union> rhss B"
by (auto simp add: rhss_def)

lemma lhss_union_distrib:
  shows "lhss (A \<union> B) = lhss A \<union> lhss B"
by (auto simp add: lhss_def)

definition
  "invariant ES \<equiv> finite ES
                \<and> finite_rhs ES
                \<and> soundness ES
                \<and> distinctness ES
                \<and> ardenable_all ES
                \<and> validity ES"

lemma invariantI:
  assumes "soundness ES" "finite ES" "distinctness ES" "ardenable_all ES"
          "finite_rhs ES" "validity ES"
  shows "invariant ES"
using assms by (simp add: invariant_def)

declare [[simproc add: finite_Collect]]

lemma finite_Trn:
  assumes fin: "finite rhs"
  shows "finite {r. Trn Y r \<in> rhs}"
using assms by (auto intro!: finite_vimageI simp add: inj_on_def)

lemma finite_Lam:
  assumes fin: "finite rhs"
  shows "finite {r. Lam r \<in> rhs}"
using assms by (auto intro!: finite_vimageI simp add: inj_on_def)

lemma trm_soundness:
  assumes finite:"finite rhs"
  shows "lang_rhs ({Trn X r| r. Trn X r \<in> rhs}) = X \<cdot> (lang (\<Uplus>{r. Trn X r \<in> rhs}))"
proof -
  have "finite {r. Trn X r \<in> rhs}"
    by (rule finite_Trn[OF finite])
  then show "lang_rhs ({Trn X r| r. Trn X r \<in> rhs}) = X \<cdot> (lang (\<Uplus>{r. Trn X r \<in> rhs}))"
    by (simp only: lang_rhs_set lang_trm.simps) (auto simp add: conc_def)
qed

lemma lang_of_append_rexp:
  "lang_trm (Append_rexp r trm) = lang_trm trm \<cdot> lang r"
by (induct rule: Append_rexp.induct)
   (auto simp add: conc_assoc)

lemma lang_of_append_rexp_rhs:
  "lang_rhs (Append_rexp_rhs rhs r) = lang_rhs rhs \<cdot> lang r"
unfolding Append_rexp_rhs_def
by (auto simp add: conc_def lang_of_append_rexp)

subsection \<open>Intial Equational Systems\<close>

lemma defined_by_str:
  assumes "s \<in> X" "X \<in> UNIV // \<approx>A"
  shows "X = \<approx>A `` {s}"
using assms
unfolding quotient_def Image_def str_eq_def
by auto

lemma every_eqclass_has_transition:
  assumes has_str: "s @ [c] \<in> X"
  and     in_CS:   "X \<in> UNIV // \<approx>A"
  obtains Y where "Y \<in> UNIV // \<approx>A" and "Y \<cdot> {[c]} \<subseteq> X" and "s \<in> Y"
proof -
  define Y where "Y = \<approx>A `` {s}"
  have "Y \<in> UNIV // \<approx>A"
    unfolding Y_def quotient_def by auto
  moreover
  have "X = \<approx>A `` {s @ [c]}"
    using has_str in_CS defined_by_str by blast
  then have "Y \<cdot> {[c]} \<subseteq> X"
    unfolding Y_def Image_def conc_def
    unfolding str_eq_def
    by clarsimp
  moreover
  have "s \<in> Y" unfolding Y_def
    unfolding Image_def str_eq_def by simp
  ultimately show thesis using that by blast
qed

lemma l_eq_r_in_eqs:
  assumes X_in_eqs: "(X, rhs) \<in> Init (UNIV // \<approx>A)"
  shows "X = lang_rhs rhs"
proof
  show "X \<subseteq> lang_rhs rhs"
  proof
    fix x
    assume in_X: "x \<in> X"
    { assume empty: "x = []"
      then have "x \<in> lang_rhs rhs" using X_in_eqs in_X
        unfolding Init_def Init_rhs_def
        by auto
    }
    moreover
    { assume not_empty: "x \<noteq> []"
      then obtain s c where decom: "x = s @ [c]"
        using rev_cases by blast
      have "X \<in> UNIV // \<approx>A" using X_in_eqs unfolding Init_def by auto
      then obtain Y where "Y \<in> UNIV // \<approx>A" "Y \<cdot> {[c]} \<subseteq> X" "s \<in> Y"
        using decom in_X every_eqclass_has_transition by metis
      then have "x \<in> lang_rhs {Trn Y (Atom c)| Y c. Y \<in> UNIV // \<approx>A \<and> Y \<Turnstile>c\<Rightarrow> X}"
        unfolding transition_def
        using decom by (force simp add: conc_def)
      then have "x \<in> lang_rhs rhs" using X_in_eqs in_X
        unfolding Init_def Init_rhs_def by simp
    }
    ultimately show "x \<in> lang_rhs rhs" by blast
  qed
next
  show "lang_rhs rhs \<subseteq> X" using X_in_eqs
    unfolding Init_def Init_rhs_def transition_def
    by auto
qed

lemma finite_Init_rhs:
  fixes CS::"(('a::finite) lang) set"
  assumes finite: "finite CS"
  shows "finite (Init_rhs CS X)"
using assms unfolding Init_rhs_def transition_def by simp

lemma Init_ES_satisfies_invariant:
  fixes A::"(('a::finite) lang)"
  assumes finite_CS: "finite (UNIV // \<approx>A)"
  shows "invariant (Init (UNIV // \<approx>A))"
proof (rule invariantI)
  show "soundness (Init (UNIV // \<approx>A))"
    unfolding soundness_def
    using l_eq_r_in_eqs by auto
  show "finite (Init (UNIV // \<approx>A))" using finite_CS
    unfolding Init_def by simp
  show "distinctness (Init (UNIV // \<approx>A))"
    unfolding distinctness_def Init_def by simp
  show "ardenable_all (Init (UNIV // \<approx>A))"
    unfolding ardenable_all_def Init_def Init_rhs_def ardenable_def
   by auto
  show "finite_rhs (Init (UNIV // \<approx>A))"
    using finite_Init_rhs[OF finite_CS]
    unfolding finite_rhs_def Init_def by auto
  show "validity (Init (UNIV // \<approx>A))"
    unfolding validity_def Init_def Init_rhs_def rhss_def lhss_def
    by auto
qed

subsection \<open>Interations\<close>

lemma Arden_preserves_soundness:
  assumes l_eq_r: "X = lang_rhs rhs"
  and not_empty: "ardenable rhs"
  and finite: "finite rhs"
  shows "X = lang_rhs (Arden X rhs)"
proof -
  define A where "A = lang (\<Uplus>{r. Trn X r \<in> rhs})"
  define b where "b = {Trn X r | r. Trn X r \<in> rhs}"
  define B where "B = lang_rhs (rhs - b)"
  have not_empty2: "[] \<notin> A"
    using finite_Trn[OF finite] not_empty
    unfolding A_def ardenable_def by simp
  have "X = lang_rhs rhs" using l_eq_r by simp
  also have "\<dots> = lang_rhs (b \<union> (rhs - b))" unfolding b_def by auto
  also have "\<dots> = lang_rhs b \<union> B" unfolding B_def by (simp only: lang_rhs_union_distrib)
  also have "\<dots> = X \<cdot> A \<union> B"
    unfolding b_def
    unfolding trm_soundness[OF finite]
    unfolding A_def
    by blast
  finally have "X = X \<cdot> A \<union> B" .
  then have "X = B \<cdot> A\<star>"
    by (simp add: reversed_Arden[OF not_empty2])
  also have "\<dots> = lang_rhs (Arden X rhs)"
    unfolding Arden_def A_def B_def b_def
    by (simp only: lang_of_append_rexp_rhs lang.simps)
  finally show "X = lang_rhs (Arden X rhs)" by simp
qed

lemma Append_preserves_finite:
  "finite rhs \<Longrightarrow> finite (Append_rexp_rhs rhs r)"
by (auto simp: Append_rexp_rhs_def)

lemma Arden_preserves_finite:
  "finite rhs \<Longrightarrow> finite (Arden X rhs)"
by (auto simp: Arden_def Append_preserves_finite)

lemma Append_preserves_ardenable:
  "ardenable rhs \<Longrightarrow> ardenable (Append_rexp_rhs rhs r)"
apply (auto simp: ardenable_def Append_rexp_rhs_def)
by (case_tac x, auto simp: conc_def)

lemma ardenable_set_sub:
  "ardenable rhs \<Longrightarrow> ardenable (rhs - A)"
by (auto simp:ardenable_def)

lemma ardenable_set_union:
  "\<lbrakk>ardenable rhs; ardenable rhs'\<rbrakk> \<Longrightarrow> ardenable (rhs \<union> rhs')"
by (auto simp:ardenable_def)

lemma Arden_preserves_ardenable:
  "ardenable rhs \<Longrightarrow> ardenable (Arden X rhs)"
by (simp only:Arden_def Append_preserves_ardenable ardenable_set_sub)

lemma Subst_preserves_ardenable:
  "\<lbrakk>ardenable rhs; ardenable xrhs\<rbrakk> \<Longrightarrow> ardenable (Subst rhs X xrhs)"
by (simp only: Subst_def Append_preserves_ardenable ardenable_set_union ardenable_set_sub)

lemma Subst_preserves_soundness:
  assumes substor: "X = lang_rhs xrhs"
  and finite: "finite rhs"
  shows "lang_rhs (Subst rhs X xrhs) = lang_rhs rhs" (is "?Left = ?Right")
proof-
  define A where "A = lang_rhs (rhs - {Trn X r | r. Trn X r \<in> rhs})"
  have "?Left = A \<union> lang_rhs (Append_rexp_rhs xrhs (\<Uplus>{r. Trn X r \<in> rhs}))"
    unfolding Subst_def
    unfolding lang_rhs_union_distrib[symmetric]
    by (simp add: A_def)
  moreover have "?Right = A \<union> lang_rhs {Trn X r | r. Trn X r \<in> rhs}"
  proof-
    have "rhs = (rhs - {Trn X r | r. Trn X r \<in> rhs}) \<union> ({Trn X r | r. Trn X r \<in> rhs})" by auto
    thus ?thesis
      unfolding A_def
      unfolding lang_rhs_union_distrib
      by simp
  qed
  moreover
  have "lang_rhs (Append_rexp_rhs xrhs (\<Uplus>{r. Trn X r \<in> rhs})) = lang_rhs {Trn X r | r. Trn X r \<in> rhs}"
    using finite substor by (simp only: lang_of_append_rexp_rhs trm_soundness)
  ultimately show ?thesis by simp
qed

lemma Subst_preserves_finite_rhs:
  "\<lbrakk>finite rhs; finite yrhs\<rbrakk> \<Longrightarrow> finite (Subst rhs Y yrhs)"
by (auto simp: Subst_def Append_preserves_finite)

lemma Subst_all_preserves_finite:
  assumes finite: "finite ES"
  shows "finite (Subst_all ES Y yrhs)"
using assms unfolding Subst_all_def by simp

declare [[simproc del: finite_Collect]]

lemma Subst_all_preserves_finite_rhs:
  "\<lbrakk>finite_rhs ES; finite yrhs\<rbrakk> \<Longrightarrow> finite_rhs (Subst_all ES Y yrhs)"
by (auto intro:Subst_preserves_finite_rhs simp add:Subst_all_def finite_rhs_def)

lemma append_rhs_preserves_cls:
  "rhss (Append_rexp_rhs rhs r) = rhss rhs"
apply (auto simp: rhss_def Append_rexp_rhs_def)
apply (case_tac xa, auto simp: image_def)
by (rule_tac x = "Times ra r" in exI, rule_tac x = "Trn x ra" in bexI, simp+)

lemma Arden_removes_cl:
  "rhss (Arden Y yrhs) = rhss yrhs - {Y}"
apply (simp add:Arden_def append_rhs_preserves_cls)
by (auto simp: rhss_def)

lemma lhss_preserves_cls:
  "lhss (Subst_all ES Y yrhs) = lhss ES"
by (auto simp: lhss_def Subst_all_def)

lemma Subst_updates_cls:
  "X \<notin> rhss xrhs \<Longrightarrow>
      rhss (Subst rhs X xrhs) = rhss rhs \<union> rhss xrhs - {X}"
apply (simp only:Subst_def append_rhs_preserves_cls rhss_union_distrib)
by (auto simp: rhss_def)

lemma Subst_all_preserves_validity:
  assumes sc: "validity (ES \<union> {(Y, yrhs)})"        (is "validity ?A")
  shows "validity (Subst_all ES Y (Arden Y yrhs))"  (is "validity ?B")
proof -
  { fix X xrhs'
    assume "(X, xrhs') \<in> ?B"
    then obtain xrhs
      where xrhs_xrhs': "xrhs' = Subst xrhs Y (Arden Y yrhs)"
      and X_in: "(X, xrhs) \<in> ES" by (simp add:Subst_all_def, blast)
    have "rhss xrhs' \<subseteq> lhss ?B"
    proof-
      have "lhss ?B = lhss ES" by (auto simp add:lhss_def Subst_all_def)
      moreover have "rhss xrhs' \<subseteq> lhss ES"
      proof-
        have "rhss xrhs' \<subseteq>  rhss xrhs \<union> rhss (Arden Y yrhs) - {Y}"
        proof -
          have "Y \<notin> rhss (Arden Y yrhs)"
            using Arden_removes_cl by auto
          thus ?thesis using xrhs_xrhs' by (auto simp: Subst_updates_cls)
        qed
        moreover have "rhss xrhs \<subseteq> lhss ES \<union> {Y}" using X_in sc
          apply (simp only:validity_def lhss_union_distrib)
          by (drule_tac x = "(X, xrhs)" in bspec, auto simp:lhss_def)
        moreover have "rhss (Arden Y yrhs) \<subseteq> lhss ES \<union> {Y}"
          using sc
          by (auto simp add: Arden_removes_cl validity_def lhss_def)
        ultimately show ?thesis by auto
      qed
      ultimately show ?thesis by simp
    qed
  } thus ?thesis by (auto simp only:Subst_all_def validity_def)
qed

lemma Subst_all_satisfies_invariant:
  assumes invariant_ES: "invariant (ES \<union> {(Y, yrhs)})"
  shows "invariant (Subst_all ES Y (Arden Y yrhs))"
proof (rule invariantI)
  have Y_eq_yrhs: "Y = lang_rhs yrhs"
    using invariant_ES by (simp only:invariant_def soundness_def, blast)
   have finite_yrhs: "finite yrhs"
    using invariant_ES by (auto simp:invariant_def finite_rhs_def)
  have ardenable_yrhs: "ardenable yrhs"
    using invariant_ES by (auto simp:invariant_def ardenable_all_def)
  show "soundness (Subst_all ES Y (Arden Y yrhs))"
  proof -
    have "Y = lang_rhs (Arden Y yrhs)"
      using Y_eq_yrhs invariant_ES finite_yrhs
      using finite_Trn[OF finite_yrhs]
      apply(rule_tac Arden_preserves_soundness)
      apply(simp_all)
      unfolding invariant_def ardenable_all_def ardenable_def
      apply(auto)
      done
    thus ?thesis using invariant_ES
      unfolding invariant_def finite_rhs_def2 soundness_def Subst_all_def
      by (auto simp add: Subst_preserves_soundness simp del: lang_rhs.simps)
  qed
  show "finite (Subst_all ES Y (Arden Y yrhs))"
    using invariant_ES by (simp add:invariant_def Subst_all_preserves_finite)
  show "distinctness (Subst_all ES Y (Arden Y yrhs))"
    using invariant_ES
    unfolding distinctness_def Subst_all_def invariant_def by auto
  show "ardenable_all (Subst_all ES Y (Arden Y yrhs))"
  proof -
    { fix X rhs
      assume "(X, rhs) \<in> ES"
      hence "ardenable rhs"  using invariant_ES
        by (auto simp add:invariant_def ardenable_all_def)
      with ardenable_yrhs
      have "ardenable (Subst rhs Y (Arden Y yrhs))"
        by (simp add:ardenable_yrhs
               Subst_preserves_ardenable Arden_preserves_ardenable)
    } thus ?thesis by (auto simp add:ardenable_all_def Subst_all_def)
  qed
  show "finite_rhs (Subst_all ES Y (Arden Y yrhs))"
  proof-
    have "finite_rhs ES" using invariant_ES
      by (simp add:invariant_def finite_rhs_def)
    moreover have "finite (Arden Y yrhs)"
    proof -
      have "finite yrhs" using invariant_ES
        by (auto simp:invariant_def finite_rhs_def)
      thus ?thesis using Arden_preserves_finite by auto
    qed
    ultimately show ?thesis
      by (simp add:Subst_all_preserves_finite_rhs)
  qed
  show "validity (Subst_all ES Y (Arden Y yrhs))"
    using invariant_ES Subst_all_preserves_validity by (auto simp add: invariant_def)
qed

lemma Remove_in_card_measure:
  assumes finite: "finite ES"
  and     in_ES: "(X, rhs) \<in> ES"
  shows "(Remove ES X rhs, ES) \<in> measure card"
proof -
  define f where "f x = ((fst x)::'a lang, Subst (snd x) X (Arden X rhs))" for x
  define ES' where "ES' = ES - {(X, rhs)}"
  have "Subst_all ES' X (Arden X rhs) = f ` ES'"
    apply (auto simp: Subst_all_def f_def image_def)
    by (rule_tac x = "(Y, yrhs)" in bexI, simp+)
  then have "card (Subst_all ES' X (Arden X rhs)) \<le> card ES'"
    unfolding ES'_def using finite by (auto intro: card_image_le)
  also have "\<dots> < card ES" unfolding ES'_def
    using in_ES finite by (rule_tac card_Diff1_less)
  finally show "(Remove ES X rhs, ES) \<in> measure card"
    unfolding Remove_def ES'_def by simp
qed

lemma Subst_all_cls_remains:
  "(X, xrhs) \<in> ES \<Longrightarrow> \<exists> xrhs'. (X, xrhs') \<in> (Subst_all ES Y yrhs)"
by (auto simp: Subst_all_def)

lemma card_noteq_1_has_more:
  assumes card:"Cond ES"
  and e_in: "(X, xrhs) \<in> ES"
  and finite: "finite ES"
  shows "\<exists>(Y, yrhs) \<in> ES. (X, xrhs) \<noteq> (Y, yrhs)"
proof-
  have "card ES > 1" using card e_in finite
    by (cases "card ES") (auto)
  then have "card (ES - {(X, xrhs)}) > 0"
    using finite e_in by auto
  then have "(ES - {(X, xrhs)}) \<noteq> {}" using finite by (rule_tac notI, simp)
  then show "\<exists>(Y, yrhs) \<in> ES. (X, xrhs) \<noteq> (Y, yrhs)"
    by auto
qed

lemma iteration_step_measure:
  assumes Inv_ES: "invariant ES"
  and    X_in_ES: "(X, xrhs) \<in> ES"
  and    Cnd:     "Cond ES "
  shows "(Iter X ES, ES) \<in> measure card"
proof -
  have fin: "finite ES" using Inv_ES unfolding invariant_def by simp
  then obtain Y yrhs
    where Y_in_ES: "(Y, yrhs) \<in> ES" and not_eq: "(X, xrhs) \<noteq> (Y, yrhs)"
    using Cnd X_in_ES by (drule_tac card_noteq_1_has_more) (auto)
  then have "(Y, yrhs) \<in> ES " "X \<noteq> Y"
    using X_in_ES Inv_ES unfolding invariant_def distinctness_def
    by auto
  then show "(Iter X ES, ES) \<in> measure card"
  apply(rule IterI2)
  apply(rule Remove_in_card_measure)
  apply(simp_all add: fin)
  done
qed

lemma iteration_step_invariant:
  assumes Inv_ES: "invariant ES"
  and    X_in_ES: "(X, xrhs) \<in> ES"
  and    Cnd: "Cond ES"
  shows "invariant (Iter X ES)"
proof -
  have finite_ES: "finite ES" using Inv_ES by (simp add: invariant_def)
  then obtain Y yrhs
    where Y_in_ES: "(Y, yrhs) \<in> ES" and not_eq: "(X, xrhs) \<noteq> (Y, yrhs)"
    using Cnd X_in_ES by (drule_tac card_noteq_1_has_more) (auto)
  then have "(Y, yrhs) \<in> ES" "X \<noteq> Y"
    using X_in_ES Inv_ES unfolding invariant_def distinctness_def
    by auto
  then show "invariant (Iter X ES)"
  proof(rule IterI2)
    fix Y yrhs
    assume h: "(Y, yrhs) \<in> ES" "X \<noteq> Y"
    then have "ES - {(Y, yrhs)} \<union> {(Y, yrhs)} = ES" by auto
    then show "invariant (Remove ES Y yrhs)" unfolding Remove_def
      using Inv_ES
      by (rule_tac Subst_all_satisfies_invariant) (simp)
  qed
qed

lemma iteration_step_ex:
  assumes Inv_ES: "invariant ES"
  and    X_in_ES: "(X, xrhs) \<in> ES"
  and    Cnd: "Cond ES"
  shows "\<exists>xrhs'. (X, xrhs') \<in> (Iter X ES)"
proof -
  have finite_ES: "finite ES" using Inv_ES by (simp add: invariant_def)
  then obtain Y yrhs
    where "(Y, yrhs) \<in> ES" "(X, xrhs) \<noteq> (Y, yrhs)"
    using Cnd X_in_ES by (drule_tac card_noteq_1_has_more) (auto)
  then have "(Y, yrhs) \<in> ES " "X \<noteq> Y"
    using X_in_ES Inv_ES unfolding invariant_def distinctness_def
    by auto
  then show "\<exists>xrhs'. (X, xrhs') \<in> (Iter X ES)"
  apply(rule IterI2)
  unfolding Remove_def
  apply(rule Subst_all_cls_remains)
  using X_in_ES
  apply(auto)
  done
qed

subsection \<open>The conclusion of the first direction\<close>

lemma Solve:
  fixes A::"('a::finite) lang"
  assumes fin: "finite (UNIV // \<approx>A)"
  and     X_in: "X \<in> (UNIV // \<approx>A)"
  shows "\<exists>rhs. Solve X (Init (UNIV // \<approx>A)) = {(X, rhs)} \<and> invariant {(X, rhs)}"
proof -
  define Inv where "Inv ES \<longleftrightarrow> invariant ES \<and> (\<exists>rhs. (X, rhs) \<in> ES)" for ES
  have "Inv (Init (UNIV // \<approx>A))" unfolding Inv_def
      using fin X_in by (simp add: Init_ES_satisfies_invariant, simp add: Init_def)
  moreover
  { fix ES
    assume inv: "Inv ES" and crd: "Cond ES"
    then have "Inv (Iter X ES)"
      unfolding Inv_def
      by (auto simp add: iteration_step_invariant iteration_step_ex) }
  moreover
  { fix ES
    assume inv: "Inv ES" and not_crd: "\<not>Cond ES"
    from inv obtain rhs where "(X, rhs) \<in> ES" unfolding Inv_def by auto
    moreover
    from not_crd have "card ES = 1" by simp
    ultimately
    have "ES = {(X, rhs)}" by (auto simp add: card_Suc_eq)
    then have "\<exists>rhs'. ES = {(X, rhs')} \<and> invariant {(X, rhs')}" using inv
      unfolding Inv_def by auto }
  moreover
    have "wf (measure card)" by simp
  moreover
  { fix ES
    assume inv: "Inv ES" and crd: "Cond ES"
    then have "(Iter X ES, ES) \<in> measure card"
      unfolding Inv_def
      apply(clarify)
      apply(rule_tac iteration_step_measure)
      apply(auto)
      done }
  ultimately
  show "\<exists>rhs. Solve X (Init (UNIV // \<approx>A)) = {(X, rhs)} \<and> invariant {(X, rhs)}"
    unfolding Solve_def by (rule while_rule)
qed

lemma every_eqcl_has_reg:
  fixes A::"('a::finite) lang"
  assumes finite_CS: "finite (UNIV // \<approx>A)"
  and X_in_CS: "X \<in> (UNIV // \<approx>A)"
  shows "\<exists>r. X = lang r"
proof -
  from finite_CS X_in_CS
  obtain xrhs where Inv_ES: "invariant {(X, xrhs)}"
    using Solve by metis

  define A where "A = Arden X xrhs"
  have "rhss xrhs \<subseteq> {X}" using Inv_ES
    unfolding validity_def invariant_def rhss_def lhss_def
    by auto
  then have "rhss A = {}" unfolding A_def
    by (simp add: Arden_removes_cl)
  then have eq: "{Lam r | r. Lam r \<in> A} = A" unfolding rhss_def
    by (auto, case_tac x, auto)

  have "finite A" using Inv_ES unfolding A_def invariant_def finite_rhs_def
    using Arden_preserves_finite by auto
  then have fin: "finite {r. Lam r \<in> A}" by (rule finite_Lam)

  have "X = lang_rhs xrhs" using Inv_ES unfolding invariant_def soundness_def
    by simp
  then have "X = lang_rhs A" using Inv_ES
    unfolding A_def invariant_def ardenable_all_def finite_rhs_def
    by (rule_tac Arden_preserves_soundness) (simp_all add: finite_Trn)
  then have "X = lang_rhs {Lam r | r. Lam r \<in> A}" using eq by simp
  then have "X = lang (\<Uplus>{r. Lam r \<in> A})" using fin by auto
  then show "\<exists>r. X = lang r" by blast
qed

lemma bchoice_finite_set:
  assumes a: "\<forall>x \<in> S. \<exists>y. x = f y"
  and     b: "finite S"
  shows "\<exists>ys. (\<Union> S) = \<Union>(f ` ys) \<and> finite ys"
using bchoice[OF a] b
apply(erule_tac exE)
apply(rule_tac x="fa ` S" in exI)
apply(auto)
done

theorem Myhill_Nerode1:
  fixes A::"('a::finite) lang"
  assumes finite_CS: "finite (UNIV // \<approx>A)"
  shows   "\<exists>r. A = lang r"
proof -
  have fin: "finite (finals A)"
    using finals_in_partitions finite_CS by (rule finite_subset)
  have "\<forall>X \<in> (UNIV // \<approx>A). \<exists>r. X = lang r"
    using finite_CS every_eqcl_has_reg by blast
  then have a: "\<forall>X \<in> finals A. \<exists>r. X = lang r"
    using finals_in_partitions by auto
  then obtain rs::"('a rexp) set" where "\<Union> (finals A) = \<Union>(lang ` rs)" "finite rs"
    using fin by (auto dest: bchoice_finite_set)
  then have "A = lang (\<Uplus>rs)"
    unfolding lang_is_union_of_finals[symmetric] by simp
  then show "\<exists>r. A = lang r" by blast
qed

end