(* Author: Tobias Nipkow *)

section "Widening and Narrowing"

theory Abs_Int3
imports Abs_Int2_ivl
begin

class WN = SL_top +
fixes widen :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<nabla>" 65)
assumes widen1: "x \<sqsubseteq> x \<nabla> y"
assumes widen2: "y \<sqsubseteq> x \<nabla> y"
fixes narrow :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<triangle>" 65)
assumes narrow1: "y \<sqsubseteq> x \<Longrightarrow> y \<sqsubseteq> x \<triangle> y"
assumes narrow2: "y \<sqsubseteq> x \<Longrightarrow> x \<triangle> y \<sqsubseteq> x"

subsection "Intervals"

instantiation ivl :: WN
begin

definition "widen_ivl ivl1 ivl2 =
  (\<^cancel>\<open>if is_empty ivl1 then ivl2 else
   if is_empty ivl2 then ivl1 else\<close>
     case (ivl1,ivl2) of (I l1 h1, I l2 h2) \<Rightarrow>
       I (if le_option False l2 l1 \<and> l2 \<noteq> l1 then None else l1)
         (if le_option True h1 h2 \<and> h1 \<noteq> h2 then None else h1))"

definition "narrow_ivl ivl1 ivl2 =
  (\<^cancel>\<open>if is_empty ivl1 \<or> is_empty ivl2 then empty else\<close>
     case (ivl1,ivl2) of (I l1 h1, I l2 h2) \<Rightarrow>
       I (if l1 = None then l2 else l1)
         (if h1 = None then h2 else h1))"

instance
proof qed
  (auto simp add: widen_ivl_def narrow_ivl_def le_option_def le_ivl_def empty_def split: ivl.split option.split if_splits)

end

subsection "Abstract State"

instantiation st :: (WN)WN
begin

definition "widen_st F1 F2 =
  FunDom (\<lambda>x. fun F1 x \<nabla> fun F2 x) (inter_list (dom F1) (dom F2))"

definition "narrow_st F1 F2 =
  FunDom (\<lambda>x. fun F1 x \<triangle> fun F2 x) (inter_list (dom F1) (dom F2))"

instance
proof (standard, goal_cases)
  case 1 thus ?case
    by(simp add: widen_st_def le_st_def lookup_def widen1)
next
  case 2 thus ?case
    by(simp add: widen_st_def le_st_def lookup_def widen2)
next
  case 3 thus ?case
    by(auto simp: narrow_st_def le_st_def lookup_def narrow1)
next
  case 4 thus ?case
    by(auto simp: narrow_st_def le_st_def lookup_def narrow2)
qed

end

subsection "Option"

instantiation option :: (WN)WN
begin

fun widen_option where
"None \<nabla> x = x" |
"x \<nabla> None = x" |
"(Some x) \<nabla> (Some y) = Some(x \<nabla> y)"

fun narrow_option where
"None \<triangle> x = None" |
"x \<triangle> None = None" |
"(Some x) \<triangle> (Some y) = Some(x \<triangle> y)"

instance
proof (standard, goal_cases)
  case (1 x y) show ?case
    by(induct x y rule: widen_option.induct) (simp_all add: widen1)
next
  case (2 x y) show ?case
    by(induct x y rule: widen_option.induct) (simp_all add: widen2)
next
  case (3 x y) thus ?case
    by(induct x y rule: narrow_option.induct) (simp_all add: narrow1)
next
  case (4 y x) thus ?case
    by(induct x y rule: narrow_option.induct) (simp_all add: narrow2)
qed

end

subsection "Annotated commands"

fun map2_acom :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a acom \<Rightarrow> 'a acom \<Rightarrow> 'a acom" where
"map2_acom f (SKIP {a1}) (SKIP {a2}) = (SKIP {f a1 a2})" |
"map2_acom f (x ::= e {a1}) (x' ::= e' {a2}) = (x ::= e {f a1 a2})" |
"map2_acom f (c1;;c2) (c1';;c2') = (map2_acom f c1 c1';; map2_acom f c2 c2')" |
"map2_acom f (IF b THEN c1 ELSE c2 {a1}) (IF b' THEN c1' ELSE c2' {a2}) =
  (IF b THEN map2_acom f c1 c1' ELSE map2_acom f c2 c2' {f a1 a2})" |
"map2_acom f ({a1} WHILE b DO c {a2}) ({a3} WHILE b' DO c' {a4}) =
  ({f a1 a3} WHILE b DO map2_acom f c c' {f a2 a4})"

abbreviation widen_acom :: "('a::WN)acom \<Rightarrow> 'a acom \<Rightarrow> 'a acom" (infix "\<nabla>\<^sub>c" 65)
where "widen_acom == map2_acom (\<nabla>)"

abbreviation narrow_acom :: "('a::WN)acom \<Rightarrow> 'a acom \<Rightarrow> 'a acom" (infix "\<triangle>\<^sub>c" 65)
where "narrow_acom == map2_acom (\<triangle>)"

lemma widen1_acom: "strip c = strip c' \<Longrightarrow> c \<sqsubseteq> c \<nabla>\<^sub>c c'"
by(induct c c' rule: le_acom.induct)(simp_all add: widen1)

lemma widen2_acom: "strip c = strip c' \<Longrightarrow> c' \<sqsubseteq> c \<nabla>\<^sub>c c'"
by(induct c c' rule: le_acom.induct)(simp_all add: widen2)

lemma narrow1_acom: "y \<sqsubseteq> x \<Longrightarrow> y \<sqsubseteq> x \<triangle>\<^sub>c y"
by(induct y x rule: le_acom.induct) (simp_all add: narrow1)

lemma narrow2_acom: "y \<sqsubseteq> x \<Longrightarrow> x \<triangle>\<^sub>c y \<sqsubseteq> x"
by(induct y x rule: le_acom.induct) (simp_all add: narrow2)

subsection "Post-fixed point computation"

definition iter_widen :: "('a acom \<Rightarrow> 'a acom) \<Rightarrow> 'a acom \<Rightarrow> ('a::WN)acom option"
where "iter_widen f = while_option (\<lambda>c. \<not> f c \<sqsubseteq> c) (\<lambda>c. c \<nabla>\<^sub>c f c)"

definition iter_narrow :: "('a acom \<Rightarrow> 'a acom) \<Rightarrow> 'a acom \<Rightarrow> 'a::WN acom option"
where "iter_narrow f = while_option (\<lambda>c. \<not> c \<sqsubseteq> c \<triangle>\<^sub>c f c) (\<lambda>c. c \<triangle>\<^sub>c f c)"

definition pfp_wn ::
  "(('a::WN)option acom \<Rightarrow> 'a option acom) \<Rightarrow> com \<Rightarrow> 'a option acom option"
where "pfp_wn f c = (case iter_widen f (\<bottom>\<^sub>c c) of None \<Rightarrow> None
                     | Some c' \<Rightarrow> iter_narrow f c')"

lemma strip_map2_acom:
 "strip c1 = strip c2 \<Longrightarrow> strip(map2_acom f c1 c2) = strip c1"
by(induct f c1 c2 rule: map2_acom.induct) simp_all

lemma iter_widen_pfp: "iter_widen f c = Some c' \<Longrightarrow> f c' \<sqsubseteq> c'"
by(auto simp add: iter_widen_def dest: while_option_stop)

lemma strip_while: fixes f :: "'a acom \<Rightarrow> 'a acom"
assumes "\<forall>c. strip (f c) = strip c" and "while_option P f c = Some c'"
shows "strip c' = strip c"
using while_option_rule[where P = "\<lambda>c'. strip c' = strip c", OF _ assms(2)]
by (metis assms(1))

lemma strip_iter_widen: fixes f :: "'a::WN acom \<Rightarrow> 'a acom"
assumes "\<forall>c. strip (f c) = strip c" and "iter_widen f c = Some c'"
shows "strip c' = strip c"
proof-
  have "\<forall>c. strip(c \<nabla>\<^sub>c f c) = strip c" by (metis assms(1) strip_map2_acom)
  from strip_while[OF this] assms(2) show ?thesis by(simp add: iter_widen_def)
qed

lemma iter_narrow_pfp: assumes "mono f" and "f c0 \<sqsubseteq> c0"
and "iter_narrow f c0 = Some c"
shows "f c \<sqsubseteq> c \<and> c \<sqsubseteq> c0" (is "?P c")
proof-
  { fix c assume "?P c"
    note 1 = conjunct1[OF this] and 2 = conjunct2[OF this]
    let ?c' = "c \<triangle>\<^sub>c f c"
    have "?P ?c'"
    proof
      have "f ?c' \<sqsubseteq> f c"  by(rule monoD[OF \<open>mono f\<close> narrow2_acom[OF 1]])
      also have "\<dots> \<sqsubseteq> ?c'" by(rule narrow1_acom[OF 1])
      finally show "f ?c' \<sqsubseteq> ?c'" .
      have "?c' \<sqsubseteq> c" by (rule narrow2_acom[OF 1])
      also have "c \<sqsubseteq> c0" by(rule 2)
      finally show "?c' \<sqsubseteq> c0" .
    qed
  }
  with while_option_rule[where P = ?P, OF _ assms(3)[simplified iter_narrow_def]]
    assms(2) le_refl
  show ?thesis by blast
qed

lemma pfp_wn_pfp:
  "\<lbrakk> mono f;  pfp_wn f c = Some c' \<rbrakk> \<Longrightarrow> f c' \<sqsubseteq> c'"
unfolding pfp_wn_def
by (auto dest: iter_widen_pfp iter_narrow_pfp split: option.splits)

lemma strip_pfp_wn:
  "\<lbrakk> \<forall>c. strip(f c) = strip c; pfp_wn f c = Some c' \<rbrakk> \<Longrightarrow> strip c' = c"
apply(auto simp add: pfp_wn_def iter_narrow_def split: option.splits)
by (metis (mono_tags) strip_map2_acom strip_while strip_bot_acom strip_iter_widen)

locale Abs_Int2 = Abs_Int1_mono
where \<gamma>=\<gamma> for \<gamma> :: "'av::{WN,L_top_bot} \<Rightarrow> val set"
begin

definition AI_wn :: "com \<Rightarrow> 'av st option acom option" where
"AI_wn = pfp_wn (step' \<top>)"

lemma AI_wn_sound: "AI_wn c = Some c' \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c c'"
proof(simp add: CS_def AI_wn_def)
  assume 1: "pfp_wn (step' \<top>) c = Some c'"
  from pfp_wn_pfp[OF mono_step'2 1]
  have 2: "step' \<top> c' \<sqsubseteq> c'" .
  have 3: "strip (\<gamma>\<^sub>c (step' \<top> c')) = c" by(simp add: strip_pfp_wn[OF _ 1])
  have "lfp (step UNIV) c \<le> \<gamma>\<^sub>c (step' \<top> c')"
  proof(rule lfp_lowerbound[simplified,OF 3])
    show "step UNIV (\<gamma>\<^sub>c (step' \<top> c')) \<le> \<gamma>\<^sub>c (step' \<top> c')"
    proof(rule step_preserves_le[OF _ _])
      show "UNIV \<subseteq> \<gamma>\<^sub>o \<top>" by simp
      show "\<gamma>\<^sub>c (step' \<top> c') \<le> \<gamma>\<^sub>c c'" by(rule mono_gamma_c[OF 2])
    qed
  qed
  from this 2 show "lfp (step UNIV) c \<le> \<gamma>\<^sub>c c'"
    by (blast intro: mono_gamma_c order_trans)
qed

end

global_interpretation Abs_Int2
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = plus_ivl
and test_num' = in_ivl
and filter_plus' = filter_plus_ivl and filter_less' = filter_less_ivl
defines AI_ivl' = AI_wn
..

subsection "Tests"

definition "step_up_ivl n = ((\<lambda>c. c \<nabla>\<^sub>c step_ivl \<top> c)^^n)"
definition "step_down_ivl n = ((\<lambda>c. c \<triangle>\<^sub>c step_ivl \<top> c)^^n)"

text\<open>For @{const test3_ivl}, @{const AI_ivl} needed as many iterations as
the loop took to execute. In contrast, @{const AI_ivl'} converges in a
constant number of steps:\<close>

value "show_acom (step_up_ivl 1 (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (step_up_ivl 2 (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (step_up_ivl 3 (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (step_up_ivl 4 (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (step_up_ivl 5 (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (step_down_ivl 1 (step_up_ivl 5 (\<bottom>\<^sub>c test3_ivl)))"
value "show_acom (step_down_ivl 2 (step_up_ivl 5 (\<bottom>\<^sub>c test3_ivl)))"
value "show_acom (step_down_ivl 3 (step_up_ivl 5 (\<bottom>\<^sub>c test3_ivl)))"

text\<open>Now all the analyses terminate:\<close>

value "show_acom_opt (AI_ivl' test4_ivl)"
value "show_acom_opt (AI_ivl' test5_ivl)"
value "show_acom_opt (AI_ivl' test6_ivl)"

subsection "Termination: Intervals"

definition m_ivl :: "ivl \<Rightarrow> nat" where
"m_ivl ivl = (case ivl of I l h \<Rightarrow>
     (case l of None \<Rightarrow> 0 | Some _ \<Rightarrow> 1) + (case h of None \<Rightarrow> 0 | Some _ \<Rightarrow> 1))"

lemma m_ivl_height: "m_ivl ivl \<le> 2"
by(simp add: m_ivl_def split: ivl.split option.split)

lemma m_ivl_anti_mono: "(y::ivl) \<sqsubseteq> x \<Longrightarrow> m_ivl x \<le> m_ivl y"
by(auto simp: m_ivl_def le_option_def le_ivl_def
        split: ivl.split option.split if_splits)

lemma m_ivl_widen:
  "~ y \<sqsubseteq> x \<Longrightarrow> m_ivl(x \<nabla> y) < m_ivl x"
by(auto simp: m_ivl_def widen_ivl_def le_option_def le_ivl_def
        split: ivl.splits option.splits if_splits)

lemma Top_less_ivl: "\<top> \<sqsubseteq> x \<Longrightarrow> m_ivl x = 0"
by(auto simp: m_ivl_def le_option_def le_ivl_def empty_def Top_ivl_def
        split: ivl.split option.split if_splits)

definition n_ivl :: "ivl \<Rightarrow> nat" where
"n_ivl ivl = 2 - m_ivl ivl"

lemma n_ivl_mono: "(x::ivl) \<sqsubseteq> y \<Longrightarrow> n_ivl x \<le> n_ivl y"
unfolding n_ivl_def by (metis diff_le_mono2 m_ivl_anti_mono)

lemma n_ivl_narrow:
  "~ x \<sqsubseteq> x \<triangle> y \<Longrightarrow> n_ivl(x \<triangle> y) < n_ivl x"
by(auto simp: n_ivl_def m_ivl_def narrow_ivl_def le_option_def le_ivl_def
        split: ivl.splits option.splits if_splits)

subsection "Termination: Abstract State"

definition "m_st m st = (\<Sum>x\<in>set(dom st). m(fun st x))"

lemma m_st_height: assumes "finite X" and "set (dom S) \<subseteq> X"
shows "m_st m_ivl S \<le> 2 * card X"
proof(auto simp: m_st_def)
  have "(\<Sum>x\<in>set(dom S). m_ivl (fun S x)) \<le> (\<Sum>x\<in>set(dom S). 2)" (is "?L \<le> _")
    by(rule sum_mono)(simp add:m_ivl_height)
  also have "\<dots> \<le> (\<Sum>x\<in>X. 2)"
    by(rule sum_mono2[OF assms]) simp
  also have "\<dots> = 2 * card X" by(simp)
  finally show "?L \<le> \<dots>" .
qed

lemma m_st_anti_mono:
  "S1 \<sqsubseteq> S2 \<Longrightarrow> m_st m_ivl S2 \<le> m_st m_ivl S1"
proof(auto simp: m_st_def le_st_def lookup_def split: if_splits)
  let ?X = "set(dom S1)" let ?Y = "set(dom S2)"
  let ?f = "fun S1" let ?g = "fun S2"
  assume asm: "\<forall>x\<in>?Y. (x \<in> ?X \<longrightarrow> ?f x \<sqsubseteq> ?g x) \<and> (x \<in> ?X \<or> \<top> \<sqsubseteq> ?g x)"
  hence 1: "\<forall>y\<in>?Y\<inter>?X. m_ivl(?g y) \<le> m_ivl(?f y)" by(simp add: m_ivl_anti_mono)
  have 0: "\<forall>x\<in>?Y-?X. m_ivl(?g x) = 0" using asm by (auto simp: Top_less_ivl)
  have "(\<Sum>y\<in>?Y. m_ivl(?g y)) = (\<Sum>y\<in>(?Y-?X) \<union> (?Y\<inter>?X). m_ivl(?g y))"
    by (metis Un_Diff_Int)
  also have "\<dots> = (\<Sum>y\<in>?Y-?X. m_ivl(?g y)) + (\<Sum>y\<in>?Y\<inter>?X. m_ivl(?g y))"
    by(subst sum.union_disjoint) auto
  also have "(\<Sum>y\<in>?Y-?X. m_ivl(?g y)) = 0" using 0 by simp
  also have "0 + (\<Sum>y\<in>?Y\<inter>?X. m_ivl(?g y)) = (\<Sum>y\<in>?Y\<inter>?X. m_ivl(?g y))" by simp
  also have "\<dots> \<le> (\<Sum>y\<in>?Y\<inter>?X. m_ivl(?f y))"
    by(rule sum_mono)(simp add: 1)
  also have "\<dots> \<le> (\<Sum>y\<in>?X. m_ivl(?f y))"
    by(simp add: sum_mono2[of "?X" "?Y Int ?X", OF _ Int_lower2])
  finally show "(\<Sum>y\<in>?Y. m_ivl(?g y)) \<le> (\<Sum>x\<in>?X. m_ivl(?f x))" .
qed

lemma m_st_widen:
assumes "\<not> S2 \<sqsubseteq> S1" shows "m_st m_ivl (S1 \<nabla> S2) < m_st m_ivl S1"
proof-
  { let ?X = "set(dom S1)" let ?Y = "set(dom S2)"
    let ?f = "fun S1" let ?g = "fun S2"
    fix x assume "x \<in> ?X" "\<not> lookup S2 x \<sqsubseteq> ?f x"
    have "(\<Sum>x\<in>?X\<inter>?Y. m_ivl(?f x \<nabla> ?g x)) < (\<Sum>x\<in>?X. m_ivl(?f x))" (is "?L < ?R")
    proof cases
      assume "x : ?Y"
      have "?L < (\<Sum>x\<in>?X\<inter>?Y. m_ivl(?f x))"
      proof(rule sum_strict_mono_ex1, simp)
        show "\<forall>x\<in>?X\<inter>?Y. m_ivl(?f x \<nabla> ?g x) \<le> m_ivl (?f x)"
          by (metis m_ivl_anti_mono widen1)
      next
        show "\<exists>x\<in>?X\<inter>?Y. m_ivl(?f x \<nabla> ?g x) < m_ivl(?f x)"
          using \<open>x:?X\<close> \<open>x:?Y\<close> \<open>\<not> lookup S2 x \<sqsubseteq> ?f x\<close>
          by (metis IntI m_ivl_widen lookup_def)
      qed
      also have "\<dots> \<le> ?R" by(simp add: sum_mono2[OF _ Int_lower1])
      finally show ?thesis .
    next
      assume "x ~: ?Y"
      have "?L \<le> (\<Sum>x\<in>?X\<inter>?Y. m_ivl(?f x))"
      proof(rule sum_mono, simp)
        fix x assume "x:?X \<and> x:?Y" show "m_ivl(?f x \<nabla> ?g x) \<le> m_ivl (?f x)"
          by (metis m_ivl_anti_mono widen1)
      qed
      also have "\<dots> < m_ivl(?f x) + \<dots>"
        using m_ivl_widen[OF \<open>\<not> lookup S2 x \<sqsubseteq> ?f x\<close>]
        by (metis Nat.le_refl add_strict_increasing gr0I not_less0)
      also have "\<dots> = (\<Sum>y\<in>insert x (?X\<inter>?Y). m_ivl(?f y))"
        using \<open>x ~: ?Y\<close> by simp
      also have "\<dots> \<le> (\<Sum>x\<in>?X. m_ivl(?f x))"
        by(rule sum_mono2)(insert \<open>x:?X\<close>, auto)
      finally show ?thesis .
    qed
  } with assms show ?thesis
    by(auto simp: le_st_def widen_st_def m_st_def Int_def)
qed

definition "n_st m X st = (\<Sum>x\<in>X. m(lookup st x))"

lemma n_st_mono: assumes "set(dom S1) \<subseteq> X" "set(dom S2) \<subseteq> X" "S1 \<sqsubseteq> S2"
shows "n_st n_ivl X S1 \<le> n_st n_ivl X S2"
proof-
  have "(\<Sum>x\<in>X. n_ivl(lookup S1 x)) \<le> (\<Sum>x\<in>X. n_ivl(lookup S2 x))"
    apply(rule sum_mono) using assms
    by(auto simp: le_st_def lookup_def n_ivl_mono split: if_splits)
  thus ?thesis by(simp add: n_st_def)
qed

lemma n_st_narrow:
assumes "finite X" and "set(dom S1) \<subseteq> X" "set(dom S2) \<subseteq> X"
and "S2 \<sqsubseteq> S1" "\<not> S1 \<sqsubseteq> S1 \<triangle> S2"
shows "n_st n_ivl X (S1 \<triangle> S2) < n_st n_ivl X S1"
proof-
  have 1: "\<forall>x\<in>X. n_ivl (lookup (S1 \<triangle> S2) x) \<le> n_ivl (lookup S1 x)"
    using assms(2-4)
    by(auto simp: le_st_def narrow_st_def lookup_def n_ivl_mono narrow2
            split: if_splits)
  have 2: "\<exists>x\<in>X. n_ivl (lookup (S1 \<triangle> S2) x) < n_ivl (lookup S1 x)"
    using assms(2-5)
    by(auto simp: le_st_def narrow_st_def lookup_def intro: n_ivl_narrow
            split: if_splits)
  have "(\<Sum>x\<in>X. n_ivl(lookup (S1 \<triangle> S2) x)) < (\<Sum>x\<in>X. n_ivl(lookup S1 x))"
    apply(rule sum_strict_mono_ex1[OF \<open>finite X\<close>]) using 1 2 by blast+
  thus ?thesis by(simp add: n_st_def)
qed

subsection "Termination: Option"

definition "m_o m n opt = (case opt of None \<Rightarrow> n+1 | Some x \<Rightarrow> m x)"

lemma m_o_anti_mono: "finite X \<Longrightarrow> domo S2 \<subseteq> X \<Longrightarrow> S1 \<sqsubseteq> S2 \<Longrightarrow>
  m_o (m_st m_ivl) (2 * card X) S2 \<le> m_o (m_st m_ivl) (2 * card X) S1"
apply(induction S1 S2 rule: le_option.induct)
apply(auto simp: domo_def m_o_def m_st_anti_mono le_SucI m_st_height
           split: option.splits)
done

lemma m_o_widen: "\<lbrakk> finite X; domo S2 \<subseteq> X; \<not> S2 \<sqsubseteq> S1 \<rbrakk> \<Longrightarrow>
  m_o (m_st m_ivl) (2 * card X) (S1 \<nabla> S2) < m_o (m_st m_ivl) (2 * card X) S1"
by(auto simp: m_o_def domo_def m_st_height less_Suc_eq_le m_st_widen
        split: option.split)

definition "n_o n opt = (case opt of None \<Rightarrow> 0 | Some x \<Rightarrow> n x + 1)"

lemma n_o_mono: "domo S1 \<subseteq> X \<Longrightarrow> domo S2 \<subseteq> X \<Longrightarrow> S1 \<sqsubseteq> S2 \<Longrightarrow>
  n_o (n_st n_ivl X) S1 \<le> n_o (n_st n_ivl X) S2"
apply(induction S1 S2 rule: le_option.induct)
apply(auto simp: domo_def n_o_def n_st_mono
           split: option.splits)
done

lemma n_o_narrow:
  "\<lbrakk> finite X; domo S1 \<subseteq> X; domo S2 \<subseteq> X; S2 \<sqsubseteq> S1; \<not> S1 \<sqsubseteq> S1 \<triangle> S2 \<rbrakk>
  \<Longrightarrow> n_o (n_st n_ivl X) (S1 \<triangle> S2) < n_o (n_st n_ivl X) S1"
apply(induction S1 S2 rule: narrow_option.induct)
apply(auto simp: n_o_def domo_def n_st_narrow)
done

lemma domo_widen_subset: "domo (S1 \<nabla> S2) \<subseteq> domo S1 \<union> domo S2"
apply(induction S1 S2 rule: widen_option.induct)
apply (auto simp: domo_def widen_st_def)
done

lemma domo_narrow_subset: "domo (S1 \<triangle> S2) \<subseteq> domo S1 \<union> domo S2"
apply(induction S1 S2 rule: narrow_option.induct)
apply (auto simp: domo_def narrow_st_def)
done

subsection "Termination: Commands"

lemma strip_widen_acom[simp]:
  "strip c' = strip (c::'a::WN acom) \<Longrightarrow>  strip (c \<nabla>\<^sub>c c') = strip c"
by(induction "widen::'a\<Rightarrow>'a\<Rightarrow>'a" c c' rule: map2_acom.induct) simp_all

lemma strip_narrow_acom[simp]:
  "strip c' = strip (c::'a::WN acom) \<Longrightarrow>  strip (c \<triangle>\<^sub>c c') = strip c"
by(induction "narrow::'a\<Rightarrow>'a\<Rightarrow>'a" c c' rule: map2_acom.induct) simp_all

lemma annos_widen_acom[simp]: "strip c1 = strip (c2::'a::WN acom) \<Longrightarrow>
  annos(c1 \<nabla>\<^sub>c c2) = map (%(x,y).x\<nabla>y) (zip (annos c1) (annos(c2::'a::WN acom)))"
by(induction "widen::'a\<Rightarrow>'a\<Rightarrow>'a" c1 c2 rule: map2_acom.induct)
  (simp_all add: size_annos_same2)

lemma annos_narrow_acom[simp]: "strip c1 = strip (c2::'a::WN acom) \<Longrightarrow>
  annos(c1 \<triangle>\<^sub>c c2) = map (%(x,y).x\<triangle>y) (zip (annos c1) (annos(c2::'a::WN acom)))"
by(induction "narrow::'a\<Rightarrow>'a\<Rightarrow>'a" c1 c2 rule: map2_acom.induct)
  (simp_all add: size_annos_same2)

lemma widen_acom_Com[simp]: "strip c2 = strip c1 \<Longrightarrow>
  c1 : Com X \<Longrightarrow> c2 : Com X \<Longrightarrow> (c1 \<nabla>\<^sub>c c2) : Com X"
apply(auto simp add: Com_def)
apply(rename_tac S S' x)
apply(erule in_set_zipE)
apply(auto simp: domo_def split: option.splits)
apply(case_tac S)
apply(case_tac S')
apply simp
apply fastforce
apply(case_tac S')
apply fastforce
apply (fastforce simp: widen_st_def)
done

lemma narrow_acom_Com[simp]: "strip c2 = strip c1 \<Longrightarrow>
  c1 : Com X \<Longrightarrow> c2 : Com X \<Longrightarrow> (c1 \<triangle>\<^sub>c c2) : Com X"
apply(auto simp add: Com_def)
apply(rename_tac S S' x)
apply(erule in_set_zipE)
apply(auto simp: domo_def split: option.splits)
apply(case_tac S)
apply(case_tac S')
apply simp
apply fastforce
apply(case_tac S')
apply fastforce
apply (fastforce simp: narrow_st_def)
done

definition "m_c m c = (let as = annos c in \<Sum>i=0..<size as. m(as!i))"

lemma measure_m_c: "finite X \<Longrightarrow> {(c, c \<nabla>\<^sub>c c') |c c'::ivl st option acom.
     strip c' = strip c \<and> c : Com X \<and> c' : Com X \<and> \<not> c' \<sqsubseteq> c}\<inverse>
    \<subseteq> measure(m_c(m_o (m_st m_ivl) (2*card(X))))"
apply(auto simp: m_c_def Let_def Com_def)
apply(subgoal_tac "length(annos c') = length(annos c)")
prefer 2 apply (simp add: size_annos_same2)
apply (auto)
apply(rule sum_strict_mono_ex1)
apply simp
apply (clarsimp)
apply(erule m_o_anti_mono)
apply(rule subset_trans[OF domo_widen_subset])
apply fastforce
apply(rule widen1)
apply(auto simp: le_iff_le_annos listrel_iff_nth)
apply(rule_tac x=n in bexI)
prefer 2 apply simp
apply(erule m_o_widen)
apply (simp)+
done

lemma measure_n_c: "finite X \<Longrightarrow> {(c, c \<triangle>\<^sub>c c') |c c'.
  strip c = strip c' \<and> c \<in> Com X \<and> c' \<in> Com X \<and> c' \<sqsubseteq> c \<and> \<not> c \<sqsubseteq> c \<triangle>\<^sub>c c'}\<inverse>
  \<subseteq> measure(m_c(n_o (n_st n_ivl X)))"
apply(auto simp: m_c_def Let_def Com_def)
apply(subgoal_tac "length(annos c') = length(annos c)")
prefer 2 apply (simp add: size_annos_same2)
apply (auto)
apply(rule sum_strict_mono_ex1)
apply simp
apply (clarsimp)
apply(rule n_o_mono)
using domo_narrow_subset apply fastforce
apply fastforce
apply(rule narrow2)
apply(fastforce simp: le_iff_le_annos listrel_iff_nth)
apply(auto simp: le_iff_le_annos listrel_iff_nth)
apply(rule_tac x=n in bexI)
prefer 2 apply simp
apply(erule n_o_narrow)
apply (simp)+
done

subsection "Termination: Post-Fixed Point Iterations"

lemma iter_widen_termination:
fixes c0 :: "'a::WN acom"
assumes P_f: "\<And>c. P c \<Longrightarrow> P(f c)"
assumes P_widen: "\<And>c c'. P c \<Longrightarrow> P c' \<Longrightarrow> P(c \<nabla>\<^sub>c c')"
and "wf({(c::'a acom,c \<nabla>\<^sub>c c')|c c'. P c \<and> P c' \<and> ~ c' \<sqsubseteq> c}^-1)"
and "P c0" and "c0 \<sqsubseteq> f c0" shows "\<exists>c. iter_widen f c0 = Some c"
proof(simp add: iter_widen_def, rule wf_while_option_Some[where P = "P"])
  show "wf {(cc', c). (P c \<and> \<not> f c \<sqsubseteq> c) \<and> cc' = c \<nabla>\<^sub>c f c}"
    apply(rule wf_subset[OF assms(3)]) by(blast intro: P_f)
next
  show "P c0" by(rule \<open>P c0\<close>)
next
  fix c assume "P c" thus "P (c \<nabla>\<^sub>c f c)" by(simp add: P_f P_widen)
qed

lemma iter_narrow_termination:
assumes P_f: "\<And>c. P c \<Longrightarrow> P(c \<triangle>\<^sub>c f c)"
and wf: "wf({(c, c \<triangle>\<^sub>c f c)|c c'. P c \<and> ~ c \<sqsubseteq> c \<triangle>\<^sub>c f c}^-1)"
and "P c0" shows "\<exists>c. iter_narrow f c0 = Some c"
proof(simp add: iter_narrow_def, rule wf_while_option_Some[where P = "P"])
  show "wf {(c', c). (P c \<and> \<not> c \<sqsubseteq> c \<triangle>\<^sub>c f c) \<and> c' = c \<triangle>\<^sub>c f c}"
    apply(rule wf_subset[OF wf]) by(blast intro: P_f)
next
  show "P c0" by(rule \<open>P c0\<close>)
next
  fix c assume "P c" thus "P (c \<triangle>\<^sub>c f c)" by(simp add: P_f)
qed

lemma iter_winden_step_ivl_termination:
  "\<exists>c. iter_widen (step_ivl \<top>) (\<bottom>\<^sub>c c0) = Some c"
apply(rule iter_widen_termination[where
  P = "%c. strip c = c0 \<and> c : Com(vars c0)"])
apply (simp_all add: step'_Com bot_acom)
apply(rule wf_subset)
apply(rule wf_measure)
apply(rule subset_trans)
prefer 2
apply(rule measure_m_c[where X = "vars c0", OF finite_cvars])
apply blast
done

lemma iter_narrow_step_ivl_termination:
  "c0 \<in> Com (vars(strip c0)) \<Longrightarrow> step_ivl \<top> c0 \<sqsubseteq> c0 \<Longrightarrow>
  \<exists>c. iter_narrow (step_ivl \<top>) c0 = Some c"
apply(rule iter_narrow_termination[where
  P = "%c. strip c = strip c0 \<and> c : Com(vars(strip c0)) \<and> step_ivl \<top> c \<sqsubseteq> c"])
apply (simp_all add: step'_Com)
apply(clarify)
apply(frule narrow2_acom, drule mono_step'[OF le_refl], erule le_trans[OF _ narrow1_acom])
apply assumption
apply(rule wf_subset)
apply(rule wf_measure)
apply(rule subset_trans)
prefer 2
apply(rule measure_n_c[where X = "vars(strip c0)", OF finite_cvars])
apply auto
by (metis bot_least domo_Top order_refl step'_Com strip_step')

(* FIXME: simplify type system: Combine Com(X) and vars <= X?? *)
lemma while_Com:
fixes c :: "'a st option acom"
assumes "while_option P f c = Some c'"
and "!!c. strip(f c) = strip c"
and "\<forall>c::'a st option acom. c : Com(X) \<longrightarrow> vars(strip c) \<subseteq> X \<longrightarrow> f c : Com(X)"
and "c : Com(X)" and "vars(strip c) \<subseteq> X" shows "c' : Com(X)"
using while_option_rule[where P = "\<lambda>c'. c' : Com(X) \<and> vars(strip c') \<subseteq> X", OF _ assms(1)]
by(simp add: assms(2-))

lemma iter_widen_Com: fixes f :: "'a::WN st option acom \<Rightarrow> 'a st option acom"
assumes "iter_widen f c = Some c'"
and "\<forall>c. c : Com(X) \<longrightarrow> vars(strip c) \<subseteq> X \<longrightarrow> f c : Com(X)"
and "!!c. strip(f c) = strip c"
and "c : Com(X)" and "vars (strip c) \<subseteq> X" shows "c' : Com(X)"
proof-
  have "\<forall>c. c : Com(X) \<longrightarrow> vars(strip c) \<subseteq> X \<longrightarrow> c \<nabla>\<^sub>c f c : Com(X)"
    by (metis (full_types) widen_acom_Com assms(2,3))
  from while_Com[OF assms(1)[simplified iter_widen_def] _ this assms(4,5)]
  show ?thesis using assms(3) by(simp)
qed

context Abs_Int2
begin

lemma iter_widen_step'_Com:
  "iter_widen (step' \<top>) c = Some c' \<Longrightarrow> vars(strip c) \<subseteq> X \<Longrightarrow> c : Com(X)
   \<Longrightarrow> c' : Com(X)"
apply(subgoal_tac "strip c'= strip c")
prefer 2 apply (metis strip_iter_widen strip_step')
apply(drule iter_widen_Com)
prefer 3 apply assumption
prefer 3 apply assumption
apply (auto simp: step'_Com)
done

end

theorem AI_ivl'_termination:
  "\<exists>c'. AI_ivl' c = Some c'"
apply(auto simp: AI_wn_def pfp_wn_def iter_winden_step_ivl_termination split: option.split)
apply(rule iter_narrow_step_ivl_termination)
apply (metis bot_acom_Com iter_widen_step'_Com[OF _ subset_refl] strip_iter_widen strip_step')
apply(erule iter_widen_pfp)
done

end

(* interesting(?) relic
lemma widen_assoc:
  "~ (y::ivl) \<sqsubseteq> x \<Longrightarrow> ~ z \<sqsubseteq> x \<nabla> y \<Longrightarrow> ((x::ivl) \<nabla> y) \<nabla> z = x \<nabla> (y \<nabla> z)"
apply(cases x)
apply(cases y)
apply(cases z)
apply(rename_tac x1 x2 y1 y2 z1 z2)
apply(simp add: le_ivl_def)
apply(case_tac x1)
apply(case_tac x2)
apply(simp add:le_option_def widen_ivl_def split: if_splits option.splits)
apply(simp add:le_option_def widen_ivl_def split: if_splits option.splits)
apply(case_tac x2)
apply(simp add:le_option_def widen_ivl_def split: if_splits option.splits)
apply(case_tac y1)
apply(case_tac y2)
apply(simp add:le_option_def widen_ivl_def split: if_splits option.splits)
apply(case_tac z1)
apply(auto simp add:le_option_def widen_ivl_def split: if_splits option.splits ivl.splits)[1]
apply(auto simp add:le_option_def widen_ivl_def split: if_splits option.splits ivl.splits)[1]
apply(case_tac y2)
apply(auto simp add:le_option_def widen_ivl_def split: if_splits option.splits ivl.splits)[1]
apply(case_tac z1)
apply(auto simp add:le_option_def widen_ivl_def split: if_splits ivl.splits option.splits)[1]
apply(case_tac z2)
apply(auto simp add:le_option_def widen_ivl_def split: if_splits option.splits)[1]
apply(auto simp add:le_option_def widen_ivl_def split: if_splits option.splits)[1]
done

lemma widen_step_trans:
  "~ (y::ivl) \<sqsubseteq> x \<Longrightarrow> ~ z \<sqsubseteq> x \<nabla> y \<Longrightarrow> \<exists>u. (x \<nabla> y) \<nabla> z = x \<nabla> u \<and> ~ u \<sqsubseteq> x"
by (metis widen_assoc preord_class.le_trans widen1)
*)


section \<open>Finite Prefixes of Infinite Sequences\<close>

theory Word_Prefixes
imports
  List_Prefixes
  "../Extensions/List_Extensions"
  Transition_Systems_and_Automata.Sequence
begin

  definition prefix_fininf :: "'a list \<Rightarrow> 'a stream \<Rightarrow> bool" (infix "\<le>\<^sub>F\<^sub>I" 50)
    where "u \<le>\<^sub>F\<^sub>I v \<equiv> \<exists> w. u @- w = v"

  lemma prefix_fininfI[intro]:
    assumes "u @- w = v"
    shows "u \<le>\<^sub>F\<^sub>I v"
    using assms unfolding prefix_fininf_def by auto
  lemma prefix_fininfE[elim]:
    assumes "u \<le>\<^sub>F\<^sub>I v"
    obtains w
    where "v = u @- w"
    using assms unfolding prefix_fininf_def by auto

  lemma prefix_fininfI_empty[intro!]: "[] \<le>\<^sub>F\<^sub>I w" by force
  lemma prefix_fininfI_item[intro!]:
    assumes "a = b" "u \<le>\<^sub>F\<^sub>I v"
    shows "a # u \<le>\<^sub>F\<^sub>I b ## v"
    using assms by force
  lemma prefix_fininfE_item[elim!]:
    assumes "a # u \<le>\<^sub>F\<^sub>I b ## v"
    obtains "a = b" "u \<le>\<^sub>F\<^sub>I v"
    using assms by force

  lemma prefix_fininf_item[simp]: "a # u \<le>\<^sub>F\<^sub>I a ## v \<longleftrightarrow> u \<le>\<^sub>F\<^sub>I v" by force
  lemma prefix_fininf_list[simp]: "w @ u \<le>\<^sub>F\<^sub>I w @- v \<longleftrightarrow> u \<le>\<^sub>F\<^sub>I v" by (induct w, auto)
  lemma prefix_fininf_conc[intro]: "u \<le>\<^sub>F\<^sub>I u @- v" by auto
  lemma prefix_fininf_prefix[intro]: "stake k w \<le>\<^sub>F\<^sub>I w" using stake_sdrop by blast
  lemma prefix_fininf_set_range[dest]: "u \<le>\<^sub>F\<^sub>I v \<Longrightarrow> set u \<subseteq> sset v" by auto

  lemma prefix_fininf_absorb:
    assumes "u \<le>\<^sub>F\<^sub>I v @- w" "length u \<le> length v"
    shows "u \<le> v"
  proof -
    obtain x where 1: "u @- x = v @- w" using assms(1) by auto
    have "u \<le> u @ stake (length v - length u) x" by rule
    also have "\<dots> = stake (length v) (u @- x)" using assms(2) by (simp add: stake_shift)
    also have "\<dots> = stake (length v) (v @- w)" unfolding 1 by rule
    also have "\<dots> = v" using eq_shift by blast
    finally show ?thesis by this
  qed
  lemma prefix_fininf_extend:
    assumes "u \<le>\<^sub>F\<^sub>I v @- w" "length v \<le> length u"
    shows "v \<le> u"
  proof -
    obtain x where 1: "u @- x = v @- w" using assms(1) by auto
    have "v \<le> v @ stake (length u - length v) w" by rule
    also have "\<dots> = stake (length u) (v @- w)" using assms(2) by (simp add: stake_shift)
    also have "\<dots> = stake (length u) (u @- x)" unfolding 1 by rule
    also have "\<dots> = u" using eq_shift by blast
    finally show ?thesis by this
  qed
  lemma prefix_fininf_length:
    assumes "u \<le>\<^sub>F\<^sub>I w" "v \<le>\<^sub>F\<^sub>I w" "length u \<le> length v"
    shows "u \<le> v"
  proof -
    obtain u' v' where 1: "w = u @- u'" "w = v @- v'" using assms(1, 2) by blast+
    have "u = stake (length u) (u @- u')" using shift_eq by blast
    also have "\<dots> = stake (length u) w" unfolding 1(1) by rule
    also have "\<dots> = stake (length u) (v @- v')" unfolding 1(2) by rule
    also have "\<dots> = take (length u) v" using assms by (simp add: min.absorb2 stake_append)
    also have "\<dots> \<le> v" by rule
    finally show ?thesis by this
  qed

  lemma prefix_fininf_append:
    assumes "u \<le>\<^sub>F\<^sub>I v @- w"
    obtains (absorb) "u \<le> v" | (extend) z where "u = v @ z" "z \<le>\<^sub>F\<^sub>I w"
  proof (cases "length u" "length v" rule: le_cases)
    case le
    obtain x where 1: "u @- x = v @- w" using assms(1) by auto
    show ?thesis
    proof (rule absorb)
      have "u \<le> u @ stake (length v - length u) x" by rule
      also have "\<dots> = stake (length v) (u @- x)" using le by (simp add: stake_shift)
      also have "\<dots> = stake (length v) (v @- w)" unfolding 1 by rule
      also have "\<dots> = v" using eq_shift by blast
      finally show "u \<le> v" by this
    qed
  next
    case ge
    obtain x where 1: "u @- x = v @- w" using assms(1) by auto
    show ?thesis
    proof (rule extend)
      have "u = stake (length u) (u @- x)" using shift_eq by auto
      also have "\<dots> = stake (length u) (v @- w)" unfolding 1 by rule
      also have "\<dots> = v @ stake (length u - length v) w" using ge by (simp add: stake_shift)
      finally show "u = v @ stake (length u - length v) w" by this
      show "stake (length u - length v) w \<le>\<^sub>F\<^sub>I w" by rule
    qed
  qed

  lemma prefix_fin_prefix_fininf_trans[trans, intro]: "u \<le> v \<Longrightarrow> v \<le>\<^sub>F\<^sub>I w \<Longrightarrow> u \<le>\<^sub>F\<^sub>I w"
    by (metis Prefix_Order.prefixE prefix_fininf_def shift_append)

  lemma prefix_finE_nth:
    assumes "u \<le> v" "i < length u"
    shows "u ! i = v ! i"
  proof -
    obtain w where 1: "v = u @ w" using assms(1) by auto
    show ?thesis unfolding 1 using assms(2) by (simp add: nth_append)
  qed
  lemma prefix_fininfI_nth:
    assumes "\<And> i. i < length u \<Longrightarrow> u ! i = w !! i"
    shows "u \<le>\<^sub>F\<^sub>I w"
  proof (rule prefix_fininfI)
    show "u @- sdrop (length u) w = w" by (simp add: assms list_eq_iff_nth_eq shift_eq)
  qed

  definition chain :: "(nat \<Rightarrow> 'a list) \<Rightarrow> bool"
    where "chain w \<equiv> mono w \<and> (\<forall> k. \<exists> l. k < length (w l))"
  definition limit :: "(nat \<Rightarrow> 'a list) \<Rightarrow> 'a stream"
    where "limit w \<equiv> smap (\<lambda> k. w (SOME l. k < length (w l)) ! k) nats"

  lemma chainI[intro?]:
    assumes "mono w"
    assumes "\<And> k. \<exists> l. k < length (w l)"
    shows "chain w"
    using assms unfolding chain_def by auto
  lemma chainD_mono[dest?]:
    assumes "chain w"
    shows "mono w"
    using assms unfolding chain_def by auto
  lemma chainE_length[elim?]:
    assumes "chain w"
    obtains l
    where "k < length (w l)"
    using assms unfolding chain_def by auto

  lemma chain_prefix_limit:
    assumes "chain w"
    shows "w k \<le>\<^sub>F\<^sub>I limit w"
  proof (rule prefix_fininfI_nth)
    fix i
    assume 1: "i < length (w k)"
    have 2: "mono w" "\<And> k. \<exists> l. k < length (w l)" using chainD_mono chainE_length assms by blast+
    have 3: "i < length (w (SOME l. i < length (w l)))" using someI_ex 2(2) by this
    show "w k ! i = limit w !! i"
    proof (cases "k" "SOME l. i < length (w l)" rule: le_cases)
      case (le)
      have 4: "w k \<le> w (SOME l. i < length (w l))" using monoD 2(1) le by this
      show ?thesis unfolding limit_def using prefix_finE_nth 4 1 by auto
    next
      case (ge)
      have 4: "w (SOME l. i < length (w l)) \<le> w k" using monoD 2(1) ge by this
      show ?thesis unfolding limit_def using prefix_finE_nth 4 3 by auto
    qed
  qed

  lemma chain_construct_1:
    assumes "P 0 x\<^sub>0" "\<And> k x. P k x \<Longrightarrow> \<exists> x'. P (Suc k) x' \<and> f x \<le> f x'"
    assumes "\<And> k x. P k x \<Longrightarrow> k \<le> length (f x)"
    obtains Q
    where "\<And> k. P k (Q k)" "chain (f \<circ> Q)"
  proof -
    obtain x' where 1:
      "P 0 x\<^sub>0" "\<And> k x. P k x \<Longrightarrow> P (Suc k) (x' k x) \<and> f x \<le> f (x' k x)"
      using assms(1, 2) by metis
    define Q where "Q \<equiv> rec_nat x\<^sub>0 x'"
    have [simp]: "Q 0 = x\<^sub>0" "\<And> k. Q (Suc k) = x' k (Q k)" unfolding Q_def by simp+
    have 2: "\<And> k. P k (Q k)"
    proof -
      fix k
      show "P k (Q k)" using 1 by (induct k, auto)
    qed
    show ?thesis
    proof (intro that chainI monoI, unfold comp_apply)
      fix k
      show "P k (Q k)" using 2 by this
    next
      fix x y :: nat
      assume "x \<le> y"
      thus "f (Q x) \<le> f (Q y)"
      proof (induct "y - x" arbitrary: x y)
        case 0
        show ?case using 0 by simp
      next
        case (Suc k)
        have "f (Q x) \<le> f (Q (Suc x))" using 1(2) 2 by auto
        also have "\<dots> \<le> f (Q y)" using Suc(2) by (intro Suc(1), auto)
        finally show ?case by this
      qed
    next
      fix k
      have 3: "P (Suc k) (Q (Suc k))" using 2 by this
      have 4: "Suc k \<le> length (f (Q (Suc k)))" using assms(3) 3 by this
      have 5: "k < length (f (Q (Suc k)))" using 4 by auto
      show "\<exists> l. k < length (f (Q l))" using 5 by blast
    qed
  qed
  lemma chain_construct_2:
    assumes "P 0 x\<^sub>0" "\<And> k x. P k x \<Longrightarrow> \<exists> x'. P (Suc k) x' \<and> f x \<le> f x' \<and> g x \<le> g x'"
    assumes "\<And> k x. P k x \<Longrightarrow> k \<le> length (f x)" "\<And> k x. P k x \<Longrightarrow> k \<le> length (g x)"
    obtains Q
    where "\<And> k. P k (Q k)" "chain (f \<circ> Q)" "chain (g \<circ> Q)"
  proof -
    obtain x' where 1:
      "P 0 x\<^sub>0" "\<And> k x. P k x \<Longrightarrow> P (Suc k) (x' k x) \<and> f x \<le> f (x' k x) \<and> g x \<le> g (x' k x)"
      using assms(1, 2) by metis
    define Q where "Q \<equiv> rec_nat x\<^sub>0 x'"
    have [simp]: "Q 0 = x\<^sub>0" "\<And> k. Q (Suc k) = x' k (Q k)" unfolding Q_def by simp+
    have 2: "\<And> k. P k (Q k)"
    proof -
      fix k
      show "P k (Q k)" using 1 by (induct k, auto)
    qed
    show ?thesis
    proof (intro that chainI monoI, unfold comp_apply)
      fix k
      show "P k (Q k)" using 2 by this
    next
      fix x y :: nat
      assume "x \<le> y"
      thus "f (Q x) \<le> f (Q y)"
      proof (induct "y - x" arbitrary: x y)
        case 0
        show ?case using 0 by simp
      next
        case (Suc k)
        have "f (Q x) \<le> f (Q (Suc x))" using 1(2) 2 by auto
        also have "\<dots> \<le> f (Q y)" using Suc(2) by (intro Suc(1), auto)
        finally show ?case by this
      qed
    next
      fix k
      have 3: "P (Suc k) (Q (Suc k))" using 2 by this
      have 4: "Suc k \<le> length (f (Q (Suc k)))" using assms(3) 3 by this
      have 5: "k < length (f (Q (Suc k)))" using 4 by auto
      show "\<exists> l. k < length (f (Q l))" using 5 by blast
    next
      fix x y :: nat
      assume "x \<le> y"
      thus "g (Q x) \<le> g (Q y)"
      proof (induct "y - x" arbitrary: x y)
        case 0
        show ?case using 0 by simp
      next
        case (Suc k)
        have "g (Q x) \<le> g (Q (Suc x))" using 1(2) 2 by auto
        also have "\<dots> \<le> g (Q y)" using Suc(2) by (intro Suc(1), auto)
        finally show ?case by this
      qed
    next
      fix k
      have 3: "P (Suc k) (Q (Suc k))" using 2 by this
      have 4: "Suc k \<le> length (g (Q (Suc k)))" using assms(4) 3 by this
      have 5: "k < length (g (Q (Suc k)))" using 4 by auto
      show "\<exists> l. k < length (g (Q l))" using 5 by blast
    qed
  qed
  lemma chain_construct_2':
    assumes "P 0 u\<^sub>0 v\<^sub>0" "\<And> k u v. P k u v \<Longrightarrow> \<exists> u' v'. P (Suc k) u' v' \<and> u \<le> u' \<and> v \<le> v'"
    assumes "\<And> k u v. P k u v \<Longrightarrow> k \<le> length u" "\<And> k u v. P k u v \<Longrightarrow> k \<le> length v"
    obtains u v
    where "\<And> k. P k (u k) (v k)" "chain u" "chain v"
  proof -
    obtain Q where 1: "\<And> k. (case_prod \<circ> P) k (Q k)" "chain (fst \<circ> Q)" "chain (snd \<circ> Q)"
    proof (rule chain_construct_2)
      show "\<exists> x'. (case_prod \<circ> P) (Suc k) x' \<and> fst x \<le> fst x' \<and> snd x \<le> snd x'"
        if "(case_prod \<circ> P) k x" for k x using assms that by auto
      show "(case_prod \<circ> P) 0 (u\<^sub>0, v\<^sub>0)" using assms by auto
      show "k \<le> length (fst x)" if "(case_prod \<circ> P) k x" for k x using assms that by auto
      show "k \<le> length (snd x)" if "(case_prod \<circ> P) k x" for k x using assms that by auto
    qed rule
    show ?thesis
    proof
      show "P k ((fst \<circ> Q) k) ((snd \<circ> Q) k)" for k using 1(1) by (auto simp: prod.case_eq_if)
      show "chain (fst \<circ> Q)" "chain (snd \<circ> Q)" using 1(2, 3) by this
    qed
  qed

end


theory tut6
imports Main
begin

datatype 'a TREE = LEAF 'a | NODE 'a "'a TREE" "'a TREE"

primrec MIRROR :: "'a TREE \<Rightarrow> 'a TREE" where
"MIRROR (LEAF x) = LEAF x" |
"MIRROR (NODE x left right) = NODE x (MIRROR right) (MIRROR left)"

thm TREE.induct

lemma "MIRROR(MIRROR t) = t"
proof (induction t)
  case LEAF
  then show ?case by simp
next
  case (NODE x left right)
  then show ?case by simp
qed

end


(*  Title:      HOL/Hoare/ExamplesAbort.thy
    Author:     Tobias Nipkow
    Copyright   1998 TUM

Some small examples for programs that may abort.
*)

theory ExamplesAbort imports Hoare_Logic_Abort begin

lemma "VARS x y z::nat
 {y = z & z \<noteq> 0} z \<noteq> 0 \<rightarrow> x := y div z {x = 1}"
by vcg_simp

lemma
 "VARS a i j
 {k <= length a & i < k & j < k} j < length a \<rightarrow> a[i] := a!j {True}"
by vcg_simp

lemma "VARS (a::int list) i
 {True}
 i := 0;
 WHILE i < length a
 INV {i <= length a}
 DO a[i] := 7; i := i+1 OD
 {True}"
by vcg_simp

end


(* Title:      Domain Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Domain Iterings\<close>

theory Domain_Iterings

imports Domain Lattice_Ordered_Semirings Omega_Algebras

begin

class domain_semiring_lattice = left_zero_domain_semiring + lattice_ordered_pre_left_semiring
begin

subclass bounded_idempotent_left_zero_semiring ..

lemma d_top:
  "d(top) = 1"
  by (metis sup_left_top d_dist_sup d_one d_plus_one)

lemma mult_domain_top:
  "x * d(y) * top \<le> d(x * y) * top"
  by (smt d_mult_d d_restrict_equals mult_assoc mult_right_isotone top_greatest)

lemma domain_meet_domain:
  "d(x \<sqinter> d(y) * z) \<le> d(y)"
  by (metis d_export d_isotone d_mult_greatest_lower_bound inf.cobounded2)

lemma meet_domain:
  "x \<sqinter> d(y) * z = d(y) * (x \<sqinter> z)"
  apply (rule order.antisym)
  apply (metis domain_meet_domain d_mult_below d_restrict_equals inf_mono mult_isotone)
  by (meson d_mult_below le_inf_iff mult_left_sub_dist_inf_right)

lemma meet_intro_domain:
  "x \<sqinter> y = d(y) * x \<sqinter> y"
  by (metis d_restrict_equals inf_commute meet_domain)

lemma meet_domain_top:
  "x \<sqinter> d(y) * top = d(y) * x"
  by (simp add: meet_domain)

proposition "d(x) = x * top \<sqinter> 1" nitpick [expect=genuine,card=3] oops

lemma d_galois:
  "d(x) \<le> d(y) \<longleftrightarrow> x \<le> d(y) * top"
  by (metis d_export d_isotone d_mult_left_absorb_sup d_plus_one d_restrict_equals d_top mult_isotone top.extremum)

lemma vector_meet:
  "x * top \<sqinter> y \<le> d(x) * y"
  by (metis d_galois d_mult_sub inf.sup_monoid.add_commute inf.sup_right_isotone meet_domain_top)

end

class domain_semiring_lattice_L = domain_semiring_lattice + L +
  assumes l1: "x * L = x * bot \<squnion> d(x) * L"
  assumes l2: "d(L) * x \<le> x * d(L)"
  assumes l3: "d(L) * top \<le> L \<squnion> d(L * bot) * top"
  assumes l4: "L * top \<le> L"
  assumes l5: "x * bot \<sqinter> L \<le> (x \<sqinter> L) * bot"
begin

lemma l8:
  "(x \<sqinter> L) * bot \<le> x * bot \<sqinter> L"
  by (meson inf.boundedE inf.boundedI mult_right_sub_dist_inf_left zero_right_mult_decreasing)

lemma l9:
  "x * bot \<sqinter> L \<le> d(x * bot) * L"
  by (metis vector_meet vector_mult_closed zero_vector)

lemma l10:
  "L * L = L"
  by (metis d_restrict_equals l1 le_iff_sup zero_right_mult_decreasing)

lemma l11:
  "d(x) * L \<le> x * L"
  by (metis l1 sup.cobounded2)

lemma l12:
  "d(x * bot) * L \<le> x * bot"
  by (metis sup_right_divisibility l1 mult_assoc mult_left_zero)

lemma l13:
  "d(x * bot) * L \<le> x"
  using l12 order_trans zero_right_mult_decreasing by blast

lemma l14:
  "x * L \<le> x * bot \<squnion> L"
  by (metis d_mult_below l1 sup_right_isotone)

lemma l15:
  "x * d(y) * L = x * bot \<squnion> d(x * y) * L"
  by (metis d_commutative d_mult_d d_zero l1 mult_assoc mult_left_zero)

lemma l16:
  "x * top \<sqinter> L \<le> x * L"
  using inf.order_lesseq_imp l11 vector_meet by blast

lemma l17:
  "d(x) * L \<le> d(x * L) * L"
  by (metis d_mult_below l11 le_infE le_infI meet_intro_domain)

lemma l18:
  "d(x) * L = d(x * L) * L"
  by (simp add: order.antisym d_mult_sub l17 mult_left_isotone)

lemma l19:
  "d(x * top * bot) * L \<le> d(x * L) * L"
  by (metis d_mult_sub l18 mult_assoc mult_left_isotone)

lemma l20:
  "x \<le> y \<longleftrightarrow> x \<le> y \<squnion> L \<and> x \<le> y \<squnion> d(y * bot) * top"
  apply (rule iffI)
  apply (simp add: le_supI1)
  by (smt sup_commute sup_inf_distrib1 l13 le_iff_sup meet_domain_top)

lemma l21:
  "d(x * bot) * L \<le> x * bot \<sqinter> L"
  by (simp add: d_mult_below l12)

lemma l22:
  "x * bot \<sqinter> L = d(x * bot) * L"
  using l21 order.antisym l9 by auto

lemma l23:
  "x * top \<sqinter> L = d(x) * L"
  apply (rule order.antisym)
  apply (simp add: vector_meet)
  by (metis d_mult_below inf.le_sup_iff inf_top.left_neutral l1 le_supE mult_left_sub_dist_inf_left)

lemma l29:
  "L * d(L) = L"
  by (metis d_preserves_equation d_restrict_equals l2)

lemma l30:
  "d(L) * x \<le> (x \<sqinter> L) \<squnion> d(L * bot) * x"
  by (metis inf.sup_right_divisibility inf_left_commute inf_sup_distrib1 l3 meet_domain_top)

lemma l31:
  "d(L) * x = (x \<sqinter> L) \<squnion> d(L * bot) * x"
  by (smt (z3) l30 d_dist_sup le_iff_sup meet_intro_domain semiring.combine_common_factor sup_commute sup_inf_absorb zero_right_mult_decreasing)

lemma l40:
  "L * x \<le> L"
  by (meson bot_least inf.order_trans l4 semiring.mult_left_mono top.extremum)

lemma l41:
  "L * top = L"
  by (simp add: l40 order.antisym top_right_mult_increasing)

lemma l50:
  "x * bot \<sqinter> L = (x \<sqinter> L) * bot"
  using order.antisym l5 l8 by force

lemma l51:
  "d(x * bot) * L = (x \<sqinter> L) * bot"
  using l22 l50 by auto

lemma l90:
  "L * top * L = L"
  by (simp add: l41 l10)

lemma l91:
  assumes "x = x * top"
    shows "d(L * bot) * x \<le> d(x * bot) * top"
proof -
  have "d(L * bot) * x \<le> d(d(L * bot) * x) * top"
    using d_galois by blast
  also have "... = d(d(L * bot) * d(x)) * top"
    using d_mult_d by auto
  also have "... = d(d(x) * L * bot) * top"
    using d_commutative d_mult_d ils.il_inf_associative by auto
  also have "... \<le> d(x * L * bot) * top"
    by (metis d_isotone l11 mult_left_isotone)
  also have "... \<le> d(x * top * bot) * top"
    by (simp add: d_isotone mult_left_isotone mult_right_isotone)
  finally show ?thesis
    using assms by auto
qed

lemma l92:
  assumes "x = x * top"
    shows "d(L * bot) * x \<le> d((x \<sqinter> L) * bot) * top"
proof -
  have "d(L * bot) * x = d(L) * d(L * bot) * x"
    using d_commutative d_mult_sub d_order by auto
  also have "... \<le> d(L) * d(x * bot) * top"
    by (metis assms order.eq_iff l91 mult_assoc mult_isotone)
  also have "... = d(d(x * bot) * L) * top"
    by (simp add: d_commutative d_export)
  also have "... \<le> d((x \<sqinter> L) * bot) * top"
    by (simp add: l51)
  finally show ?thesis
    .
qed

end

class domain_itering_lattice_L = bounded_itering + domain_semiring_lattice_L
begin

lemma mult_L_circ:
  "(x * L)\<^sup>\<circ> = 1 \<squnion> x * L"
  by (metis circ_back_loop_fixpoint circ_mult l40 le_iff_sup mult_assoc)

lemma mult_L_circ_mult_below:
  "(x * L)\<^sup>\<circ> * y \<le> y \<squnion> x * L"
  by (smt sup_right_isotone l40 mult_L_circ mult_assoc mult_left_one mult_right_dist_sup mult_right_isotone)

lemma circ_L:
  "L\<^sup>\<circ> = L \<squnion> 1"
  by (metis sup_commute l10 mult_L_circ)

lemma circ_d0_L:
  "x\<^sup>\<circ> * d(x * bot) * L = x\<^sup>\<circ> * bot"
  by (metis sup_bot_right circ_loop_fixpoint circ_plus_same d_zero l15 mult_assoc mult_left_zero)

lemma d0_circ_left_unfold:
  "d(x\<^sup>\<circ> * bot) = d(x * x\<^sup>\<circ> * bot)"
  by (metis sup_commute sup_bot_left circ_loop_fixpoint mult_assoc)

lemma d_circ_import:
  "d(y) * x \<le> x * d(y) \<Longrightarrow> d(y) * x\<^sup>\<circ> = d(y) * (d(y) * x)\<^sup>\<circ>"
  apply (rule order.antisym)
  apply (simp add: circ_import d_idempotent d_plus_one le_iff_sup)
  using circ_isotone d_mult_below mult_right_isotone by auto

end

class domain_omega_algebra_lattice_L = bounded_left_zero_omega_algebra + domain_semiring_lattice_L
begin

lemma mult_L_star:
  "(x * L)\<^sup>\<star> = 1 \<squnion> x * L"
  by (metis l40 le_iff_sup mult_assoc star.circ_back_loop_fixpoint star.circ_mult)

lemma mult_L_omega:
  "(x * L)\<^sup>\<omega> \<le> x * L"
  by (metis l40 mult_right_isotone omega_slide)

lemma mult_L_sup_star:
  "(x * L \<squnion> y)\<^sup>\<star> = y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
proof (rule order.antisym)
  have "(x * L \<squnion> y) * (y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L) = x * L * (y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L) \<squnion> y * (y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L)"
    by (simp add: mult_right_dist_sup)
  also have "... \<le> x * L \<squnion> y * (y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L)"
    by (metis sup_left_isotone l40 mult_assoc mult_right_isotone)
  also have "... \<le> x * L \<squnion> y * y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    by (smt sup_assoc sup_commute sup_ge2 mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
  also have "... \<le> x * L \<squnion> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    by (meson order_refl star.left_plus_below_circ sup_mono)
  also have "... = y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    by (metis sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint star.circ_reflexive star.circ_sup_one_right_unfold star_involutive)
  finally have "1 \<squnion> (x * L \<squnion> y) * (y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L) \<le> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    by (meson le_supI le_supI1 star.circ_reflexive)
  thus "(x * L \<squnion> y)\<^sup>\<star> \<le> y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L"
    using star_left_induct by fastforce
next
  show "y\<^sup>\<star> \<squnion> y\<^sup>\<star> * x * L \<le> (x * L \<squnion> y)\<^sup>\<star>"
    by (metis sup_commute le_sup_iff mult_assoc star.circ_increasing star.circ_mult_upper_bound star.circ_sub_dist)
qed

lemma mult_L_sup_omega:
  "(x * L \<squnion> y)\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
proof -
  have 1: "(y\<^sup>\<star> * x * L)\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
    by (simp add: le_supI2 mult_L_omega)
  have "(y\<^sup>\<star> * x * L)\<^sup>\<star> * y\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * L"
    by (metis sup_right_isotone l40 mult_assoc mult_right_isotone star_left_induct)
  thus ?thesis
    using 1 by (simp add: ils.il_inf_associative omega_decompose sup_monoid.add_commute)
qed

end

sublocale domain_omega_algebra_lattice_L < dL_star: itering where circ = star ..

sublocale domain_omega_algebra_lattice_L < dL_star: domain_itering_lattice_L where circ = star ..

context domain_omega_algebra_lattice_L
begin

lemma d0_star_below_d0_omega:
  "d(x\<^sup>\<star> * bot) \<le> d(x\<^sup>\<omega> * bot)"
  by (simp add: d_isotone star_bot_below_omega_bot)

lemma d0_below_d0_omega:
  "d(x * bot) \<le> d(x\<^sup>\<omega> * bot)"
  by (metis d0_star_below_d0_omega d_isotone mult_left_isotone order_trans star.circ_increasing)

lemma star_L_split:
  assumes "y \<le> z"
      and "x * z * L \<le> x * bot \<squnion> z * L"
    shows "x\<^sup>\<star> * y * L \<le> x\<^sup>\<star> * bot \<squnion> z * L"
proof -
  have "x * (x\<^sup>\<star> * bot \<squnion> z * L) \<le> x\<^sup>\<star> * bot \<squnion> x * z * L"
    by (metis sup_bot_right order.eq_iff mult_assoc mult_left_dist_sup star.circ_loop_fixpoint)
  also have "... \<le> x\<^sup>\<star> * bot \<squnion> x * bot \<squnion> z * L"
    using assms(2) semiring.add_left_mono sup_monoid.add_assoc by auto
  also have "... = x\<^sup>\<star> * bot \<squnion> z * L"
    using mult_isotone star.circ_increasing sup.absorb_iff1 by force
  finally have "y * L \<squnion> x * (x\<^sup>\<star> * bot \<squnion> z * L) \<le> x\<^sup>\<star> * bot \<squnion> z * L"
    by (simp add: assms(1) le_supI1 mult_left_isotone sup_monoid.add_commute)
  thus ?thesis
    by (simp add: star_left_induct mult.assoc)
qed

lemma star_L_split_same:
  "x * y * L \<le> x * bot \<squnion> y * L \<Longrightarrow> x\<^sup>\<star> * y * L = x\<^sup>\<star> * bot \<squnion> y * L"
  apply (rule order.antisym)
  using star_L_split apply blast
  by (metis bot_least ils.il_inf_associative le_supI mult_isotone mult_left_one order_refl star.circ_reflexive)

lemma star_d_L_split_equal:
  "d(x * y) \<le> d(y) \<Longrightarrow> x\<^sup>\<star> * d(y) * L = x\<^sup>\<star> * bot \<squnion> d(y) * L"
  by (metis sup_right_isotone l15 le_iff_sup mult_right_sub_dist_sup_left star_L_split_same)

lemma d0_omega_mult:
  "d(x\<^sup>\<omega> * y * bot) = d(x\<^sup>\<omega> * bot)"
  apply (rule order.antisym)
  apply (simp add: d_isotone mult_isotone omega_sub_vector)
  by (metis d_isotone mult_assoc mult_right_isotone bot_least)

lemma d_omega_export:
  "d(y) * x \<le> x * d(y) \<Longrightarrow> d(y) * x\<^sup>\<omega> = (d(y) * x)\<^sup>\<omega>"
  apply (rule order.antisym)
  apply (simp add: d_preserves_equation omega_simulation)
  by (smt le_iff_sup mult_left_dist_sup omega_simulation_2 omega_slide)

lemma d_omega_import:
  "d(y) * x \<le> x * d(y) \<Longrightarrow> d(y) * x\<^sup>\<omega> = d(y) * (d(y) * x)\<^sup>\<omega>"
  using d_idempotent omega_import order.refl by auto

lemma star_d_omega_top:
  "x\<^sup>\<star> * d(x\<^sup>\<omega>) * top = x\<^sup>\<star> * bot \<squnion> d(x\<^sup>\<omega>) * top"
  apply (rule order.antisym)
  apply (metis le_supI2 mult_domain_top star_mult_omega)
  by (metis ils.il_inf_associative le_supI mult_left_one mult_left_sub_dist_sup_right mult_right_sub_dist_sup_left star.circ_right_unfold_1 sup_monoid.add_0_right)

lemma omega_meet_L:
  "x\<^sup>\<omega> \<sqinter> L = d(x\<^sup>\<omega>) * L"
  by (metis l23 omega_vector)

proposition d_star_mult: "d(x * y) \<le> d(y) \<Longrightarrow> d(x\<^sup>\<star> * y) = d(x\<^sup>\<star> * bot) \<squnion> d(y)" oops
proposition d0_split_omega_omega: "x\<^sup>\<omega> \<le> x\<^sup>\<omega> * bot \<squnion> d(x\<^sup>\<omega> \<sqinter> L) * top" nitpick [expect=genuine,card=2] oops

end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_QSortIsSort
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if le y z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

fun gt :: "Nat => Nat => bool" where
  "gt y z = lt z y"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter q (nil2) = nil2"
| "filter q (cons2 z xs) =
     (if q z then cons2 z (filter q xs) else filter q xs)"

(*fun did not finish the proof*)
function qsort :: "Nat list => Nat list" where
  "qsort (nil2) = nil2"
| "qsort (cons2 z xs) =
     x (qsort (filter (% (z2 :: Nat) => le z2 z) xs))
       (x (cons2 z (nil2))
          (qsort (filter (% (x2 :: Nat) => gt x2 z) xs)))"
  by pat_completeness auto

theorem property0 :
  "((qsort xs) = (isort xs))"
  oops

end


theory LTree
imports Main  "$AFP/Coinductive/Coinductive_List"
begin

codatatype (lset: 'a) tree = Node (nxt : "'a \<Rightarrow> 'a tree option")

primcorec empty :: "'a tree"
  where "nxt empty = (\<lambda> _ . None)"

primcorec single :: "'a \<Rightarrow> 'a tree"
  where "nxt (single x) = (\<lambda> _ . None)(x := Some empty)"

primcorec many :: "'a \<Rightarrow> 'a tree"
  where "nxt (many x) = (\<lambda> x'. if x' = x then Some (many x) else None)"

primcorec anything :: "'a tree"
  where "nxt anything = (\<lambda> _ . Some anything)"

coinductive paths_aux :: "'a tree \<Rightarrow> 'a llist \<Rightarrow> bool"
  where "paths_aux t LNil"
      | "nxt t x = Some t' \<Longrightarrow> paths_aux t' l \<Longrightarrow> paths_aux t (LCons x l)"

definition paths :: "'a tree \<Rightarrow> 'a llist set"
  where "paths t = Collect (paths_aux t)"
lemma elim_paths_aux[pred_set_conv]: "paths_aux t p \<longleftrightarrow> p \<in> paths t" unfolding paths_def by simp
lemmas paths_intros[intro?] = paths_aux.intros[unfolded elim_paths_aux]
lemmas paths_coinduct[consumes 1, coinduct set: paths] = paths_aux.coinduct[to_set]
lemmas paths_cases[consumes 1, cases set: paths] = paths_aux.cases[to_set]
lemmas paths_simpss = paths_aux.simps[to_set]

lemma "repeat x \<in> paths (many x)"
  apply (coinduction)
  apply (rule disjI2)
  apply auto
  apply (rule exI[where x = "repeat x"])
  apply auto
  apply (rule iterates)
  done

fun op_option :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> 'a option"
  where "op_option f (Some x) (Some y) = Some (f x y)"
      | "op_option f (Some x) None     = Some x"
      | "op_option f None     (Some y) = Some y"
      | "op_option f None     None     = None"
(*
primcorec or :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
  where "nxt (or t1 t2) = (\<lambda> x. op_option or (nxt t1 x) (nxt t2 x))"
*)
primcorec or :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
  where "nxt (or t1 t2) = (\<lambda> x.
           case (nxt t1 x) of Some t1' \<Rightarrow> (case nxt t2 x of Some t2' \<Rightarrow> Some (or t1' t2') | None \<Rightarrow> Some t1')
                              | None     \<Rightarrow> nxt t2 x)"

lemma or_simp:  "nxt (or t1 t2) x =  op_option or (nxt t1 x) (nxt t2 x)"
  by (cases "nxt t1 x", case_tac [!] "nxt t2 x") auto

(*
primcorec and_aux :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
      and and :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
  where "(and_aux t1 t2) = Node (\<lambda> x. case (nxt t1 x) of Some t1' \<Rightarrow> Some (and t1' t2) | None \<Rightarrow> None)"
       |"(and t1 t2) = or (and_aux t1 t2) (and_aux t2 t1)"

primcorec and :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
   where "(and t1 t2) = or (Node (\<lambda> x. case (nxt t1 x) of Some t1' \<Rightarrow> Some (and t1' t2) | None \<Rightarrow> None)) (Node (\<lambda> x. case (nxt t1 x) of Some t1' \<Rightarrow> Some (and t1' t2) | None \<Rightarrow> None))"

primcorec and :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
   where "nxt (and t1 t2) = (\<lambda> x.
      case (nxt t1 x) of Some t1' \<Rightarrow> (case nxt t2 x of Some t2' \<Rightarrow> Some (or (and t1' t2) (and t1 t2')) | None \<Rightarrow> Some (and t1' t2))
                         | None     \<Rightarrow> (case nxt t2 x of Some t2' \<Rightarrow> Some (and t1 t2')                     | None \<Rightarrow> None))"

primcorec and :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
   where "nxt (and t1 t2) = map_option (\<lambda> (x,y). (and x y, and x y)) o (\<lambda> x.
      case (nxt t1 x) of Some t1' \<Rightarrow> (case nxt t2 x of Some t2' \<Rightarrow> Some (or t1' t1, or t2 t2') | None \<Rightarrow> Some (t1', t2))
                         | None     \<Rightarrow> (case nxt t2 x of Some t2' \<Rightarrow> Some (t1, t2')                | None \<Rightarrow> None))"
*)

end


(*  Title:       Proving the Correctness of Disk Paxos

    Author:      Mauro J. Jaskelioff, Stephan Merz, 2005
    Maintainer:  Mauro J. Jaskelioff <mauro at fceia.unr.edu.ar>
*)

theory DiskPaxos_Inv3 imports DiskPaxos_Inv2  begin

subsection \<open>Invariant 3\<close>

text \<open>
  This invariant says that if two processes have read each other's block
  from disk $d$ during their current phases, then at least one of them
  has read the other's current block.
\<close>

definition HInv3_L :: "state \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "HInv3_L s p q d =  (phase s p \<in> {1,2}
                     \<and> phase s q \<in> {1,2}
                     \<and> hasRead s p d q
                     \<and> hasRead s q d p)"

definition HInv3_R :: "state \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "HInv3_R s p q d =  (\<lparr>block= dblock s q, proc= q\<rparr> \<in> blocksRead s p d
                     \<or> \<lparr>block= dblock s p, proc= p\<rparr> \<in> blocksRead s q d)"

definition HInv3_inner :: "state \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
  where "HInv3_inner s p q d = (HInv3_L s p q d \<longrightarrow> HInv3_R s p q d)"

definition HInv3 :: "state \<Rightarrow> bool"
  where "HInv3 s = (\<forall>p q d. HInv3_inner s p q d)"

subsubsection\<open>Proofs of Invariant 3\<close>

theorem HInit_HInv3: "HInit s \<Longrightarrow> HInv3 s"
  by(simp add: HInit_def Init_def HInv3_def
               HInv3_inner_def HInv3_L_def HInv3_R_def)

lemma InitPhase_HInv3_p:
  "\<lbrakk> InitializePhase s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: InitializePhase_def HInv3_inner_def
                    hasRead_def HInv3_L_def HInv3_R_def)

lemma InitPhase_HInv3_q:
  "\<lbrakk> InitializePhase s s' q ; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: InitializePhase_def HInv3_inner_def
                    hasRead_def HInv3_L_def HInv3_R_def)

lemma HInv3_L_sym: "HInv3_L s p q d \<Longrightarrow> HInv3_L s q p d"
  by(auto simp add: HInv3_L_def)

lemma HInv3_R_sym: "HInv3_R s p q d \<Longrightarrow> HInv3_R s q p d"
  by(auto simp add: HInv3_R_def)

lemma Phase1or2ReadThen_HInv3_pq:
  assumes act:  "Phase1or2ReadThen s s' p d q"
  and  inv_L':  "HInv3_L s' p q d"
  and      pq:  "p\<noteq>q"
  and   inv2b:  "Inv2b s"
  shows   "HInv3_R s' p q d"
proof -
  from inv_L' act pq
  have "phase s q \<in> {1,2} \<and> hasRead s q d p"
    by(auto simp add: Phase1or2ReadThen_def HInv3_L_def
            hasRead_def split: if_split_asm)
  with inv2b
  have "disk s d q = dblock s q"
    by(auto simp add: Inv2b_def Inv2b_inner_def
             hasRead_def)
  with act
  show ?thesis
    by(auto simp add: Phase1or2ReadThen_def HInv3_def
                       HInv3_inner_def HInv3_R_def)
qed

lemma Phase1or2ReadThen_HInv3_hasRead:
  "\<lbrakk> \<not>hasRead s pp dd qq;
     Phase1or2ReadThen s s' p d q;
     pp\<noteq>p \<or> qq\<noteq>q \<or> dd\<noteq>d\<rbrakk>
  \<Longrightarrow> \<not>hasRead s' pp dd qq"
  by(auto simp add: hasRead_def Phase1or2ReadThen_def)

theorem HPhase1or2ReadThen_HInv3:
  assumes act:  "HPhase1or2ReadThen s s' p d q"
  and     inv:  "HInv3 s"
  and      pq:  "p\<noteq>q"
  and   inv2b:  "Inv2b s"
  shows   "HInv3 s'"
proof(clarsimp simp add: HInv3_def HInv3_inner_def)
  fix pp qq dd
  assume h3l': "HInv3_L s' pp qq dd"
  show  "HInv3_R s' pp qq dd"
  proof(cases "HInv3_L s pp qq dd")
    case True
    with inv
    have "HInv3_R s pp qq dd"
      by(auto simp add: HInv3_def HInv3_inner_def)
    with act h3l'
    show ?thesis
      by(auto simp add: HInv3_R_def HInv3_L_def
                          Phase1or2ReadThen_def)
  next
    case False
    assume nh3l: "\<not> HInv3_L s pp qq dd"
    show " HInv3_R s' pp qq dd"
    proof(cases "((pp=p \<and> qq=q) \<or> (pp=q \<and> qq=p)) \<and> dd=d")
      case True
      with act pq inv2b h3l' HInv3_L_sym[OF h3l']
      show ?thesis
        by(auto dest: Phase1or2ReadThen_HInv3_pq HInv3_R_sym)
    next
      case False
      from nh3l h3l' act
      have "(\<not>hasRead s pp dd qq \<or> \<not>hasRead s qq dd pp)
            \<and> hasRead s' pp dd qq \<and> hasRead s' qq dd pp"
        by(auto simp add: HInv3_L_def Phase1or2ReadThen_def)
      with act False
      show ?thesis
        by(auto dest: Phase1or2ReadThen_HInv3_hasRead)
    qed
  qed
qed

lemma StartBallot_HInv3_p:
  "\<lbrakk> StartBallot s s' p; HInv3_L s' p q d \<rbrakk>
          \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: StartBallot_def dest: InitPhase_HInv3_p)

lemma StartBallot_HInv3_q:
  "\<lbrakk> StartBallot s s' q; HInv3_L s' p q d \<rbrakk>
           \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: StartBallot_def dest: InitPhase_HInv3_q)

lemma StartBallot_HInv3_nL:
  "\<lbrakk> StartBallot s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
           \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: StartBallot_def InitializePhase_def
                      HInv3_L_def hasRead_def)

lemma StartBallot_HInv3_R:
  "\<lbrakk> StartBallot s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
              \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: StartBallot_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma StartBallot_HInv3_t:
  "\<lbrakk> StartBallot s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
        dest: StartBallot_HInv3_nL StartBallot_HInv3_R)

lemma StartBallot_HInv3:
  assumes act: "StartBallot s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
         dest: StartBallot_HInv3_p StartBallot_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: StartBallot_HInv3_t)
qed

theorem HStartBallot_HInv3:
  "\<lbrakk> HStartBallot s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: StartBallot_HInv3)

theorem HPhase1or2ReadElse_HInv3:
  "\<lbrakk> HPhase1or2ReadElse s s' p d q; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: Phase1or2ReadElse_def HInv3_def
              dest: StartBallot_HInv3)

theorem HPhase1or2Write_HInv3:
  assumes act: "HPhase1or2Write s s' p d"
  and inv: "HInv3 s"
  shows "HInv3 s'"
proof(auto simp add: HInv3_def)
  fix pp qq dd
  show " HInv3_inner s' pp qq dd"
  proof(cases "HInv3_L s pp qq dd")
    case True
    with inv
    have "HInv3_R s pp qq dd"
      by(simp add: HInv3_def HInv3_inner_def)
    with act
    show ?thesis
      by(auto simp add: HInv3_inner_def HInv3_R_def
                      Phase1or2Write_def)
  next
    case False
    with act
    have "\<not>HInv3_L s' pp qq dd"
      by(auto simp add: HInv3_L_def hasRead_def Phase1or2Write_def)
    thus ?thesis
      by(simp add: HInv3_inner_def)
  qed
qed

lemma EndPhase1_HInv3_p:
  "\<lbrakk> EndPhase1 s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: EndPhase1_def dest: InitPhase_HInv3_p)

lemma EndPhase1_HInv3_q:
  "\<lbrakk> EndPhase1 s s' q; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase1_def dest: InitPhase_HInv3_q)

lemma EndPhase1_HInv3_nL:
  "\<lbrakk> EndPhase1 s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                    \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: EndPhase1_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma EndPhase1_HInv3_R:
  "\<lbrakk> EndPhase1 s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                      \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase1_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma EndPhase1_HInv3_t:
  "\<lbrakk> EndPhase1 s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def dest: EndPhase1_HInv3_nL
                   EndPhase1_HInv3_R)

lemma EndPhase1_HInv3:
  assumes act: "EndPhase1 s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: EndPhase1_HInv3_p EndPhase1_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: EndPhase1_HInv3_t)
qed

theorem HEndPhase1_HInv3:
  "\<lbrakk> HEndPhase1 s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: EndPhase1_HInv3)

lemma EndPhase2_HInv3_p:
  "\<lbrakk> EndPhase2 s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: EndPhase2_def dest: InitPhase_HInv3_p)

lemma EndPhase2_HInv3_q:
  "\<lbrakk> EndPhase2 s s' q; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase2_def dest: InitPhase_HInv3_q)

lemma EndPhase2_HInv3_nL:
  "\<lbrakk> EndPhase2 s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                     \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: EndPhase2_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma EndPhase2_HInv3_R:
  "\<lbrakk> EndPhase2 s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                     \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase2_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma EndPhase2_HInv3_t:
  "\<lbrakk> EndPhase2 s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                    \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
              dest: EndPhase2_HInv3_nL EndPhase2_HInv3_R)

lemma EndPhase2_HInv3:
  assumes act: "EndPhase2 s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: EndPhase2_HInv3_p EndPhase2_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: EndPhase2_HInv3_t)
qed

theorem HEndPhase2_HInv3:
  "\<lbrakk> HEndPhase2 s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: EndPhase2_HInv3)

lemma Fail_HInv3_p:
  "\<lbrakk> Fail s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: Fail_def dest: InitPhase_HInv3_p)

lemma Fail_HInv3_q:
  "\<lbrakk> Fail s s' q; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: Fail_def dest: InitPhase_HInv3_q)

lemma Fail_HInv3_nL:
  "\<lbrakk> Fail s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
             \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: Fail_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma Fail_HInv3_R:
  "\<lbrakk> Fail s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
             \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: Fail_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma Fail_HInv3_t:
  "\<lbrakk> Fail s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
              \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
              dest: Fail_HInv3_nL Fail_HInv3_R)

lemma Fail_HInv3:
  assumes act: "Fail s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: Fail_HInv3_p Fail_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: Fail_HInv3_t)
qed

theorem HFail_HInv3:
  "\<lbrakk> HFail s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: Fail_HInv3)

theorem HPhase0Read_HInv3:
  assumes act: "HPhase0Read s s' p d"
  and inv: "HInv3 s"
  shows "HInv3 s'"
proof(auto simp add: HInv3_def)
  fix pp qq dd
  show " HInv3_inner s' pp qq dd"
  proof(cases "HInv3_L s pp qq dd")
    case True
    with inv
    have "HInv3_R s pp qq dd"
      by(simp add: HInv3_def HInv3_inner_def)
    with act
    show ?thesis
      by(auto simp add: HInv3_inner_def HInv3_R_def Phase0Read_def)
  next
    case False
    with act
    have "\<not>HInv3_L s' pp qq dd"
      by(auto simp add: HInv3_L_def hasRead_def Phase0Read_def)
    thus ?thesis
      by(simp add: HInv3_inner_def)
  qed
qed

lemma EndPhase0_HInv3_p:
  "\<lbrakk> EndPhase0 s s' p; HInv3_L s' p q d \<rbrakk>
              \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: EndPhase0_def dest: InitPhase_HInv3_p)

lemma EndPhase0_HInv3_q:
  "\<lbrakk> EndPhase0 s s' q; HInv3_L s' p q d \<rbrakk>
              \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase0_def dest: InitPhase_HInv3_q)

lemma EndPhase0_HInv3_nL:
  "\<lbrakk> EndPhase0 s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
               \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: EndPhase0_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma EndPhase0_HInv3_R:
  "\<lbrakk> EndPhase0 s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase0_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma EndPhase0_HInv3_t:
  "\<lbrakk> EndPhase0 s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                 \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
              dest: EndPhase0_HInv3_nL EndPhase0_HInv3_R)

lemma EndPhase0_HInv3:
  assumes act: "EndPhase0 s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: EndPhase0_HInv3_p EndPhase0_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: EndPhase0_HInv3_t)
qed

theorem HEndPhase0_HInv3:
  "\<lbrakk> HEndPhase0 s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: EndPhase0_HInv3)

text\<open>$HInv1 \wedge HInv2 \wedge HInv3$ is an invariant of $HNext$.\<close>

lemma I2c:
  assumes nxt: "HNext s s'"
  and inv: "HInv1 s \<and> HInv2 s \<and> HInv3 s"
  shows "HInv3 s'" using assms
  by(auto simp add: HNext_def Next_def,
     auto intro: HStartBallot_HInv3,
     auto intro: HPhase0Read_HInv3,
     auto intro: HPhase1or2Write_HInv3,
     auto simp add: Phase1or2Read_def HInv2_def
          intro: HPhase1or2ReadThen_HInv3
                 HPhase1or2ReadElse_HInv3,
     auto simp add: EndPhase1or2_def
          intro: HEndPhase1_HInv3
                 HEndPhase2_HInv3,
     auto intro: HFail_HInv3,
     auto intro: HEndPhase0_HInv3)

end


theory Cycle
imports Main
"../../topoS/thy_lib/FiniteGraph"
"../../topoS/thy_lib/isabelle_afp/Graph_Theory/Pair_Digraph"
"../../topoS/thy_lib/Collections/Refine_Dflt"
"../../topoS/thy_lib/Collections/Examples/Autoref/Nested_DFS"
begin

definition graph_to_afp_graph :: "'v graph \<Rightarrow> 'v pair_pre_digraph" where
  "graph_to_afp_graph G \<equiv> \<lparr> pverts = nodes G, parcs = edges G \<rparr>"

lemma "\<lbrakk> valid_graph G \<rbrakk> \<Longrightarrow> pair_wf_digraph (graph_to_afp_graph G)"
  apply(unfold_locales)
  by(auto simp add: valid_graph_def graph_to_afp_graph_def)

lemma "\<lbrakk> valid_graph G \<rbrakk> \<Longrightarrow> pair_fin_digraph (graph_to_afp_graph G)"
  apply(unfold_locales)
  by(auto simp add: valid_graph_def graph_to_afp_graph_def)

lemma "with_proj (graph_to_afp_graph G) =  \<lparr> verts = nodes G, arcs = edges G, tail = fst, head = snd \<rparr>"
  by(simp add: graph_to_afp_graph_def)

definition "has_directed_cycle" :: "'v graph \<Rightarrow> ('v \<times> 'v) awalk \<Rightarrow> bool" where
  "has_directed_cycle G p \<equiv> pre_digraph.cycle (with_proj (graph_to_afp_graph G)) p"

lemma fixes G::"'v graph" and Gafp::"('v, 'v \<times> 'v) pre_digraph"
  assumes transl: "Gafp = with_proj (graph_to_afp_graph G)"
  shows "has_directed_cycle G p = (\<exists>u. pre_digraph.awalk Gafp u p u \<and> distinct (tl (pre_digraph.awalk_verts Gafp u p)) \<and> p \<noteq> [])"
  by(simp add: has_directed_cycle_def pre_digraph.cycle_def transl)

(*hmm, for my purposes, this almost looks executable enough! \<dots>*)
definition pcycle :: "'v set \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> 'v \<Rightarrow> bool" where
  "pcycle V E v0 \<equiv> \<exists>v\<in>V. (v0,v)\<in>E\<^sup>* \<and> (v,v)\<in>E\<^sup>+"
(*for my purpose, it might be enough:
  \<forall> reachable v0 x. (x,x) \<notin> view^+ but this does not find undirected cycles! *)
(*is basic routing loop detection*)

hide_const(open) succ (*my succ in my graph*)

definition nodes_of :: "('v \<times> 'v) set \<Rightarrow> 'v set" where "nodes_of E \<equiv> (fst ` E \<union> snd ` E)"

(*Collections&Refinement tests*)

(*requires: no loops (x,x) \<in> E*)
(*V=worklist, (vertex, parent)*)
definition cycles_dfs_imp :: "('a \<times>'a) set \<Rightarrow> 'a \<Rightarrow> bool nres"
  where
  "cycles_dfs_imp E v0 \<equiv>  do {
      (_,_,cycle) \<leftarrow> WHILE (\<lambda> (W,Discovered,cycle). W \<noteq> {} \<and> \<not> cycle) (\<lambda> (W,Discovered,cycle). do {
        (vparent,v) \<leftarrow> SPEC (\<lambda>v. v\<in>W);
        if v \<in> snd ` Discovered (* \<or> v \<in> fst ` Discovered evtl auch fst`?? test in python first!*)
        then
          RETURN (W,Discovered,True)
        else do {
          let succs = {v'. (v,v')\<in>E \<or> (v',v)\<in>E} - {vparent,v}; (*exclude self-loops*)
          let W = W - {(vparent,v)};
          let Discovered = insert (vparent,v) Discovered;
          let W = W \<union> ({v} \<times> succs);
          RETURN (W,Discovered,cycle)
        }
      }) ({(v0,v0 (*probably: succs v0????*))},{},False);
      RETURN cycle
  }"

lemma pcas_append: "pcas a p b \<Longrightarrow> pcas a (p @ [(b, c)]) c"
  by(induction a p b rule: pcas.induct, simp_all)

lemma pcas_iff_trancl: assumes "x \<noteq> y" shows "(\<exists> p. set p \<subseteq> D \<and> pcas x p y) \<longleftrightarrow> (x,y) \<in> D\<^sup>+"
proof
  assume "\<exists>p. set p \<subseteq> D \<and> pcas x p y"
  from this obtain p where pset: "set p \<subseteq> D" and pcas: "pcas x p y" by auto
  have "x \<noteq> y \<longrightarrow> set p \<subseteq> D \<longrightarrow> pcas x p y \<longrightarrow> (x, y) \<in> D\<^sup>+"
    apply(induction p arbitrary: x y)
    apply(simp)
    apply(clarify)
    apply(simp)
    using trancl_into_trancl2 by (metis r_into_trancl')
  from this assms pset pcas
  show "(x, y) \<in> D\<^sup>+" by simp
next
  show "(x,y) \<in> D\<^sup>+ \<Longrightarrow> (\<exists> p. set p \<subseteq> D \<and> pcas x p y)"
  apply(induction rule: trancl_induct)
  apply(rule_tac x="[(x,y)]" in exI)
  apply(simp)
  apply(erule exE)
  apply(rule_tac x="p@[(y,z)]" in exI)
  apply(simp add: pcas_append)
  done
qed

lemma pcas_start_in_pawalkvert: "pcas a p b \<Longrightarrow> a \<in> set (pawalk_verts a p)"
  by(induction p, simp_all)
lemma pcas_end_in_pawalkvert: "pcas a p b \<Longrightarrow> b \<in> set (pawalk_verts a p)"
  by(induction p arbitrary: a, simp_all)
lemma pcas_distinct_len: "pcas a p b \<Longrightarrow>  a \<noteq> b \<Longrightarrow> length p \<ge> 1"
  by(induction a p b rule:pcas.induct, simp_all)
lemma pawalk_verts_length: "length (pawalk_verts a p) = Suc (length p)"
  by(induction p arbitrary: a, simp_all)

lemma takeWhile_append_split: "\<lbrakk>\<exists>x\<in>set X. \<not> P x \<Longrightarrow> Q (takeWhile P X);
       (\<And>x. x\<in>set X \<Longrightarrow> P x) \<Longrightarrow> Q (X@takeWhile P Y) \<rbrakk> \<Longrightarrow>
      Q (takeWhile P (X@Y) )"
using takeWhile_append1 takeWhile_append2 by metis

fun lastRemove :: "('a\<times>'a) \<Rightarrow>  ('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list" where
  "lastRemove (a,b) l = rev (takeWhile (\<lambda>(x,y). y \<noteq> b) (rev l))"
value "lastRemove (0::nat,1) [(0,1), (1::nat,2), (2,3), (3,2), (2,4), (4,5)]"
value "lastRemove (1::nat,2) [(1::nat,2), (2,3), (3,2), (2,4), (4,5), (5,6)]"
value "lastRemove (2::nat,3) [(2,3), (3,2), (2,4), (4,5)]"
value "lastRemove (2::nat,3) [(2,3), (3,2), (2,4), (4,5), (5,3), (3,6)]"
value "lastRemove (2::nat,1) [(2,1)]"
value "lastRemove (1::nat,2) [(4,5)]"
value "lastRemove (1::nat,1) [(1,1), (1,2), (2,2)]"
value "lastRemove (1::nat,1) [(1,1), (2,2)]"
lemma lastRemove_empty: "lastRemove c [] = []" by(cases c, simp)
lemma lastRemove_drop: "\<exists>n. lastRemove c l = drop n l"
  apply(induction l, simp_all)
  apply(simp add: lastRemove_empty)
  apply(cases c, clarsimp)
  apply(drule_tac f="rev" in HOL.arg_cong)
  apply(simp)
  apply(rename_tac h n)
  apply(case_tac "h = b")
  apply(simp_all add: List.takeWhile_tail)
  apply(rule_tac x="Suc n" in exI)
  apply(simp)
  apply(rule takeWhile_append_split)
  apply(simp_all)
  apply(rule_tac x="Suc n" in exI, simp)
  apply(rule_tac x="0" in exI)
  apply(simp)
  done

lemma lastRemove_length: "length (lastRemove c l) \<le> length l"
  using lastRemove_drop by (metis Nat.diff_le_self length_drop)
lemma lastRemove_set: "set (lastRemove c p) \<subseteq> set p"
  apply(induction p, simp_all add: lastRemove_empty)
  apply(cases c, clarsimp)
  by (metis prod.inject rev.simps(2) set_ConsD set_rev set_takeWhileD)

lemma "\<lbrakk>lastRemove (x,y) p \<noteq> []; pcas x p y\<rbrakk> \<Longrightarrow> y = fst (hd (lastRemove (x,y) p))"
  apply(induction p arbitrary: x y)
  apply(simp_all)
  apply(rule takeWhile_append_split)
  apply(simp_all)
  apply force

  oops
lemma "\<lbrakk>pcas z p y\<rbrakk> \<Longrightarrow> pcas x ((x,z)#(lastRemove (x,z) p)) y"
oops

lemma "\<lbrakk>pcas x p y\<rbrakk> \<Longrightarrow> (p = [] \<longrightarrow> pcas x (lastRemove c p) y) \<and> (p \<noteq> [] \<longrightarrow> pcas x ((hd p)#(lastRemove (hd p) p)) y)"
proof(induction p arbitrary: x y)
  case Nil thus ?case by(simp add: lastRemove_empty)
  next
  case (Cons a p)
  from lastRemove_drop obtain n where s: "(lastRemove a (a#p)) = drop n (a#p)" by blast
  from Cons show ?case
  apply(simp add: s)
  apply(case_tac "p=[]")
  apply(simp_all)
oops

lemma "\<forall> (x,y) \<in> set (lastRemove (a,b) l). b \<notin> snd `  set (lastRemove (a,b) l)"
  apply(simp) by (metis (lifting, mono_tags) in_snd_imageE set_takeWhileD split_conv)

(* [(1,2), (2,3), (3,2), (2,4)] \<longrightarrow> [(1,2), (2,4)] *)
function kreisentfernung :: "('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list" where
  "kreisentfernung [] = []" |
  "kreisentfernung (c#cs) = c#kreisentfernung (lastRemove c cs)"
by pat_completeness auto
termination sorry
value "kreisentfernung [(0,1), (1::nat,2), (2,3), (3,2), (2,4), (4,5)]"
value "kreisentfernung [(1::nat,2), (2,3), (3,2), (2,4), (4,4), (4,1), (1::nat,2), (2,3), (3,2), (2,4), (4,4)]"
value "kreisentfernung [(1::nat,2), (2,3), (3,2), (2,4), (4,5), (5,3)]"
value "kreisentfernung [(1::nat,2), (2,3), (3,2), (2,4), (4,5), (5,3), (3,1)]"
value "kreisentfernung [(1::nat,1), (2,1)]"
value "kreisentfernung [(2::nat,1)]"
value "kreisentfernung [(2::nat,3), (3,2), (2,4), (4,5), (5,3)]"

lemma "set (kreisentfernung (drop x p)) \<subseteq> set p"
  proof(induction p arbitrary: x)
  case Nil thus ?case by(simp add: lastRemove_empty)
  next
  case (Cons a p)
  assume Cons: "\<And>x. set (kreisentfernung (drop x p)) \<subseteq> set p"
  from lastRemove_drop obtain n where s: "lastRemove a p = drop n p" by blast
  from Cons have "set (kreisentfernung (drop n p)) \<subseteq> set p" by simp
  hence "set (kreisentfernung (lastRemove a p)) \<subseteq> insert a (set p)"
    by(simp add: s subset_insertI2)
  from this Cons show ?case
  by(case_tac x, auto)
qed
lemma "drop 0 l = l" by simp

lemma "pcas x p y \<Longrightarrow> pcas x (kreisentfernung p) y"
apply(induction p)
  apply(simp)
  apply(simp)
oops
value "pawalk_verts 1 [(1::nat,2), (2,3), (3,2), (2,4), (4,5), (5,3), (3,1)]"
lemma "pcas x p y \<Longrightarrow> distinct (tl (pawalk_verts x (kreisentfernung (filter (\<lambda>(x,y). x\<noteq>y) p))))"
nitpicks
oops
(*aber erstmal pcas zeigen*)

lemma "pcas x p y \<Longrightarrow> \<exists>p'. pcas x p' y \<and> set (pawalk_verts x p') \<subseteq> set (pawalk_verts x p) \<and> distinct (tl (pawalk_verts x p'))"
  apply(induction x p y rule: pcas.induct)
  apply(simp)
  apply(rule_tac x="[]" in exI)
  apply(simp)
  apply(simp)
  apply(erule_tac exE)
  apply(clarsimp)
  apply(case_tac "a = b")
  apply(rule_tac x="p'" in exI)
  apply(simp)
  using pcas_start_in_pawalkvert apply fast
  apply(case_tac "b \<notin> (set (pawalk_verts b p'))")
  apply(rule_tac x="(a,b)#p'" in exI)
  apply(simp)
  apply (metis pcas_start_in_pawalkvert)
  apply(rule_tac x="dropWhile (\<lambda>(x1,x2). x1 \<noteq> b) p'" in exI) (*TODO need to cut out circle ....*)
  apply(simp)
  nitpick
sorry (*TODOTODO*)

(*everything reachable from V'*)
lemma "{y. \<exists>x \<in> V'. (x,y) \<in> E\<^sup>*} = E\<^sup>*``V'" by blast

definition restrict_to :: "('v \<times> 'v) set \<Rightarrow> 'v set \<Rightarrow> ('v \<times> 'v) set" where
  "restrict_to E V \<equiv> {(a,b)\<in>E. a\<in>V \<and> b\<in>V}"

definition bi :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" where
  "bi E = E \<union> backflows E"

lemma bi_insert: "bi (insert (x,y) X) = {(x,y), (y,x)} \<union> bi X"
  by(auto simp add: bi_def backflows_def)
lemma bi_sym: "sym (bi X)"
  by(simp add: sym_def bi_def backflows_def)
lemma bi_union: "bi A \<union> bi B = bi (A \<union> B)"
  by(auto simp add: sym_def bi_def backflows_def)

definition uni_restrict_to :: "('v \<times> 'v) set \<Rightarrow> 'v set \<Rightarrow> ('v \<times> 'v) set" where
  "uni_restrict_to E V \<equiv> restrict_to (bi E) V"

lemma uni_restrict_to_mono: "D' \<subseteq> D \<Longrightarrow> uni_restrict_to E D' \<subseteq> uni_restrict_to E D"
  by(simp add: uni_restrict_to_def restrict_to_def, fast)

definition has_undirected_cycle_in :: "('a \<times> 'a) set \<Rightarrow> bool" where
  "has_undirected_cycle_in E \<equiv>
  \<exists> u \<in> nodes_of E. \<exists> p. set p \<subseteq> bi E \<and> pcas u p u \<and> distinct (tl (Pair_Digraph.pawalk_verts u p)) \<and> length p \<ge> 3"

definition cycles_dfs_imp_WHILE_invar :: "('v \<times> 'v) set \<Rightarrow> 'v \<Rightarrow> ('v\<times>'v) set \<times> ('v\<times>'v) set \<times> bool \<Rightarrow> bool" where
  "cycles_dfs_imp_WHILE_invar E v0 \<sigma> \<equiv> let (W,D,cycle) = \<sigma> in
        W \<subseteq> bi E \<and> D \<subseteq> bi E
        \<and> (\<forall> (a,_) \<in> W. \<exists> (_,d) \<in> D. (d,a) \<in> D)
        \<and> W \<inter> D = {}
        \<and> (\<forall> x\<in>snd`D. \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+)
        \<and> (cycle \<longrightarrow> has_undirected_cycle_in (D \<union> W))
        (*\<and> (\<forall> x\<in>Discovered. \<forall> y\<in>Discovered. x \<noteq> y \<longrightarrow>
            (\<exists> p. set p \<subseteq> uni_restrict_to E (Discovered) \<and> pcas x p y \<and> distinct (Pair_Digraph.pawalk_verts x p)))*)
        (*E\<^sup>*``(fst ` V') \<union> fst ` Discovered = E\<^sup>*``{v0} \<and> *)"

lemma "(\<forall> x\<in>snd`(bi D). \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+) \<Longrightarrow> (\<forall> x\<in>fst`D. \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+)"
  apply(clarsimp)
  apply(rename_tac a b x y)
  apply(erule_tac x="(b,a)" in ballE)
  apply(erule_tac x="(x,y)" in ballE)
  apply(simp_all)
  by(simp add: bi_def backflows_def)

lemma distinct_xyz_length: "distinct [x,y,z] \<Longrightarrow> x \<in> set X \<Longrightarrow> y \<in> set X \<Longrightarrow> z \<in> set X \<Longrightarrow> length X \<ge> 3"
by (smt distinct_length_2_or_more length_pos_if_in_set list.size(4) list_decomp_2 list_tail_coinc set_ConsD)

lemma assumes D_path: "(\<forall> x\<in>nodes_of D. \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+)" (*replace snd with nodes_of*)
    and ad2W: "(a, d2) \<in> W" and d1d2D: "(d1, d2) \<in> D"
    and WD_edge: "(\<forall> (a,_) \<in> W. \<exists> (_,d) \<in> D. (d,a) \<in> D)"
    and nreflW: "\<forall> (x,y) \<in> W. x \<noteq> y"
    (*and nreflD: "\<forall> (x,y) \<in> D. x \<noteq> y"*)
    and disjunct: "bi W \<inter> bi D = {}"
   shows "has_undirected_cycle_in (D \<union> {(a,d2)})"
   proof(unfold has_undirected_cycle_in_def)
    from ad2W WD_edge have "\<exists> (x,y) \<in> D. (y, a) \<in> D" by fast
    from this obtain y where yD: "(y, a) \<in> D" by blast
    have "a \<noteq> d2" using ad2W nreflW by blast
    have "y \<noteq> a" sorry (*does not hold, y might be v0*)
    from `y \<noteq> a` `a \<noteq> d2` disjunct ad2W yD have "y \<noteq> d2" by(simp add: bi_def backflows_def, blast)
    (* d2 \<longrightarrow> y \<longrightarrow> (y,a) \<longrightarrow> a,d2 <-- in W*) (*need d2 \<noteq> y*)
    (*from yD have "set [(y,a)] \<subseteq> bi D \<and> pcas y [(y,a)] a" by (auto simp: bi_def)*)
    from yD d1d2D D_path have "y \<noteq> d2 \<longrightarrow> (y, d2) \<in> (bi D)\<^sup>+"
      by(simp add: nodes_of_def, force)
    from this `y \<noteq> d2` have "(d2, y) \<in> (bi D)\<^sup>+" using bi_sym by (metis symD sym_trancl)
    from this pcas_iff_trancl[symmetric] `y \<noteq> d2` have "\<exists>p. set p \<subseteq> (bi D) \<and> pcas d2 p y" by metis
    from this obtain p where p: "set p \<subseteq> (bi D) \<and> pcas d2 p y" and pdist: "distinct (pawalk_verts d2 p)" sorry
    from pcas_distinct_len p `y \<noteq> d2` have plength: "length p \<ge> 1" by metis
    let ?pa = "p@[(y,a)]"
    from p yD have pa: "set ?pa \<subseteq> (bi D) \<and> pcas d2 ?pa a" by(simp add: bi_def pcas_append)
    have "pcas d2 p y \<Longrightarrow> pawalk_verts d2 (p @ [(y, a)]) = (pawalk_verts d2 p)@[a]"
      by(induction p arbitrary: d2, simp_all)
    from this p have pawalk_verts_simp: "pawalk_verts d2 (p @ [(y, a)]) = (pawalk_verts d2 p)@[a]" by simp
    have a_in_path_length: "a \<in> set (pawalk_verts d2 p) \<Longrightarrow> length p \<ge> 2"
    proof -
      assume 0: "a \<in> set (pawalk_verts d2 p)"
      from `y \<noteq> a` `a \<noteq> d2` `y \<noteq> d2` have 1: "distinct [d2, y, a]" by auto
      from p have 2: "d2 \<in> set (pawalk_verts d2 p)" by (metis pcas_start_in_pawalkvert)
      from p have 3: "y \<in> set (pawalk_verts d2 p)" using pcas_end_in_pawalkvert by metis
      from distinct_xyz_length 0 1 2 3 have "length (pawalk_verts d2 p) \<ge> 3" by fast
      from this pawalk_verts_length show "length p \<ge> 2" by (metis le_numeral_Suc pred_numeral_simps(3))
    qed
    from pdist have padist: "a \<notin> set (pawalk_verts d2 p) \<Longrightarrow> distinct (pawalk_verts d2 ?pa)"
      by(simp add: pawalk_verts_simp)
    (*if a in pa: let ?pa = p*)
    from plength have palength: "length ?pa \<ge> 2" by simp
    from ad2W have ad2biW: "(d2,a) \<in> bi W" by(simp add: bi_def backflows_def)
    hence "set [(a, d2)] \<subseteq> bi {(a,d2)} \<and> pcas a [(a, d2)] d2" by (simp add: bi_def)
    from this pa have 1: "set ((a, d2)#?pa) \<subseteq> bi {(a,d2)} \<union> bi D \<and> pcas a ((a, d2)#?pa) a" by auto
    from padist have 2: "distinct (tl (pawalk_verts a ((a, d2)#?pa)))" by simp

   show "\<exists>u\<in>nodes_of (D \<union> {(a, d2)}). \<exists>p. set p \<subseteq> bi (D \<union> {(a, d2)}) \<and> pcas u p u \<and> distinct (tl (pawalk_verts u p)) \<and> 3 \<le> length p"
    apply(case_tac "a \<notin> set (pawalk_verts d2 p)")
    apply(rule_tac x=a in bexI)
    apply(rule_tac x="(a, d2)#?pa" in exI)
    apply(rule conjI)
    using bi_union 1 apply blast
    apply(rule conjI)
    using 1 apply blast
    apply(rule conjI)
    using padist apply simp
    apply(simp add: plength[simplified])
    apply(simp add: nodes_of_def)
oops

lemma cycles_dfs_imp_WHILE_invar_step1:
  assumes "cycles_dfs_imp_WHILE_invar E v0 (W, Discovered, cycle)"
       "(a, snd (d1, d2)) \<in> W" "(d1, d2) \<in> Discovered" "W \<noteq> {}" "\<not> cycle"
  shows "cycles_dfs_imp_WHILE_invar E v0 (W, Discovered, True)"
  using assms unfolding cycles_dfs_imp_WHILE_invar_def
  apply(simp)
  (*a is snd`discovered \<longrightarrow> (d2,a) \<in> D^+ \<longrightarrow> need W disjunct D \<longrightarrow> path: d2,a + (a,d2)*)
  (*TODO*)
  apply(simp add: has_undirected_cycle_in_def)
  proof -
  show "\<exists>u\<in>nodes_of (Discovered \<union> W). \<exists>p. set p \<subseteq> bi (Discovered \<union> W) \<and> pcas u p u \<and> distinct (tl (pawalk_verts u p)) \<and> 3 \<le> length p"
oops

lemma nodes_of_backflows_snd: "nodes_of E = snd ` E \<union> snd ` (backflows E)"
    apply(simp add: nodes_of_def backflows_alt_fstsnd) by force
lemma nodes_of_subset_backflows_b: "v0 \<in> nodes_of E \<Longrightarrow> V \<subseteq> insert (v0,v0) (E \<union> backflows E) \<Longrightarrow> (a, b) \<in> V \<Longrightarrow> b \<in> nodes_of E"
    apply(simp add: nodes_of_backflows_snd) by force

lemma "y \<in> snd ` (V - {(a, b)} \<union> {b} \<times> ({v'. (b, v') \<in> E \<or> (v', b) \<in> E} - {a, b})) \<Longrightarrow>
         b \<noteq> y \<Longrightarrow>  y \<notin> snd ` V \<Longrightarrow> False" oops

lemma cycles_dfs_imp_WHILE_invar_step2:
  assumes "v0 \<in> nodes_of E" and "cycles_dfs_imp_WHILE_invar E v0 (W, Discovered, False)"
       "(w1, w2) \<in> W"
       "w2 \<notin> snd ` Discovered"
       "W \<noteq> {}"
       "\<not> cycle"
  shows "cycles_dfs_imp_WHILE_invar E v0 (W - {(w1, w2)} \<union> {w2} \<times> ({v'. (w2, v') \<in> E \<or> (v', w2) \<in> E} - {w1, w2}), insert (w1, w2) Discovered, False)"
  using assms unfolding cycles_dfs_imp_WHILE_invar_def
  apply(simp)
  apply(rule conjI)
  apply(auto)[1]
  apply(rule conjI)
  apply(auto simp add: bi_def backflows_def)[1]
  apply(rule conjI)
  apply(auto simp add: bi_def backflows_def)[1]
  apply(rule conjI)
  apply blast
  apply(rule conjI)
  nitpick (*dis*)
  apply(simp add: bi_insert)[1]
  apply(clarsimp)
  apply(erule_tac x="(w1,w2)" in ballE, simp)
  prefer 2 apply simp
  apply(erule bexE)
  apply(clarify)
  (*holds but needs proof ...*)
    using nodes_of_subset_backflows_b
oops

lemma cycles_dfs_imp_sound:
  fixes succ and v0
  assumes F: "finite E"
  shows "cycles_dfs_imp E v0 \<le> SPEC (\<lambda>r. r \<longleftrightarrow> has_undirected_cycle_in (uni_restrict_to E (E\<^sup>*``{v0})))"
proof -

  from F show ?thesis
    unfolding cycles_dfs_imp_def
    apply(intro WHILE_rule[where I="cycles_dfs_imp_WHILE_invar E v0"] refine_vcg)
    apply(auto simp add: cycles_dfs_imp_WHILE_invar_def restrict_to_def has_undirected_cycle_in_def nodes_of_def)[1]
    apply(clarify, rename_tac A W C V Discovered cycle I J a L d1 d2)
    apply(simp add: cycles_dfs_imp_WHILE_invar_step1)
    apply(clarsimp)
    apply(rename_tac W Discovered cycle w1 w2)
    apply(auto simp add: cycles_dfs_imp_WHILE_invar_def)[1]
    apply(simp add: cycles_dfs_imp_WHILE_invar_def)[1]
    apply(rule conjI)
    apply(auto)[1]
    apply(rule conjI)
    apply(auto)[1]
    apply(rule conjI)
    apply(auto)[1]
    apply clarify
    using v0 try0
    oops

(*no idea what's wrong here*)
definition cycles_dfs_recX :: "('a \<Rightarrow>'a set) \<Rightarrow> 'a \<Rightarrow> bool nres"
  where
  "cycles_dfs_recX succ v0 \<equiv> REC (\<lambda>D (V,v).
    if v \<in> V then RETURN True
    else do {
      let V=insert v V;
      FOREACH (succ v) (\<lambda>v' _. D (V,v')) False }
  ) ({},v0)"
lemma cycles_dfs_rec_sound:
  fixes succ and v0
  defines "E \<equiv> {(v,v'). v'\<in>succ v}"
  defines "V \<equiv> {v. (v0,v)\<in>E\<^sup>*}"
  assumes F: "finite V"
  shows "cycles_dfs_recX succ v0 \<le> SPEC (\<lambda>r. r \<longrightarrow> (\<forall>x\<in>V. (v0,x)\<in>E\<^sup>* \<longrightarrow> (x,x)\<notin>E\<^sup>+))"
proof -
  have S: "\<And>v. succ v = E``{v}"
    by (auto simp: E_def)

  from F show ?thesis
    unfolding cycles_dfs_recX_def S
    apply(intro REC_rule[where \<Phi>="\<lambda>(V',v'). (v0,v')\<in>E\<^sup>* \<and> V'\<subseteq>V \<and> (\<forall>x\<in>V'. (v0,x)\<in>E\<^sup>* \<longrightarrow> (x,x)\<notin>E\<^sup>+)"]
        FOREACH_rule[where I="\<lambda>Succs r. XXX"] refine_vcg) (*r \<longrightarrow> (\<forall>v\<in>V. (v0,v)\<in>E\<^sup>* \<longrightarrow> (v,v)\<notin>E\<^sup>+)*)
    apply(refine_mono) (*REC is somehow undocumented*)
    apply(simp)
    apply(simp_all)
    apply(rename_tac V' v')
    oops

fun fibdef :: "nat \<Rightarrow> nat" where
  "fibdef 0 = 1" |
  "fibdef (Suc 0) = 1" |
  "fibdef (Suc (Suc n)) = fibdef (Suc n) + fibdef n"
value "fibdef 4"

definition fibref :: "nat \<Rightarrow> nat nres"
  where
  "fibref n \<equiv> REC (\<lambda>D (n).
    if n = 0 then RETURN 1
    else if n = 1 then RETURN 1
    else do {
      x \<leftarrow> (D (n - 1));
      y \<leftarrow> (D (n - 2));
      RETURN (x + y)
      }
    ) (n)"

lemma fibref:
  shows "fibref n \<le> SPEC (\<lambda>r. r = fibdef n)"
proof -
  show ?thesis
    unfolding fibref_def
    apply (refine_rcg refine_vcg REC_rule[where \<Phi>="\<lambda>n. n \<ge> 0"])
    apply(simp_all)[3]
    apply(simp add: RETURN_def)
    apply(auto)
    oops

section{*TEST TEST TES TEST of UNIO*}
  lemma "UNION {1::nat,2,3} (\<lambda>n. {n+1}) = {2,3,4}" by eval
  lemma "(\<Union>n\<in>{1::nat, 2, 3}. {n + 1}) = {2, 3, 4}" by eval
  lemma "UNION {1::nat,2,3} (\<lambda>n. {n+1}) = set (map (\<lambda>n. n+1) [1,2,3])" by eval

(*
  locale X =
    fixes N1 N2
    assumes well_n1: "wellformed_network N1"
    assumes well_n2: "wellformed_network N2"
  begin
  end

  sublocale X \<subseteq> n1!: wellformed_network N1
    by (rule well_n1)
  sublocale X \<subseteq> n2!: wellformed_network N2
    by (rule well_n2)

    context X
    begin

    end
*)

end