(* Title:      Relative Modal Operators
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Relative Modal Operators\<close>

theory Relative_Modal

imports Relative_Domain

begin

class relative_diamond_semiring = relative_domain_semiring + diamond +
  assumes diamond_def: "|x>y = d(x * y)"
begin

lemma diamond_x_1:
  "|x>1 = d(x)"
  by (simp add: diamond_def)

lemma diamond_x_d:
  "|x>d(y) = d(x * y)"
  using d_mult_d diamond_def by auto

lemma diamond_x_und:
  "|x>d(y) = |x>y"
  using diamond_x_d diamond_def by auto

lemma diamond_d_closed:
  "|x>y = d( |x>y)"
  by (simp add: d_involutive diamond_def)

text \<open>Theorem 46.11\<close>

lemma diamond_bot_y:
  "|bot>y = bot"
  by (simp add: d_zero diamond_def)

lemma diamond_1_y:
  "|1>y = d(y)"
  by (simp add: diamond_def)

text \<open>Theorem 46.12\<close>

lemma diamond_1_d:
  "|1>d(y) = d(y)"
  by (simp add: diamond_1_y diamond_x_und)

text \<open>Theorem 46.10\<close>

lemma diamond_d_y:
  "|d(x)>y = d(x) * d(y)"
  by (simp add: d_export diamond_def)

text \<open>Theorem 46.11\<close>

lemma diamond_d_bot:
  "|d(x)>bot = bot"
  by (metis diamond_bot_y diamond_d_y d_commutative d_zero)

text \<open>Theorem 46.12\<close>

lemma diamond_d_1:
  "|d(x)>1 = d(x)"
  by (simp add: diamond_x_1 d_involutive)

lemma diamond_d_d:
  "|d(x)>d(y) = d(x) * d(y)"
  by (simp add: diamond_d_y diamond_x_und)

text \<open>Theorem 46.12\<close>

lemma diamond_d_d_same:
  "|d(x)>d(x) = d(x)"
  by (simp add: diamond_d_d d_idempotent)

text \<open>Theorem 46.2\<close>

lemma diamond_left_dist_sup:
  "|x \<squnion> y>z = |x>z \<squnion> |y>z"
  by (simp add: d_dist_sup diamond_def mult_right_dist_sup)

text \<open>Theorem 46.3\<close>

lemma diamond_right_sub_dist_sup:
  "|x>y \<squnion> |x>z \<le> |x>(y \<squnion> z)"
  by (metis d_dist_sup diamond_def le_iff_sup mult_left_sub_dist_sup)

text \<open>Theorem 46.4\<close>

lemma diamond_associative:
  "|x * y>z = |x>(y * z)"
  by (simp add: diamond_def mult_assoc)

text \<open>Theorem 46.4\<close>

lemma diamond_left_mult:
  "|x * y>z = |x>|y>z"
  using diamond_x_und diamond_def mult_assoc by auto

lemma diamond_right_mult:
  "|x>(y * z) = |x>|y>z"
  using diamond_associative diamond_left_mult by auto

text \<open>Theorem 46.6\<close>

lemma diamond_d_export:
  "|d(x) * y>z = d(x) * |y>z"
  using diamond_d_y diamond_def mult_assoc by auto

lemma diamond_diamond_export:
  "||x>y>z = |x>y * |z>1"
  using diamond_d_y diamond_def by force

text \<open>Theorem 46.1\<close>

lemma diamond_left_isotone:
  "x \<le> y \<Longrightarrow> |x>z \<le> |y>z"
  by (metis diamond_left_dist_sup le_iff_sup)

text \<open>Theorem 46.1\<close>

lemma diamond_right_isotone:
  "y \<le> z \<Longrightarrow> |x>y \<le> |x>z"
  by (metis diamond_right_sub_dist_sup le_iff_sup le_sup_iff)

lemma diamond_isotone:
  "w \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> |w>x \<le> |y>z"
  by (meson diamond_left_isotone diamond_right_isotone order_trans)

lemma diamond_left_upper_bound:
  "|x>y \<le> |x \<squnion> z>y"
  by (simp add: diamond_left_isotone)

lemma diamond_right_upper_bound:
  "|x>y \<le> |x>(y \<squnion> z)"
  by (simp add: diamond_right_isotone)

lemma diamond_lower_bound_right:
  "|x>(d(y) * d(z)) \<le> |x>d(y)"
  by (simp add: diamond_right_isotone d_mult_left_lower_bound)

lemma diamond_lower_bound_left:
  "|x>(d(y) * d(z)) \<le> |x>d(z)"
  using diamond_lower_bound_right d_commutative by force

text \<open>Theorem 46.5\<close>

lemma diamond_right_sub_dist_mult:
  "|x>(d(y) * d(z)) \<le> |x>d(y) * |x>d(z)"
  using diamond_lower_bound_left diamond_lower_bound_right d_mult_greatest_lower_bound diamond_def by force

text \<open>Theorem 46.13\<close>

lemma diamond_demodalisation_1:
  "d(x) * |y>z \<le> Z \<longleftrightarrow> d(x) * y * d(z) \<le> Z"
  by (metis d_weak_locality diamond_def mult_assoc)

text \<open>Theorem 46.14\<close>

lemma diamond_demodalisation_3:
  "|x>y \<le> d(z) \<longleftrightarrow> x * d(y) \<le> d(z) * x \<squnion> Z"
  apply (rule iffI)
  apply (smt (verit) sup_commute sup_right_isotone d_below_one d_restrict diamond_def diamond_x_und mult_left_isotone mult_right_isotone mult_1_right order_trans)
  by (smt sup_commute sup_bot_left d_Z d_commutative d_dist_sup d_involutive d_mult_sub d_plus_left_upper_bound diamond_d_y diamond_def diamond_x_und le_iff_sup order_trans)

text \<open>Theorem 46.6\<close>

lemma diamond_d_export_2:
  "|d(x) * y>z = d(x) * |d(x) * y>z"
  by (metis diamond_d_export diamond_left_mult d_idempotent)

text \<open>Theorem 46.7\<close>

lemma diamond_d_promote:
  "|x * d(y)>z = |x * d(y)>(d(y) * z)"
  by (metis d_idempotent diamond_def mult_assoc)

text \<open>Theorem 46.8\<close>

lemma diamond_d_import_iff:
  "d(x) \<le> |y>z \<longleftrightarrow> d(x) \<le> |d(x) * y>z"
  by (metis diamond_d_export diamond_d_y d_order diamond_def order.eq_iff)

text \<open>Theorem 46.9\<close>

lemma diamond_d_import_iff_2:
  "d(x) * d(y) \<le> |z>w \<longleftrightarrow> d(x) * d(y) \<le> |d(y) * z>w"
  apply (rule iffI)
  apply (metis diamond_associative d_export d_mult_greatest_lower_bound diamond_def order.refl)
  by (metis diamond_d_y d_mult_greatest_lower_bound diamond_def mult_assoc)

end

class relative_box_semiring = relative_diamond_semiring + relative_antidomain_semiring + box +
  assumes box_def: "|x]y = a(x * a(y))"
begin

text \<open>Theorem 47.1\<close>

lemma box_diamond:
  "|x]y = a( |x>a(y))"
  by (simp add: box_def d_a_closed diamond_def)

text \<open>Theorem 47.2\<close>

lemma diamond_box:
  "|x>y = a( |x]a(y))"
  using box_def d_def d_mult_d diamond_def by auto

lemma box_x_bot:
  "|x]bot = a(x)"
  by (metis box_def mult_1_right one_def)

lemma box_x_1:
  "|x]1 = a(x * bot)"
  by (simp add: box_def)

lemma box_x_d:
  "|x]d(y) = a(x * a(y))"
  by (simp add: box_def d_a_closed)

lemma box_x_und:
  "|x]d(y) = |x]y"
  by (simp add: box_diamond d_a_closed)

lemma box_x_a:
  "|x]a(y) = a(x * y)"
  using a_mult_d box_def by auto

text \<open>Theorem 47.15\<close>

lemma box_bot_y:
  "|bot]y = 1"
  using box_def by auto

lemma box_1_y:
  "|1]y = d(y)"
  by (simp add: box_def d_def)

text \<open>Theorem 47.16\<close>

lemma box_1_d:
  "|1]d(y) = d(y)"
  by (simp add: box_1_y box_x_und)

lemma box_1_a:
  "|1]a(y) = a(y)"
  by (simp add: box_x_a)

lemma box_d_y:
  "|d(x)]y = a(x) \<squnion> d(y)"
  using a_export_a box_def d_def by auto

lemma box_a_y:
  "|a(x)]y = d(x) \<squnion> d(y)"
  by (simp add: a_mult_deMorgan_1 box_def)

text \<open>Theorem 47.14\<close>

lemma box_d_bot:
  "|d(x)]bot = a(x)"
  by (simp add: box_x_bot d_a_closed)

lemma box_a_bot:
  "|a(x)]bot = d(x)"
  by (simp add: box_x_bot d_def)

text \<open>Theorem 47.15\<close>

lemma box_d_1:
  "|d(x)]1 = 1"
  by (simp add: box_d_y d_one_one)

lemma box_a_1:
  "|a(x)]1 = 1"
  by (simp add: box_x_1)

text \<open>Theorem 47.13\<close>

lemma box_d_d:
  "|d(x)]d(y) = a(x) \<squnion> d(y)"
  by (simp add: box_d_y box_x_und)

lemma box_a_d:
  "|a(x)]d(y) = d(x) \<squnion> d(y)"
  by (simp add: box_a_y box_x_und)

lemma box_d_a:
  "|d(x)]a(y) = a(x) \<squnion> a(y)"
  by (simp add: box_x_a a_export_d)

lemma box_a_a:
  "|a(x)]a(y) = d(x) \<squnion> a(y)"
  by (simp add: box_a_y a_d_closed)

text \<open>Theorem 47.15\<close>

lemma box_d_d_same:
  "|d(x)]d(x) = 1"
  using box_x_d d_complement_zero by auto

lemma box_a_a_same:
  "|a(x)]a(x) = 1"
  by (simp add: box_def)

text \<open>Theorem 47.16\<close>

lemma box_d_below_box:
  "d(x) \<le> |d(y)]d(x)"
  by (simp add: box_d_d)

lemma box_d_closed:
  "|x]y = d( |x]y)"
  by (simp add: a_d_closed box_def)

lemma box_deMorgan_1:
  "a( |x]y) = |x>a(y)"
  by (simp add: diamond_box box_def)

lemma box_deMorgan_2:
  "a( |x>y) = |x]a(y)"
  using box_x_a d_a_closed diamond_def by auto

text \<open>Theorem 47.5\<close>

lemma box_left_dist_sup:
  "|x \<squnion> y]z = |x]z * |y]z"
  by (simp add: a_dist_sup box_def mult_right_dist_sup)

lemma box_right_dist_sup:
  "|x](y \<squnion> z) = a(x * a(y) * a(z))"
  by (simp add: a_dist_sup box_def mult_assoc)

lemma box_associative:
  "|x * y]z = a(x * y * a(z))"
  by (simp add: box_def)

text \<open>Theorem 47.6\<close>

lemma box_left_mult:
  "|x * y]z = |x]|y]z"
  using box_x_a box_def mult_assoc by force

lemma box_right_mult:
  "|x](y * z) = a(x * a(y * z))"
  by (simp add: box_def)

text \<open>Theorem 47.7\<close>

lemma box_right_submult_d_d:
  "|x](d(y) * d(z)) \<le> |x]d(y) * |x]d(z)"
  by (smt a_antitone a_dist_sup a_export_d box_diamond d_a_closed diamond_def mult_left_sub_dist_sup)

lemma box_right_submult_a_d:
  "|x](a(y) * d(z)) \<le> |x]a(y) * |x]d(z)"
  by (metis box_right_submult_d_d a_d_closed)

lemma box_right_submult_d_a:
  "|x](d(y) * a(z)) \<le> |x]d(y) * |x]a(z)"
  using box_right_submult_a_d box_x_a d_def tests_dual.sub_commutative by auto

lemma box_right_submult_a_a:
  "|x](a(y) * a(z)) \<le> |x]a(y) * |x]a(z)"
  by (metis box_right_submult_d_d a_d_closed)

text \<open>Theorem 47.8\<close>

lemma box_d_export:
  "|d(x) * y]z = a(x) \<squnion> |y]z"
  by (simp add: a_export_d box_def mult_assoc)

lemma box_a_export:
  "|a(x) * y]z = d(x) \<squnion> |y]z"
  using box_a_y box_d_closed box_left_mult by auto

text \<open>Theorem 47.4\<close>

lemma box_left_antitone:
  "y \<le> x \<Longrightarrow> |x]z \<le> |y]z"
  by (metis a_antitone box_def mult_left_isotone)

text \<open>Theorem 47.3\<close>

lemma box_right_isotone:
  "y \<le> z \<Longrightarrow> |x]y \<le> |x]z"
  by (metis a_antitone box_def mult_right_isotone)

lemma box_antitone_isotone:
  "y \<le> w \<Longrightarrow> x \<le> z \<Longrightarrow> |w]x \<le> |y]z"
  by (meson box_left_antitone box_right_isotone order_trans)

lemma diamond_1_a:
  "|1>a(y) = a(y)"
  by (simp add: d_def diamond_1_y)

lemma diamond_a_y:
  "|a(x)>y = a(x) * d(y)"
  by (metis a_d_closed diamond_d_y)

lemma diamond_a_bot:
  "|a(x)>bot = bot"
  by (simp add: diamond_a_y d_zero)

lemma diamond_a_1:
  "|a(x)>1 = a(x)"
  by (simp add: d_def diamond_x_1)

lemma diamond_a_d:
  "|a(x)>d(y) = a(x) * d(y)"
  by (simp add: diamond_a_y diamond_x_und)

lemma diamond_d_a:
  "|d(x)>a(y) = d(x) * a(y)"
  by (simp add: a_d_closed diamond_d_y)

lemma diamond_a_a:
  "|a(x)>a(y) = a(x) * a(y)"
  by (simp add: a_mult_closed diamond_def)

lemma diamond_a_a_same:
  "|a(x)>a(x) = a(x)"
  by (simp add: diamond_a_a)

lemma diamond_a_export:
  "|a(x) * y>z = a(x) * |y>z"
  using diamond_a_y diamond_associative diamond_def by auto

lemma a_box_a_a:
  "a(p) * |a(p)]a(q) = a(p) * a(q)"
  using box_a_a box_a_bot box_x_bot tests_dual.sup_complement_intro by auto

lemma box_left_lower_bound:
  "|x \<squnion> y]z \<le> |x]z"
  by (simp add: box_left_antitone)

lemma box_right_upper_bound:
  "|x]y \<le> |x](y \<squnion> z)"
  by (simp add: box_right_isotone)

lemma box_lower_bound_right:
  "|x](d(y) * d(z)) \<le> |x]d(y)"
  by (simp add: box_right_isotone d_mult_left_lower_bound)

lemma box_lower_bound_left:
  "|x](d(y) * d(z)) \<le> |x]d(z)"
  by (simp add: box_right_isotone d_restrict_iff_1)

text \<open>Theorem 47.9\<close>

lemma box_d_import:
  "d(x) * |y]z = d(x) * |d(x) * y]z"
  using a_box_a_a box_left_mult box_def d_def by force

text \<open>Theorem 47.10\<close>

lemma box_d_promote:
  "|x * d(y)]z = |x * d(y)](d(y) * z)"
  using a_box_a_a box_x_a box_def d_def mult_assoc by auto

text \<open>Theorem 47.11\<close>

lemma box_d_import_iff:
  "d(x) \<le> |y]z \<longleftrightarrow> d(x) \<le> |d(x) * y]z"
  using box_d_export box_def d_def tests_dual.shunting by auto

text \<open>Theorem 47.12\<close>

lemma box_d_import_iff_2:
  "d(x) * d(y) \<le> |z]w \<longleftrightarrow> d(x) * d(y) \<le> |d(y) * z]w"
  apply (rule iffI)
  using box_d_export le_supI2 apply simp
  by (metis box_d_import d_commutative d_restrict_iff_1)

text \<open>Theorem 47.20\<close>

lemma box_demodalisation_2:
  "-p \<le> |y](-q) \<longleftrightarrow> -p * y * --q \<le> Z"
  by (simp add: a_greatest_left_absorber box_def mult_assoc)

lemma box_right_sub_dist_sup:
  "|x]d(y) \<squnion> |x]d(z) \<le> |x](d(y) \<squnion> d(z))"
  by (simp add: box_right_isotone)

lemma box_diff_var:
  "|x](d(y) \<squnion> a(z)) * |x]d(z) \<le> |x]d(z)"
  by (simp add: box_right_dist_sup box_x_d tests_dual.upper_bound_right)

text \<open>Theorem 47.19\<close>

lemma diamond_demodalisation_2:
  "|x>y \<le> d(z) \<longleftrightarrow> a(z) * x * d(y) \<le> Z"
  using a_antitone a_greatest_left_absorber a_mult_d d_def diamond_def mult_assoc by fastforce

text \<open>Theorem 47.17\<close>

lemma box_below_Z:
  "( |x]y) * x * a(y) \<le> Z"
  by (simp add: a_restrict box_def mult_assoc)

text \<open>Theorem 47.18\<close>

lemma box_partial_correctness:
  "|x]1 = 1 \<longleftrightarrow> x * bot \<le> Z"
  by (simp add: box_x_1 a_strict)

lemma diamond_split:
  "|x>y = d(z) * |x>y \<squnion> a(z) * |x>y"
  by (metis d_def diamond_def sup_monoid.add_commute tests_dual.sba_dual.sup_cases tests_dual.sub_commutative)

lemma box_import_shunting:
  "-p * -q \<le> |x](-r) \<longleftrightarrow> -q \<le> |-p * x](-r)"
  by (smt box_demodalisation_2 mult_assoc sub_comm sub_mult_closed)

proposition box_dist_mult: "|x](d(y) * d(z)) = |x](d(y)) * |x](d(z))" nitpick [expect=genuine,card=6] oops
proposition box_demodalisation_3: "d(x) \<le> |y]d(z) \<longrightarrow> d(x) * y \<le> y * d(z) \<squnion> Z" nitpick [expect=genuine,card=6] oops
proposition fbox_diff: "|x](d(y) \<squnion> a(z)) \<le> |x]y \<squnion> a( |x]z)" nitpick [expect=genuine,card=6] oops
proposition diamond_diff: "|x>y * a( |x>z) \<le> |x>(d(y) * a(z))" nitpick [expect=genuine,card=6] oops
proposition diamond_diff_var: "|x>d(y) \<le> |x>(d(y) * a(z)) \<squnion> |x>d(z)" nitpick [expect=genuine,card=6] oops

end

class relative_left_zero_diamond_semiring = relative_diamond_semiring + relative_domain_semiring + idempotent_left_zero_semiring
begin

lemma diamond_right_dist_sup:
  "|x>(y \<squnion> z) = |x>y \<squnion> |x>z"
  by (simp add: d_dist_sup diamond_def mult_left_dist_sup)

end

class relative_left_zero_box_semiring = relative_box_semiring + relative_left_zero_antidomain_semiring
begin

subclass relative_left_zero_diamond_semiring ..

lemma box_right_mult_d_d:
  "|x](d(y) * d(z)) = |x]d(y) * |x]d(z)"
  using a_dist_sup box_d_a box_def d_def mult_left_dist_sup by auto

lemma box_right_mult_a_d:
  "|x](a(y) * d(z)) = |x]a(y) * |x]d(z)"
  by (metis box_right_mult_d_d a_d_closed)

lemma box_right_mult_d_a:
  "|x](d(y) * a(z)) = |x]d(y) * |x]a(z)"
  using box_right_mult_a_d box_def box_x_a d_def by auto

lemma box_right_mult_a_a:
  "|x](a(y) * a(z)) = |x]a(y) * |x]a(z)"
  using a_dist_sup box_def mult_left_dist_sup tests_dual.sub_sup_demorgan by force

lemma box_demodalisation_3:
  assumes "d(x) \<le> |y]d(z)"
    shows "d(x) * y \<le> y * d(z) \<squnion> Z"
proof -
  have "d(x) * y * a(z) \<le> Z"
    using assms a_greatest_left_absorber box_x_d d_def mult_assoc by auto
  thus ?thesis
    by (simp add: a_a_below case_split_right_sup d_def sup_commute mult_assoc)
qed

lemma fbox_diff:
  "|x](d(y) \<squnion> a(z)) \<le> |x]y \<squnion> a( |x]z)"
  by (smt (z3) a_compl_intro a_dist_sup a_mult_d a_plus_left_lower_bound sup_commute box_def d_def mult_left_dist_sup tests_dual.sba_dual.shunting)

lemma diamond_diff_var:
  "|x>d(y) \<le> |x>(d(y) * a(z)) \<squnion> |x>d(z)"
  by (metis d_cancellation_1 diamond_right_dist_sup diamond_right_isotone sup_commute)

lemma diamond_diff:
  "|x>y * a( |x>z) \<le> |x>(d(y) * a(z))"
  by (metis d_a_shunting d_involutive diamond_def diamond_diff_var diamond_x_und)

end

end


(*
  File: Union_Find_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of union find\<close>

theory Union_Find_Impl
  imports SepAuto "../Functional/Union_Find"
begin

text \<open>
  Development follows theory Union\_Find in
  \cite{Separation_Logic_Imperative_HOL-AFP} by Lammich and Meis.
\<close>

type_synonym uf = "nat array \<times> nat array"

definition is_uf :: "nat \<Rightarrow> (nat\<times>nat) set \<Rightarrow> uf \<Rightarrow> assn" where [rewrite_ent]:
  "is_uf n R u = (\<exists>\<^sub>Al szl. snd u \<mapsto>\<^sub>a l * fst u \<mapsto>\<^sub>a szl *
        \<up>(ufa_invar l) * \<up>(ufa_\<alpha> l = R) * \<up>(length l = n) * \<up>(length szl = n))"

definition uf_init :: "nat \<Rightarrow> uf Heap" where
  "uf_init n = do {
     l \<leftarrow> Array.of_list [0..<n];
     szl \<leftarrow> Array.new n (1::nat);
     return (szl, l)
   }"

text \<open>Correctness of uf\_init.\<close>
theorem uf_init_rule [hoare_triple]:
  "<emp> uf_init n <is_uf n (uf_init_rel n)>" by auto2

partial_function (heap) uf_rep_of :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap" where
  "uf_rep_of p i = do {
     n \<leftarrow> Array.nth p i;
     if n = i then return i else uf_rep_of p n
   }"

lemma uf_rep_of_rule [hoare_triple]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow>
   <p \<mapsto>\<^sub>a l>
   uf_rep_of p i
   <\<lambda>r. p \<mapsto>\<^sub>a l * \<up>(r = rep_of l i)>"
@proof @prop_induct "ufa_invar l \<and> i < length l" @qed

partial_function (heap) uf_compress :: "nat \<Rightarrow> nat \<Rightarrow> nat array \<Rightarrow> unit Heap" where
  "uf_compress i ci p = (
    if i = ci then return ()
    else do {
      ni \<leftarrow> Array.nth p i;
      uf_compress ni ci p;
      Array.upd i ci p;
      return ()
    })"

lemma uf_compress_rule [hoare_triple]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow>
   <p \<mapsto>\<^sub>a l>
    uf_compress i (rep_of l i) p
   <\<lambda>_. \<exists>\<^sub>Al'. p \<mapsto>\<^sub>a l' * \<up>(ufa_invar l' \<and> length l' = length l \<and>
              (\<forall>i<length l. rep_of l' i = rep_of l i))>"
@proof @prop_induct "ufa_invar l \<and> i < length l" @qed

definition uf_rep_of_c :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap" where
  "uf_rep_of_c p i = do {
    ci \<leftarrow> uf_rep_of p i;
    uf_compress i ci p;
    return ci
  }"

lemma uf_rep_of_c_rule [hoare_triple]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow>
   <p \<mapsto>\<^sub>a l>
   uf_rep_of_c p i
   <\<lambda>r. \<exists>\<^sub>Al'. p \<mapsto>\<^sub>a l' * \<up>(r = rep_of l i \<and> ufa_invar l' \<and> length l' = length l \<and>
                          (\<forall>i<length l. rep_of l' i = rep_of l i))>"
  by auto2

definition uf_cmp :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool Heap" where
  "uf_cmp u i j = do {
    n \<leftarrow> Array.len (snd u);
    if (i\<ge>n \<or> j\<ge>n) then return False
    else do {
      ci \<leftarrow> uf_rep_of_c (snd u) i;
      cj \<leftarrow> uf_rep_of_c (snd u) j;
      return (ci = cj)
    }
  }"

text \<open>Correctness of compare.\<close>
theorem uf_cmp_rule [hoare_triple]:
  "<is_uf n R u>
   uf_cmp u i j
   <\<lambda>r. is_uf n R u * \<up>(r \<longleftrightarrow> (i,j)\<in>R)>" by auto2

definition uf_union :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> uf Heap" where
  "uf_union u i j = do {
    ci \<leftarrow> uf_rep_of (snd u) i;
    cj \<leftarrow> uf_rep_of (snd u) j;
    if (ci = cj) then return u
    else do {
      si \<leftarrow> Array.nth (fst u) ci;
      sj \<leftarrow> Array.nth (fst u) cj;
      if si < sj then do {
        Array.upd ci cj (snd u);
        Array.upd cj (si+sj) (fst u);
        return u
      } else do {
        Array.upd cj ci (snd u);
        Array.upd ci (si+sj) (fst u);
        return u
      }
    }
  }"

text \<open>Correctness of union.\<close>
theorem uf_union_rule [hoare_triple]:
  "i < n \<Longrightarrow> j < n \<Longrightarrow>
   <is_uf n R u>
   uf_union u i j
   <is_uf n (per_union R i j)>" by auto2

setup \<open>del_prfstep_thm @{thm is_uf_def}\<close>

end


(*  Title:      WordInterval.thy
    Authors:    Julius Michaelis, Cornelius Diekmann
*)
theory WordInterval
imports Main
  Word_Next
  "~~/src/HOL/Word/Word"
begin

section\<open>WordInterval: Executable datatype for Machine Word Sets\<close>
text\<open>Stores ranges of machine words as interval. This has been proven quite efficient for
     IP Addresses.\<close>
(*NOTE: All algorithms here use a straight-forward implementation. There is a lot of room for
        improving the computation complexity, for example by making the WordInterval a balanced,
        sorted tree.*)

subsection\<open>Syntax\<close>
context
  notes [[typedef_overloaded]]
begin
  datatype ('a::len0) wordinterval = WordInterval
                                        "('a::len0) word" --"start (inclusive)"
                                        "('a::len0) word" --"end (inclusive)"
                                  | RangeUnion "'a wordinterval" "'a wordinterval"
end

subsection\<open>Semantics\<close>
  fun wordinterval_to_set :: "'a::len0 wordinterval \<Rightarrow> ('a::len0 word) set"
  where
    "wordinterval_to_set (WordInterval start end) =
        {start .. end}" |
    "wordinterval_to_set (RangeUnion r1 r2) =
        wordinterval_to_set r1 \<union> wordinterval_to_set r2"

(*Note: The runtime of all the operations could be improved, for example by keeping the tree sorted
  and balanced.*)

subsection\<open>Basic operations\<close>
  text\<open>@{text \<in>}\<close>
  fun wordinterval_element :: "'a::len0 word \<Rightarrow> 'a::len0 wordinterval \<Rightarrow> bool" where
    "wordinterval_element el (WordInterval s e) \<longleftrightarrow> s \<le> el \<and> el \<le> e" |
    "wordinterval_element el (RangeUnion r1 r2) \<longleftrightarrow>
                                            wordinterval_element el r1 \<or> wordinterval_element el r2"
  lemma wordinterval_element_set_eq[simp]:
    "wordinterval_element el rg = (el \<in> wordinterval_to_set rg)"
    by(induction rg rule: wordinterval_element.induct) simp_all

  definition wordinterval_union
    :: "'a::len0 wordinterval \<Rightarrow> 'a::len0 wordinterval \<Rightarrow> 'a::len0 wordinterval" where
    "wordinterval_union r1 r2 = RangeUnion r1 r2"

subsection\<open>WordInterval and Lists\<close>
  text\<open>A list of @{text "(start, end)"} tuples.\<close>

  text\<open>wordinterval to list\<close>
  fun wi2l :: "'a::len0 wordinterval \<Rightarrow> ('a::len0 word \<times> 'a::len0 word) list" where
    "wi2l (RangeUnion r1 r2) = wi2l r1 @ wi2l r2" |
    "wi2l (WordInterval s e) = (if e < s then [] else [(s,e)])"

  text\<open>list to wordinterval\<close>
  fun l2wi :: "('a::len word \<times> 'a word) list \<Rightarrow> 'a wordinterval" where
    "l2wi [] = Empty_WordInterval" |
    "l2wi [(s,e)] = (WordInterval s e)" |
    "l2wi ((s,e)#rs) = (RangeUnion (WordInterval s e) (l2wi rs))"

  lemma l2wi_append: "wordinterval_to_set (l2wi (l1@l2)) =
                      wordinterval_to_set (l2wi l1) \<union> wordinterval_to_set (l2wi l2)"
    proof(induction l1 arbitrary: l2 rule:l2wi.induct)
    case 1 thus ?case by simp
    next
    case (2 s e l2) thus ?case by (cases l2) simp_all
    next
    case 3 thus ?case by force
    qed

  lemma l2wi_wi2l: "wordinterval_to_set (l2wi (wi2l r)) = wordinterval_to_set r"
    by(induction r) (simp_all add: l2wi_append)

  lemma l2wi: "wordinterval_to_set (l2wi l) = (\<Union> (i,j) \<in> set l. {i .. j})"
    by(induction l rule: l2wi.induct, simp_all)

  lemma wi2l: "(\<Union>(i,j)\<in>set (wi2l r). {i .. j}) = wordinterval_to_set r"
    by(induction r rule: wi2l.induct, simp_all)

  lemma l2wi_remdups: "wordinterval_to_set (l2wi (remdups ls)) = wordinterval_to_set (l2wi ls)"
    by(simp add: l2wi)

subsection\<open>Optimizing and minimizing @{typ "('a::len) wordinterval"}s\<close>
text\<open>Removing empty intervals\<close>
context
begin
  fun wordinterval_optimize_empty :: "'a::len0 wordinterval \<Rightarrow> 'a wordinterval" where
    "wordinterval_optimize_empty (RangeUnion r1 r2) = (let r1o = wordinterval_optimize_empty r1;
                                                           r2o = wordinterval_optimize_empty r2
      in if
        wordinterval_empty r1o
      then
        r2o
      else if
        wordinterval_empty r2o
      then
        r1o
      else
        RangeUnion r1o r2o)" |
    "wordinterval_optimize_empty r = r"
  lemma wordinterval_optimize_empty_set_eq[simp]:
    "wordinterval_to_set (wordinterval_optimize_empty r) = wordinterval_to_set r"
    by(induction r) (simp_all add: Let_def)

  lemma wordinterval_optimize_empty_double:
    "wordinterval_optimize_empty (wordinterval_optimize_empty r) = wordinterval_optimize_empty r"
    by(induction r) (simp_all add: Let_def)

  private fun wordinterval_empty_shallow :: "'a::len0 wordinterval \<Rightarrow> bool"  where
    "wordinterval_empty_shallow (WordInterval s e) \<longleftrightarrow> e < s" |
    "wordinterval_empty_shallow (RangeUnion _ _) \<longleftrightarrow> False"
  private lemma helper_optimize_shallow:
    "wordinterval_empty_shallow (wordinterval_optimize_empty r) =
      wordinterval_empty (wordinterval_optimize_empty r)"
    by(induction r) fastforce+
  private fun wordinterval_optimize_empty2 where
    "wordinterval_optimize_empty2 (RangeUnion r1 r2) = (let r1o = wordinterval_optimize_empty r1;
                                                            r2o = wordinterval_optimize_empty r2
      in if
        wordinterval_empty_shallow r1o
      then
        r2o
      else if
        wordinterval_empty_shallow r2o
      then
        r1o
      else
        RangeUnion r1o r2o)" |
    "wordinterval_optimize_empty2 r = r"
  lemma wordinterval_optimize_empty_code[code_unfold]:
    "wordinterval_optimize_empty = wordinterval_optimize_empty2"
    by (subst fun_eq_iff, clarify, rename_tac r, induct_tac r)
       (unfold wordinterval_optimize_empty.simps wordinterval_optimize_empty2.simps
               Let_def helper_optimize_shallow, simp_all)
end

text\<open>Merging overlapping intervals\<close>
context
begin

  private definition disjoint :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
    "disjoint A B \<equiv> A \<inter> B = {}"

  private primrec interval_of :: "('a::len0) word \<times> 'a word \<Rightarrow> 'a word set" where
    "interval_of (s,e) = {s .. e}"
  declare interval_of.simps[simp del]

  private definition disjoint_intervals
    :: "(('a::len0) word \<times> ('a::len0) word) \<Rightarrow> ('a word \<times> 'a word) \<Rightarrow> bool"
  where
    "disjoint_intervals A B \<equiv> disjoint (interval_of A) (interval_of B)"

  private definition not_disjoint_intervals
    :: "(('a::len0) word \<times> ('a::len0) word) \<Rightarrow> ('a word \<times> 'a word) \<Rightarrow> bool"
  where
    "not_disjoint_intervals A B \<equiv> \<not> disjoint (interval_of A) (interval_of B)"

  private

  private lemma [code]:
    "disjoint_intervals A B =
      (case A of (s,e) \<Rightarrow> case B of (s',e') \<Rightarrow> s > e' \<or> s' > e \<or> s > e \<or> s' > e')"
    apply(cases A, cases B)
    apply(simp add: disjoint_intervals_def interval_of.simps disjoint_def)
    by fastforce

  text\<open>BEGIN merging overlapping intervals\<close>
  (*result has no empty intervals and all are disjoint.
    merging things such as [1,7] [8,10] would still be possible*)
  private fun merge_overlap
    :: "(('a::len0) word \<times> ('a::len0) word) \<Rightarrow> ('a word \<times> 'a word) list \<Rightarrow> ('a word \<times> 'a word) list"
  where
    "merge_overlap s [] = [s]" |
    "merge_overlap (s,e) ((s',e')#ss) = (
       if not_disjoint_intervals (s,e) (s',e')
       then (min s s', max e e')#ss
       else (s',e')#merge_overlap (s,e) ss)"

  private lemma not_disjoint_union:
      fixes s :: "('a::len0) word"
      shows "\<not> disjoint {s..e} {s'..e'} \<Longrightarrow> {s..e} \<union> {s'..e'} = {min s s' .. max e e'}"
    by(auto simp add: disjoint_def min_def max_def)

  private lemma disjoint_subset: "disjoint A B \<Longrightarrow> A \<subseteq> B \<union> C \<Longrightarrow> A \<subseteq> C"
    unfolding disjoint_def
    by blast

  private lemma merge_overlap_helper1: "interval_of A \<subseteq> (\<Union>s \<in> set ss. interval_of s) \<Longrightarrow>
      (\<Union>s \<in> set (merge_overlap A ss). interval_of s) = (\<Union>s \<in> set ss. interval_of s)"
    apply(induction ss)
     apply(simp; fail)
    apply(rename_tac x xs)
    apply(cases A, rename_tac a b)
    apply(case_tac x)
    apply(simp add: not_disjoint_intervals_def interval_of.simps)
    apply(intro impI conjI)
     apply(drule not_disjoint_union)
     apply blast
    apply(drule_tac C="(\<Union>x\<in>set xs. interval_of x)" in disjoint_subset)
     apply(simp_all)
    done

  private lemma merge_overlap_helper2: "\<exists>s'\<in>set ss. \<not> disjoint (interval_of A) (interval_of s') \<Longrightarrow>
          interval_of A \<union> (\<Union>s \<in> set ss. interval_of s) = (\<Union>s \<in> set (merge_overlap A ss). interval_of s)"
    apply(induction ss)
     apply(simp; fail)
    apply(rename_tac x xs)
    apply(cases A, rename_tac a b)
    apply(case_tac x)
    apply(simp add: not_disjoint_intervals_def interval_of.simps)
    apply(intro impI conjI)
     apply(drule not_disjoint_union)
     apply blast
    apply(simp)
    by blast

  private lemma merge_overlap_length:
    "\<exists>s' \<in> set ss. \<not> disjoint (interval_of A) (interval_of s') \<Longrightarrow>
      length (merge_overlap A ss) = length ss"
    apply(induction ss)
     apply(simp)
    apply(rename_tac x xs)
    apply(cases A, rename_tac a b)
    apply(case_tac x)
    apply(simp add: not_disjoint_intervals_def interval_of.simps)
    done

  lemma "merge_overlap (1:: 16 word,2) [(1, 7)] = [(1, 7)]" by eval
  lemma "merge_overlap (1:: 16 word,2) [(2, 7)] = [(1, 7)]" by eval
  lemma "merge_overlap (1:: 16 word,2) [(3, 7)] = [(3, 7), (1,2)]" by eval

  private function listwordinterval_compress
    :: "(('a::len0) word \<times> ('a::len0) word) list \<Rightarrow> ('a word \<times> 'a word) list" where
    "listwordinterval_compress [] = []" |
    "listwordinterval_compress (s#ss) = (
            if \<forall>s' \<in> set ss. disjoint_intervals s s'
            then s#listwordinterval_compress ss
            else listwordinterval_compress (merge_overlap s ss))"
  by(pat_completeness, auto)

  private termination listwordinterval_compress
  apply (relation "measure length")
    apply(rule wf_measure)
   apply(simp)
  using disjoint_intervals_def merge_overlap_length by fastforce

  private lemma listwordinterval_compress:
    "(\<Union>s \<in> set (listwordinterval_compress ss). interval_of s) = (\<Union>s \<in> set ss. interval_of s)"
    apply(induction ss rule: listwordinterval_compress.induct)
     apply(simp)
    apply(simp)
    apply(intro impI)
    apply(simp add: disjoint_intervals_def)
    apply(drule merge_overlap_helper2)
    apply(simp)
    done

  lemma "listwordinterval_compress [(1::32 word,3), (8,10), (2,5), (3,7)] = [(8, 10), (1, 7)]"
    by eval

  private lemma A_in_listwordinterval_compress: "A \<in> set (listwordinterval_compress ss) \<Longrightarrow>
    interval_of A \<subseteq> (\<Union>s \<in> set ss. interval_of s)"
    using listwordinterval_compress by blast

  private lemma listwordinterval_compress_disjoint:
    "A \<in> set (listwordinterval_compress ss) \<Longrightarrow> B \<in> set (listwordinterval_compress ss) \<Longrightarrow>
      A \<noteq> B \<Longrightarrow> disjoint (interval_of A) (interval_of B)"
    apply(induction ss arbitrary: rule: listwordinterval_compress.induct)
     apply(simp)
    apply(simp split: if_split_asm)
    apply(elim disjE)
       apply(simp_all)
     apply(simp_all add: disjoint_intervals_def disjoint_def)
     apply(thin_tac [!] "False \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> _")
     apply(blast dest: A_in_listwordinterval_compress)+
    done
  text\<open>END merging overlapping intervals\<close>

  text\<open>BEGIN merging adjacent intervals\<close>
  private fun merge_adjacent
    :: "(('a::len) word \<times> ('a::len) word) \<Rightarrow> ('a word \<times> 'a word) list \<Rightarrow> ('a word \<times> 'a word) list"
  where
    "merge_adjacent s [] = [s]" |
    "merge_adjacent (s,e) ((s',e')#ss) = (
       if s \<le>e \<and> s' \<le> e' \<and> word_next e = s'
       then (s, e')#ss
       else if s \<le>e \<and> s' \<le> e' \<and> word_next e' = s
       then (s', e)#ss
       else (s',e')#merge_adjacent (s,e) ss)"

  private lemma merge_adjacent_helper:
  "interval_of A \<union> (\<Union>s \<in> set ss. interval_of s) = (\<Union>s \<in> set (merge_adjacent A ss). interval_of s)"
    apply(induction ss)
     apply(simp; fail)
    apply(rename_tac x xs)
    apply(cases A, rename_tac a b)
    apply(case_tac x)
    apply(simp add:  interval_of.simps)
    apply(intro impI conjI)
       apply (metis Un_assoc word_adjacent_union)
      apply(elim conjE)
      apply(drule(2) word_adjacent_union)
      subgoal by (blast)
     subgoal by (metis word_adjacent_union Un_assoc)
    by blast

  private lemma merge_adjacent_length:
    "\<exists>(s', e')\<in>set ss. s \<le> e \<and> s' \<le> e' \<and> (word_next e = s' \<or> word_next e' = s)
     \<Longrightarrow> length (merge_adjacent (s,e) ss) = length ss"
    apply(induction ss)
     apply(simp)
    apply(rename_tac x xs)
    apply(case_tac x)
    apply(simp add: )
    by blast

  private function listwordinterval_adjacent
    :: "(('a::len) word \<times> ('a::len) word) list \<Rightarrow> ('a word \<times> 'a word) list" where
    "listwordinterval_adjacent [] = []" |
    "listwordinterval_adjacent ((s,e)#ss) = (
            if \<forall>(s',e') \<in> set ss. \<not> (s \<le>e \<and> s' \<le> e' \<and> (word_next e = s' \<or> word_next e' = s))
            then (s,e)#listwordinterval_adjacent ss
            else listwordinterval_adjacent (merge_adjacent (s,e) ss))"
  by(pat_completeness, auto)

  private termination listwordinterval_adjacent
  apply (relation "measure length")
    apply(rule wf_measure)
   apply(simp)
  apply(simp)
  using merge_adjacent_length by fastforce

  private

  lemma "listwordinterval_adjacent [(1::16 word, 3), (5, 10), (10,10), (4,4)] = [(10, 10), (1, 10)]"
    by eval
  text\<open>END merging adjacent intervals\<close>

  definition wordinterval_compress :: "('a::len) wordinterval \<Rightarrow> 'a wordinterval" where
    "wordinterval_compress r \<equiv>
      l2wi (remdups (listwordinterval_adjacent (listwordinterval_compress
        (wi2l (wordinterval_optimize_empty r)))))"

  text\<open>Correctness: Compression preserves semantics\<close>
  lemma wordinterval_compress:
    "wordinterval_to_set (wordinterval_compress r) = wordinterval_to_set r"
    unfolding wordinterval_compress_def
    proof -
      have interval_of': "interval_of s = (case s of (s,e) \<Rightarrow> {s .. e})" for s
        by (cases s) (simp add: interval_of.simps)

      have "wordinterval_to_set (l2wi (remdups (listwordinterval_adjacent
              (listwordinterval_compress (wi2l (wordinterval_optimize_empty r)))))) =
            (\<Union>x\<in>set (listwordinterval_adjacent (listwordinterval_compress
                (wi2l (wordinterval_optimize_empty r)))). interval_of x)"
        by (force simp: interval_of' l2wi)
      also have "\<dots> =  (\<Union>s\<in>set (wi2l (wordinterval_optimize_empty r)). interval_of s)"
        by(simp add: listwordinterval_compress listwordinterval_adjacent)
      also have "\<dots> = (\<Union>(i, j)\<in>set (wi2l (wordinterval_optimize_empty r)). {i..j})"
        by(simp add: interval_of')
      also have "\<dots> = wordinterval_to_set r" by(simp add: wi2l)
      finally show "wordinterval_to_set
        (l2wi (remdups (listwordinterval_adjacent (listwordinterval_compress
            (wi2l (wordinterval_optimize_empty r))))))
          = wordinterval_to_set r" .
  qed

end

text\<open>Example\<close>
lemma "(wi2l \<circ> (wordinterval_compress :: 32 wordinterval \<Rightarrow> 32 wordinterval) \<circ> l2wi)
          [(70, 80001), (0,0), (150, 8000), (1,3), (42,41), (3,7), (56, 200), (8,10)] =
          [(56, 80001), (0, 10)]" by eval

lemma "wordinterval_compress (RangeUnion (RangeUnion (WordInterval (1::32 word) 5)
                                                        (WordInterval 8 10)) (WordInterval 3 7)) =
       WordInterval 1 10" by eval

subsection\<open>Further operations\<close>

  text\<open>@{text "\<Union>"}\<close>
  definition wordinterval_Union :: "('a::len) wordinterval list \<Rightarrow> 'a wordinterval" where
    "wordinterval_Union ws = wordinterval_compress (foldr wordinterval_union ws Empty_WordInterval)"

  lemma wordinterval_Union:
    "wordinterval_to_set (wordinterval_Union ws) = (\<Union> w \<in> (set ws). wordinterval_to_set w)"
    by(induction ws) (simp_all add: wordinterval_compress wordinterval_Union_def)

context
begin
  private fun wordinterval_setminus'
    :: "'a::len wordinterval \<Rightarrow> 'a wordinterval \<Rightarrow> 'a wordinterval" where
    "wordinterval_setminus' (WordInterval s e) (WordInterval ms me) = (
      if s > e \<or> ms > me then WordInterval s e else
      if me \<ge> e
        then
          WordInterval (if ms = 0 then 1 else s) (min e (word_prev ms))
        else if ms \<le> s
        then
          WordInterval (max s (word_next me)) (if me = max_word then 0 else e)
        else
          RangeUnion (WordInterval (if ms = 0 then 1 else s) (word_prev ms))
                     (WordInterval (word_next me) (if me = max_word then 0 else e))
        )" |
     "wordinterval_setminus' (RangeUnion r1 r2) t =
        RangeUnion (wordinterval_setminus' r1 t) (wordinterval_setminus' r2 t)"|
     "wordinterval_setminus' t (RangeUnion r1 r2) =
        wordinterval_setminus' (wordinterval_setminus' t r1) r2"

  private lemma wordinterval_setminus'_rr_set_eq:
    "wordinterval_to_set(wordinterval_setminus' (WordInterval s e) (WordInterval ms me)) =
    wordinterval_to_set (WordInterval s e) - wordinterval_to_set (WordInterval ms me)"
     apply(simp only: wordinterval_setminus'.simps)
     apply(case_tac "e < s")
      apply simp
     apply(case_tac "me < ms")
      apply simp
     apply(case_tac [!] "e \<le> me")
      apply(case_tac [!] "ms = 0")
        apply(case_tac [!] "ms \<le> s")
            apply(case_tac [!] "me = max_word")
                    apply(simp_all add: word_prev_def word_next_def min_def max_def)
            apply(safe)
                                  apply(auto)
                          apply(uint_arith)
                         apply(uint_arith)
                        apply(uint_arith)
                       apply(uint_arith)
                      apply(uint_arith)
                     apply(uint_arith)
                    apply(uint_arith)
                   apply(uint_arith)
                  apply(uint_arith)
                 apply(uint_arith)
                apply(uint_arith)
               apply(uint_arith)
              apply(uint_arith)
             apply(uint_arith)
            apply(uint_arith)
           apply(uint_arith)
          apply(uint_arith)
         apply(uint_arith)
        apply(uint_arith)
       apply(uint_arith)
      apply(uint_arith)
     apply(uint_arith)
   done

  private lemma wordinterval_setminus'_set_eq:
    "wordinterval_to_set (wordinterval_setminus' r1 r2) =
      wordinterval_to_set r1 - wordinterval_to_set r2"
    apply(induction rule: wordinterval_setminus'.induct)
      using wordinterval_setminus'_rr_set_eq apply blast
     apply auto
    done
  lemma wordinterval_setminus'_empty_struct:
    "wordinterval_empty r2 \<Longrightarrow> wordinterval_setminus' r1 r2 = r1"
    by(induction r1 r2 rule: wordinterval_setminus'.induct) auto

  definition wordinterval_setminus
    :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
    "wordinterval_setminus r1 r2 = wordinterval_compress (wordinterval_setminus' r1 r2)"

  lemma wordinterval_setminus_set_eq[simp]: "wordinterval_to_set (wordinterval_setminus r1 r2) =
    wordinterval_to_set r1 - wordinterval_to_set r2"
    by(simp add: wordinterval_setminus_def wordinterval_compress wordinterval_setminus'_set_eq)
end

definition wordinterval_UNIV :: "'a::len wordinterval" where
  "wordinterval_UNIV \<equiv> WordInterval 0 max_word"
lemma wordinterval_UNIV_set_eq[simp]: "wordinterval_to_set wordinterval_UNIV = UNIV"
  unfolding wordinterval_UNIV_def
  using max_word_max by fastforce

fun wordinterval_invert :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
  "wordinterval_invert r = wordinterval_setminus wordinterval_UNIV r"
lemma wordinterval_invert_set_eq[simp]:
  "wordinterval_to_set (wordinterval_invert r) = UNIV - wordinterval_to_set r" by(auto)

lemma wordinterval_invert_UNIV_empty:
  "wordinterval_empty (wordinterval_invert wordinterval_UNIV)" by simp

text\<open>@{text "\<inter>"}\<close>
context
begin
  private lemma "{(s::nat) .. e} \<inter> {s' .. e'} = {} \<longleftrightarrow> s > e' \<or> s' > e \<or> s > e \<or> s' > e'"
    by simp linarith
  private fun wordinterval_intersection'
    :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
    "wordinterval_intersection' (WordInterval s e) (WordInterval s' e') = (
        if s > e \<or> s' > e' \<or> s > e' \<or> s' > e \<or> s > e \<or> s' > e'
        then
          Empty_WordInterval
        else
          WordInterval (max s s') (min e e')
        )" |
    "wordinterval_intersection' (RangeUnion r1 r2) t =
        RangeUnion (wordinterval_intersection' r1 t) (wordinterval_intersection' r2 t)"|
    "wordinterval_intersection' t (RangeUnion r1 r2) =
        RangeUnion (wordinterval_intersection' t r1) (wordinterval_intersection' t r2)"

  private lemma wordinterval_intersection'_set_eq:
    "wordinterval_to_set (wordinterval_intersection' r1 r2) =
      wordinterval_to_set r1 \<inter> wordinterval_to_set r2"
    by(induction r1 r2 rule: wordinterval_intersection'.induct) (auto)

  lemma "wordinterval_intersection'
          (RangeUnion (RangeUnion (WordInterval (1::32 word) 3) (WordInterval 8 10))
                      (WordInterval 1 3)) (WordInterval 1 3) =
          RangeUnion (RangeUnion (WordInterval 1 3) (WordInterval 1 0)) (WordInterval 1 3)" by eval

  definition wordinterval_intersection
    :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
    "wordinterval_intersection r1 r2 \<equiv> wordinterval_compress (wordinterval_intersection' r1 r2)"

  lemma wordinterval_intersection_set_eq[simp]:
    "wordinterval_to_set (wordinterval_intersection r1 r2) =
      wordinterval_to_set r1 \<inter> wordinterval_to_set r2"
    by(simp add: wordinterval_intersection_def
                 wordinterval_compress wordinterval_intersection'_set_eq)

  lemma "wordinterval_intersection
          (RangeUnion (RangeUnion (WordInterval (1::32 word) 3) (WordInterval 8 10))
                      (WordInterval 1 3)) (WordInterval 1 3) =
          WordInterval 1 3" by eval
end

definition wordinterval_subset :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> bool" where
  "wordinterval_subset r1 r2 \<equiv> wordinterval_empty (wordinterval_setminus r1 r2)"
lemma wordinterval_subset_set_eq[simp]:
  "wordinterval_subset r1 r2 = (wordinterval_to_set r1 \<subseteq> wordinterval_to_set r2)"
  unfolding wordinterval_subset_def by simp

definition wordinterval_eq :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> bool" where
  "wordinterval_eq r1 r2 = (wordinterval_subset r1 r2 \<and> wordinterval_subset r2 r1)"
lemma wordinterval_eq_set_eq:
  "wordinterval_eq r1 r2 \<longleftrightarrow> wordinterval_to_set r1 = wordinterval_to_set r2"
  unfolding wordinterval_eq_def by auto

thm iffD1[OF wordinterval_eq_set_eq]
(*declare iffD1[OF wordinterval_eq_set_eq, simp]*)

lemma wordinterval_eq_comm: "wordinterval_eq r1 r2 \<longleftrightarrow> wordinterval_eq r2 r1"
  unfolding wordinterval_eq_def by fast
lemma wordinterval_to_set_alt: "wordinterval_to_set r = {x. wordinterval_element x r}"
  unfolding wordinterval_element_set_eq by blast

lemma wordinterval_un_empty:
  "wordinterval_empty r1 \<Longrightarrow> wordinterval_eq (wordinterval_union r1 r2) r2"
  by(subst wordinterval_eq_set_eq, simp)
lemma wordinterval_un_emty_b:
  "wordinterval_empty r2 \<Longrightarrow> wordinterval_eq (wordinterval_union r1 r2) r1"
  by(subst wordinterval_eq_set_eq, simp)

lemma wordinterval_Diff_triv:
  "wordinterval_empty (wordinterval_intersection a b) \<Longrightarrow> wordinterval_eq (wordinterval_setminus a b) a"
  unfolding wordinterval_eq_set_eq
  by simp blast

text\<open>A size of the datatype, does not correspond to the cardinality of the corresponding set\<close>
fun wordinterval_size :: "('a::len) wordinterval \<Rightarrow> nat" where
  "wordinterval_size (RangeUnion a b) = wordinterval_size a + wordinterval_size b" |
  "wordinterval_size (WordInterval s e) = (if s \<le> e then 1 else 0)"

lemma wordinterval_size_length: "wordinterval_size r = length (wi2l r)"
  by(induction r) (auto)

lemma Ex_wordinterval_nonempty: "\<exists>x::('a::len wordinterval). y \<in> wordinterval_to_set x"
  proof show "y \<in> wordinterval_to_set wordinterval_UNIV" by simp qed

lemma wordinterval_eq_reflp:
  "reflp wordinterval_eq"
  apply(rule reflpI)
  by(simp only: wordinterval_eq_set_eq)
lemma wordintervalt_eq_symp:
  "symp wordinterval_eq"
  apply(rule sympI)
  by(simp add: wordinterval_eq_comm)
lemma wordinterval_eq_transp:
  "transp wordinterval_eq"
  apply(rule transpI)
  by(simp only: wordinterval_eq_set_eq)

lemma wordinterval_eq_equivp:
  "equivp wordinterval_eq"
  by (auto intro: equivpI wordinterval_eq_reflp wordintervalt_eq_symp wordinterval_eq_transp)

text\<open>The smallest element in the interval\<close>
  definition is_lowest_element :: "'a::ord \<Rightarrow> 'a set \<Rightarrow> bool" where
    "is_lowest_element x S = (x \<in> S \<and> (\<forall>y\<in>S. y \<le> x \<longrightarrow> y = x))"

  lemma
  	fixes x :: "'a :: complete_lattice"
  	assumes "x \<in> S"
  	shows " x = Inf S \<Longrightarrow> is_lowest_element x S"
  using assms apply(simp add: is_lowest_element_def)
   by (simp add: Inf_lower eq_iff)

  lemma
  	fixes x :: "'a :: linorder"
  	assumes "finite S" and "x \<in> S"
  	shows "is_lowest_element x S \<longleftrightarrow> x = Min S"
  apply(rule)
  subgoal
   apply(simp add: is_lowest_element_def)
   apply(subst Min_eqI[symmetric])
   using assms by(auto)
  by (metis Min.coboundedI assms(1) assms(2) dual_order.antisym is_lowest_element_def)

text\<open>Smallest element in the interval\<close>
  fun wordinterval_lowest_element :: "'a::len0 wordinterval \<Rightarrow> 'a word option" where
    "wordinterval_lowest_element (WordInterval s e) = (if s \<le> e then Some s else None)" |
    "wordinterval_lowest_element (RangeUnion A B) =
      (case (wordinterval_lowest_element A, wordinterval_lowest_element B) of
          (Some a, Some b) \<Rightarrow> Some (if a < b then a else b) |
          (None, Some b) \<Rightarrow> Some b |
          (Some a, None) \<Rightarrow> Some a |
          (None, None) \<Rightarrow> None)"

  lemma wordinterval_lowest_none_empty: "wordinterval_lowest_element r = None \<longleftrightarrow> wordinterval_empty r"
    proof(induction r)
    case WordInterval thus ?case by simp
    next
    case RangeUnion thus ?case by fastforce
    qed

  lemma wordinterval_lowest_element_correct_A:
    "wordinterval_lowest_element r = Some x \<Longrightarrow> is_lowest_element x (wordinterval_to_set r)"
    unfolding is_lowest_element_def
    apply(induction r arbitrary: x rule: wordinterval_lowest_element.induct)
     apply(rename_tac rs re x, case_tac "rs \<le> re", auto)[1]
    apply(subst(asm) wordinterval_lowest_element.simps(2))
    apply(rename_tac A B x)
    apply(case_tac     "wordinterval_lowest_element B")
     apply(case_tac[!] "wordinterval_lowest_element A")
       apply(simp_all add: wordinterval_lowest_none_empty)[3]
    apply fastforce
  done

  lemma wordinterval_lowest_element_set_eq: assumes "\<not> wordinterval_empty r"
    shows "(wordinterval_lowest_element r = Some x) = (is_lowest_element x (wordinterval_to_set r))"
    (*unfolding is_lowest_element_def*)
    proof(rule iffI)
      assume "wordinterval_lowest_element r = Some x"
      thus "is_lowest_element x (wordinterval_to_set r)"
     using wordinterval_lowest_element_correct_A wordinterval_lowest_none_empty by simp
    next
      assume "is_lowest_element x (wordinterval_to_set r)"
      with assms show "(wordinterval_lowest_element r = Some x)"
        proof(induction r arbitrary: x rule: wordinterval_lowest_element.induct)
        case 1 thus ?case by(simp add: is_lowest_element_def)
        next
        case (2 A B x)

        have is_lowest_RangeUnion: "is_lowest_element x (wordinterval_to_set A \<union> wordinterval_to_set B) \<Longrightarrow>
          is_lowest_element x (wordinterval_to_set A) \<or> is_lowest_element x (wordinterval_to_set B)"
          by(simp add: is_lowest_element_def)

         (*why \<And> A B?*)
         have wordinterval_lowest_element_RangeUnion:
          "\<And>a b A B. wordinterval_lowest_element A = Some a \<Longrightarrow>
                  wordinterval_lowest_element B = Some b \<Longrightarrow>
                  wordinterval_lowest_element (RangeUnion A B) = Some (min a b)"
           by(auto dest!: wordinterval_lowest_element_correct_A simp add: is_lowest_element_def min_def)

        from 2 show ?case
        apply(case_tac     "wordinterval_lowest_element B")
         apply(case_tac[!] "wordinterval_lowest_element A")
           apply(auto simp add: is_lowest_element_def)[3]
        apply(subgoal_tac "\<not> wordinterval_empty A \<and> \<not> wordinterval_empty B")
         prefer 2
         using arg_cong[where f = Not, OF wordinterval_lowest_none_empty] apply blast
        apply(drule(1) wordinterval_lowest_element_RangeUnion)
        apply(simp split: option.split_asm add: min_def)
         apply(drule is_lowest_RangeUnion)
         apply(elim disjE)
          apply(simp add: is_lowest_element_def)
         apply(clarsimp simp add: wordinterval_lowest_none_empty)

        apply(simp add: is_lowest_element_def)
        apply(clarsimp simp add: wordinterval_lowest_none_empty)
        using wordinterval_lowest_element_correct_A[simplified is_lowest_element_def]
        by (metis Un_iff not_le)
      qed
    qed

text\<open>Cardinality approximation for @{typ "('a::len) wordinterval"}s\<close>
context
begin
  lemma card_atLeastAtMost_word: fixes s::"('a::len) word" shows "card {s..e} = Suc (unat e) - (unat s)"
    apply(cases "s > e")
     apply(simp)
     apply(subst(asm) Word.word_less_nat_alt)
     apply simp
    apply(subst Word_Lemmas.upto_enum_set_conv2[symmetric])
    apply(subst List.card_set)
    apply(simp add: remdups_enum_upto)
    done

  fun wordinterval_card :: "('a::len) wordinterval \<Rightarrow> nat" where
    "wordinterval_card (WordInterval s e) = Suc (unat e) - (unat s)" |
    "wordinterval_card (RangeUnion a b) = wordinterval_card a + wordinterval_card b"

  lemma wordinterval_card: "wordinterval_card r \<ge> card (wordinterval_to_set r)"
    proof(induction r)
    case WordInterval thus ?case by (simp add: card_atLeastAtMost_word)
    next
    case (RangeUnion r1 r2)
      have "card (wordinterval_to_set r1 \<union> wordinterval_to_set r2) \<le>
              card (wordinterval_to_set r1) + card (wordinterval_to_set r2)"
        using Finite_Set.card_Un_le by blast
      with RangeUnion show ?case by(simp)
    qed

  text\<open>With @{thm wordinterval_compress} it should be possible to get the exact cardinality\<close>
end

end


theory mapp
  imports Function_Model_Base
begin

context Function_Model begin

subsection \<open>Application relation on model Functions\<close>
lemma mapp_iff :
  assumes "f : mFunc"
  shows "mapp f b c \<longleftrightarrow> app (snd f) b c"
  unfolding mapp_def
  using assms by auto

lemma mapp_iff_pair :
  assumes "<func, f'> : mFunc"
  shows "mapp <func, f'> b c \<longleftrightarrow> app f' b c"
  unfolding mapp_iff[OF assms] mfunc_snd_eq[OF assms] ..

lemmas mappI = iffD2[OF mapp_iff]
   and mappI_pair = iffD2[OF mapp_iff_pair]

lemmas mappD = iffD1[OF mapp_iff]
   and mappD_pair = iffD1[OF mapp_iff_pair]

lemma mappE :
  assumes f:"f : mFunc" and bc:"mapp f b c"
  obtains f' where
    "f' : Function" "f = <func, f'>" "app f' b c"
proof (rule mfuncE1[OF f])
  thm mfunc_pair_snd_func mappD assms
  fix f' assume f_eq : "f = <func, f'>"
  moreover hence f':"f' : Function"
    using mfunc_pair_snd_func f by auto
  have app: "app f' b c"
    using mappD_pair f_eq f bc by auto

  from f' f_eq app show ?thesis ..
qed

lemma mapp_m :
  assumes f:"f : mFunc" and bc:"mapp f b c"
  shows "b : M \<and> c : M"
proof (rule mappE[OF f bc])
  fix f' assume
    f' : "f' : Function" and f_eq : "f = <func, f'>"
  then obtain j where
    j : "j : Ord" and "f' \<in> (Tier j \<ominus> func) \<midarrow>p\<rightarrow> (Tier j \<ominus> func)"
    using mE_mfunc_pair mfunc_m[OF f] by metis
  hence "dom f' \<subseteq> Tier j \<ominus> func" "ran f' \<subseteq> Tier j \<ominus> func"
    using fspaceD[OF tier_ex_set tier_ex_set, OF j j] by auto
  moreover have "app f' b c"
    using mappD_pair f bc
    unfolding f_eq by auto
  ultimately have "b \<in> Tier j \<ominus> func" "c \<in> Tier j \<ominus> func"
    using domI[OF f'] ranI[OF f'] by auto
  thus "b : M \<and> c : M"
    using mI[OF j exsetD1[OF tier_set[OF j]]]
    by auto
qed

text \<open>Model application is functional:\<close>
lemma mapp_functional :
  assumes f : "f : mFunc"
      and bc : "mapp f b c"
      and bd : "mapp f b d"
    shows "c = d"
  using bc bd app_eqI[OF mfunc_snd_func[OF f]]
  unfolding mapp_iff[OF f] by auto

lemma mapp_functional_ax :
  "m\<forall>f : mFunc. m\<forall>x y z. mapp f x y \<and> mapp f x z \<longrightarrow> y = z"
  unfolding mtall_def mall_def tall_def
  using mapp_functional by auto

text \<open>Model functions are extensional:\<close>
lemma mfunc_ext :
  assumes f : "f : mFunc" and g : "g : mFunc"
      and bc:"\<And>b c. mapp f b c \<longleftrightarrow> mapp g b c"
    shows "f = g"
proof (rule mfuncE1[OF f], rule mfuncE1[OF g])
  fix f' g' assume
    f' : "f = <func, f'>" and g' : "g = <func, g'>"
  have
    "snd f = snd g"
    using bc fun_eqI[OF mfunc_snd_func mfunc_snd_func, OF f g]
    unfolding mapp_def by auto
  thus "f = g"
    using mfunc_snd_eq f g unfolding f' g'
    by metis
qed

lemma mfunc_ext_ax :
  "m\<forall>f : mFunc. m\<forall>g : mFunc.
    (m\<forall>x y. mapp f x y = mapp g x y) \<longrightarrow> f = g"
  unfolding mtall_def mall_def tall_def
  using mfunc_ext mapp_m by meson

end
end


(*  Title:       LList_CCPO_Topology.thy
    Author:      Johannes Hölzl, TU Munich
    Author:      Andreas Lochbihler, ETH Zurich
*)

section {* A CCPO topology on lazy lists with examples *}

theory LList_CCPO_Topology imports
  CCPO_Topology
  "../Coinductive_List_Prefix"
begin

lemma closed_Collect_eq_isCont:
  fixes f g :: "'a :: t2_space \<Rightarrow> 'b::t2_space"
  assumes f: "\<And>x. isCont f x" and g: "\<And>x. isCont g x"
  shows "closed {x. f x = g x}"
  by (intro closed_Collect_eq continuous_at_imp_continuous_on ballI assms)

instantiation llist :: (type) ccpo_topology
begin

definition open_llist :: "'a llist set \<Rightarrow> bool" where
  "open_llist A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> Sup C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"

instance
  by intro_classes (simp add: open_llist_def)

end

subsection {* Continuity and closedness of predefined constants *}

lemma tendsto_mcont_llist: "mcont lSup lprefix lSup lprefix f \<Longrightarrow> f \<midarrow>l\<rightarrow> f l"
  by (auto simp add: Sup_llist_def[abs_def] intro!: tendsto_mcont)

lemma tendsto_ltl[THEN tendsto_compose, tendsto_intros]: "ltl \<midarrow>l\<rightarrow> ltl l"
  by (intro tendsto_mcont_llist mcont_ltl)

lemma tendsto_lappend2[THEN tendsto_compose, tendsto_intros]: "lappend l \<midarrow>l'\<rightarrow> lappend l l'"
  by (intro tendsto_mcont_llist mcont_lappend2)

lemma tendsto_LCons[THEN tendsto_compose, tendsto_intros]: "LCons x \<midarrow>l\<rightarrow> LCons x l"
  by (intro tendsto_mcont_llist mcont_LCons)

lemma tendsto_lmap[THEN tendsto_compose, tendsto_intros]: "lmap f \<midarrow>l\<rightarrow> lmap f l"
  by (intro tendsto_mcont_llist mcont_lmap)

lemma tendsto_llength[THEN tendsto_compose, tendsto_intros]: "llength \<midarrow>l\<rightarrow> llength l"
  by (intro tendsto_mcont) (simp add: Sup_llist_def[abs_def])

lemma tendsto_lset[THEN tendsto_compose, tendsto_intros]: "lset \<midarrow>l\<rightarrow> lset l"
  by(rule tendsto_mcont)(simp add: Sup_llist_def[abs_def])

lemma open_lhd: "open {l. \<not> lnull l \<and> lhd l = x}"
  unfolding open_ccpo set_eq_iff
proof (simp add: imp_conjL Sup_llist_def del: lhd_lSup, intro allI impI)
  fix C assume "Complete_Partial_Order.chain lprefix C" "lhd (lSup C) = x"
  moreover assume "\<exists>c\<in>C. \<not> lnull c"
  then obtain c where "c \<in> C" "\<not> lnull c"
    by auto
  ultimately show "\<exists>c. c \<in> C \<and> \<not> lnull c \<and> lhd c = x"
    by (force simp: lhd_lSup_eq)
qed

lemma open_LCons': assumes A: "open A" shows "open (LCons x ` A)"
proof -
  have "open (ltl -` A \<inter> {l. \<not> lnull l \<and> lhd l = x})"
    by (intro open_Int open_vimageI open_lhd A tendsto_intros)
  also have "(ltl -` A \<inter> {l. \<not> lnull l \<and> lhd l = x}) = LCons x ` A"
    by force
  finally show ?thesis .
qed

lemma open_Ici: "lfinite xs \<Longrightarrow> open {xs ..}"
proof (induct xs rule: lfinite.induct)
  case lfinite_LNil then show ?case
    by (simp add: atLeast_def)
next
  case (lfinite_LConsI xs x)
  moreover have "{LCons x xs ..} = LCons x ` {xs ..}"
    by (auto simp: LCons_lprefix_conv)
  ultimately show ?case
    by (auto intro: open_LCons')
qed

lemma open_lfinite[simp]: "lfinite x \<Longrightarrow> open {x}"
proof (induct rule: lfinite.induct)
  show "open {LNil}"
    using open_ccpo_Iic[of LNil] by (simp add: atMost_def lnull_def)
qed (auto dest: open_LCons')

lemma open_singleton_iff_lfinite: "open {x} \<longleftrightarrow> lfinite x"
proof
  assume "lfinite x" then show "open {x}"
    unfolding compact_eq_lfinite[symmetric] Sup_llist_def[abs_def, symmetric] less_eq_llist_def[abs_def, symmetric]
    by (rule open_singletonI_compact)
next
  assume "open {x}"
  show "lfinite x"
  proof (rule ccontr)
    let ?C = "{ys. lprefix ys x \<and> ys \<noteq> x}"
    assume inf: "\<not> lfinite x"
    note lSup_strict_prefixes[OF this] `open {x}`
    moreover have "chain ?C"
      using lprefixes_chain[of x] by (auto dest: chain_compr)
    moreover have "?C \<noteq> {}"
      using inf by (cases x) auto
    ultimately show False
      by (auto simp: open_ccpo Sup_llist_def)
  qed
qed

lemma closure_eq_lfinite:
  assumes closed_Q: "closed {xs. Q xs}"
  assumes downwards_Q: "\<And>xs ys. Q xs \<Longrightarrow> lprefix ys xs \<Longrightarrow> Q ys"
  shows "{xs. Q xs} = closure {xs. lfinite xs \<and> Q xs}"
proof (rule closure_unique[symmetric])
  fix T assume T: "{xs. lfinite xs \<and> Q xs} \<subseteq> T" and "closed T"

  show "{xs. Q xs} \<subseteq> T"
  proof clarify
    fix xs :: "'a llist"
    let ?F = "{ys. lprefix ys xs \<and> lfinite ys}"
    assume "Q xs"
    with T downwards_Q have "?F \<subseteq> T"
      by auto
    moreover have "chain ?F" "?F \<noteq> {}"
      by (auto intro: lprefixes_chain chain_subset)
    moreover have "lSup ?F = xs"
      by (rule lSup_finite_prefixes)
    ultimately show "xs \<in> T"
      using `closed T` by (auto simp: closed_ccpo Sup_llist_def)
  qed
qed (auto simp: closed_Q)

lemma closure_lfinite: "closure {xs. lfinite xs} = UNIV"
  using closure_eq_lfinite[of "\<lambda>_. True"] by auto

lemma closed_ldistinct: "closed {xs. ldistinct xs}"
  unfolding closed_ccpo by (auto simp: ldistinct_lSup Sup_llist_def subset_eq)

lemma ldistinct_closure: "{xs. ldistinct xs} = closure {xs. lfinite xs \<and> ldistinct xs}"
  by (rule closure_eq_lfinite[OF closed_ldistinct ldistinct_lprefix])

lemma closed_ldistinct': "(\<And>x. isCont f x) \<Longrightarrow> closed {xs. ldistinct (f xs)}"
  using continuous_closed_preimage_univ[of _ f, OF closed_ldistinct] by auto

lemma closed_lsorted: "closed {xs. lsorted xs}"
  unfolding closed_ccpo by (auto simp: lsorted_lSup Sup_llist_def subset_eq)

lemma lsorted_closure: "{xs. lsorted xs} = closure {xs. lfinite xs \<and> lsorted xs}"
  by (rule closure_eq_lfinite[OF closed_lsorted lsorted_lprefixD])

lemma closed_lsorted': "(\<And>x. isCont f x) \<Longrightarrow> closed {xs. lsorted (f xs)}"
  using continuous_closed_preimage_univ[of _ f, OF closed_lsorted] by auto

lemma closed_in_lset: "closed {l. x \<in> lset l}"
  unfolding closed_ccpo by (auto simp add: subset_eq lset_lSup Sup_llist_def)

lemma closed_llist_all2:
  "closed {(x, y). llist_all2 R x y}"
proof -
  { fix a b assume *: "\<And>A B. open A \<Longrightarrow> open B \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> (\<exists>x\<in>A. \<exists>y\<in>B. llist_all2 R x y)"
    then have "llist_all2 R a b"
    proof (coinduction arbitrary: a b)
      case LNil
      from LNil[rule_format, of "{LNil}" "- {LNil}"] LNil[rule_format, of "- {LNil}" "{LNil}"]
      show ?case
        by (auto simp: closed_def[symmetric] lnull_def)
    next
      case LCons
      show ?case
      proof
        show ?lhd
          using LCons(1)[rule_format, OF open_lhd open_lhd, of "lhd a" "lhd b"] LCons(2,3)
          by (auto dest: llist_all2_lhdD)
        show ?ltl
        proof (rule, simp, safe)
          fix A B assume "open A" "open B" "ltl a \<in> A" "ltl b \<in> B"
          with LCons(1)[rule_format, OF open_LCons' open_LCons', of A B "lhd a" "lhd b"] LCons(2,3)
          show "\<exists>a'\<in>A. \<exists>b'\<in>B. llist_all2 R a' b'"
            by (auto simp: not_lnull_conv)
        qed
      qed
    qed }
  then show ?thesis
    unfolding closed_def open_prod_def
    by (auto simp: subset_eq)
qed

lemma closed_list_all2:
  fixes f g :: "'b::t2_space \<Rightarrow> 'a llist"
  assumes f: "\<And>x. isCont f x" and g: "\<And>x. isCont g x"
  shows "closed {x. llist_all2 R (f x) (g x)}"
  using  isCont_closed_vimage[OF isCont_Pair[OF f g] closed_llist_all2, of R]
  by simp

lemma at_botI_lfinite[simp]: "lfinite l \<Longrightarrow> at l = bot"
  by (simp add: at_eq_bot_iff)

lemma at_eq_lfinite: "at l = (if lfinite l then bot else at' l)"
  by (auto simp: at'_def open_singleton_iff_lfinite)

lemma eventually_lfinite: "eventually lfinite (at' x)"
  apply (simp add: at'_def open_singleton_iff_lfinite eventually_principal eventually_at_topological)
  apply (intro exI[of _ "{.. x}"] impI conjI open_ccpo_Iic)
  apply (auto simp: lstrict_prefix_def intro!: lstrict_prefix_lfinite1)
  done

lemma eventually_nhds_llist:
  "eventually P (nhds l) \<longleftrightarrow> (\<exists>xs\<le>l. lfinite xs \<and> (\<forall>ys\<ge>xs. ys \<le> l \<longrightarrow> P ys))"
  unfolding eventually_nhds
proof safe
  let ?F = "{l'. lprefix l' l \<and> lfinite l'}"
  fix A assume "open A" "l \<in> A" "\<forall>l\<in>A. P l"
  moreover have "chain ?F" "?F \<noteq> {}"
    by (auto simp: chain_def dest: lprefix_down_linear)
  moreover have "Sup ?F = l"
    unfolding Sup_llist_def by (rule lSup_finite_prefixes)
  ultimately have "\<exists>xs. xs \<in> ?F \<and> (\<forall>ys\<ge>xs. ys \<in> ?F \<longrightarrow> P ys)"
    using open_ccpoD[of A ?F] by auto
  then show "\<exists>xs\<le>l. lfinite xs \<and> (\<forall>ys\<ge>xs. ys \<le> l \<longrightarrow> P ys)"
    by (metis (lifting) `l \<in> A` `\<forall>l\<in>A. P l` le_llist_conv_lprefix mem_Collect_eq not_lfinite_lprefix_conv_eq)
next
  fix xs assume "xs \<le> l" "lfinite xs" "\<forall>ys\<ge>xs. ys \<le> l \<longrightarrow> P ys"
  then show "\<exists>S. open S \<and> l \<in> S \<and> Ball S P"
    by (intro exI[of _ "{xs ..} \<inter> {.. l}"] conjI open_Int open_Ici open_ccpo_Iic) auto
qed

lemma nhds_lfinite: "lfinite l \<Longrightarrow> nhds l = principal {l}"
  unfolding filter_eq_iff eventually_principal eventually_nhds_llist
  by (auto simp del: le_llist_conv_lprefix)

lemma eventually_at'_llist:
  "eventually P (at' l) \<longleftrightarrow> (\<exists>xs\<le>l. lfinite xs \<and> (\<forall>ys\<ge>xs. lfinite ys \<longrightarrow> ys \<le> l \<longrightarrow> P ys))"
proof cases
  assume "lfinite l"
  then show ?thesis
    by (auto simp add: eventually_filtermap at'_def open_singleton_iff_lfinite
                       eventually_principal lfinite_eq_range_llist_of)
next
  assume "\<not> lfinite l"
  then show ?thesis
    by (auto simp: eventually_filtermap at'_def open_singleton_iff_lfinite
                   eventually_at_filter eventually_nhds_llist)
       (metis not_lfinite_lprefix_conv_eq)
qed

lemma eventually_at'_llistI: "(\<And>xs. lfinite xs \<Longrightarrow> xs \<le> l \<Longrightarrow> P xs) \<Longrightarrow> eventually P (at' l)"
  by (auto simp: eventually_at'_llist)

lemma Lim_at'_lfinite: "lfinite xs \<Longrightarrow> Lim (at' xs) f = f xs"
  by (rule tendsto_Lim[OF at'_bot]) (auto simp add: at'_def topological_tendstoI eventually_principal)

lemma filterlim_at'_list:
  "(f \<longlongrightarrow> y) (at' (x::'a llist)) \<Longrightarrow> f \<midarrow>x\<rightarrow> y"
  unfolding at'_def by (auto split: if_split_asm simp: open_singleton_iff_lfinite)

lemma tendsto_mcont_llist': "mcont lSup lprefix lSup lprefix f \<Longrightarrow> (f \<longlongrightarrow> f x) (at' (x :: 'a llist))"
by(auto simp add: at'_def nhds_lfinite[symmetric] open_singleton_iff_lfinite tendsto_at_iff_tendsto_nhds[symmetric] intro: tendsto_mcont_llist)

lemma tendsto_closed:
  assumes eq: "closed {x. P x}"
  assumes ev: "\<And>ys. lfinite ys \<Longrightarrow> ys \<le> x \<Longrightarrow> P ys"
  shows "P x"
proof -
  have "x \<in> {x. P x}"
  proof (rule Lim_in_closed_set)
    show "eventually (\<lambda>x. x \<in> {x. P x}) (at' x)"
      unfolding eq using ev
      by (force intro!: eventually_at'_llistI)
  qed (rule assms tendsto_id_at' at'_bot)+
  then show ?thesis
    by simp
qed

lemma tendsto_Sup_at':
  fixes f :: "'a llist \<Rightarrow> 'b::ccpo_topology"
  assumes f: "\<And>x y. x \<le> y \<Longrightarrow> lfinite x \<Longrightarrow> lfinite y \<Longrightarrow> f x \<le> f y"
  shows "(f \<longlongrightarrow> (Sup (f`{xs. lfinite xs \<and> xs \<le> l}))) (at' l)"
proof (rule topological_tendstoI)
  let ?F = "{xs. lfinite xs \<and> xs \<le> l}"

  have ch_F: "chain (f`?F)" "f`?F \<noteq> {}"
    by (rule chain_imageI[OF chain_subset, OF lprefixes_chain]) (auto simp: f)

  fix A assume A: "open A" "Sup (f`?F) \<in> A" then show "eventually (\<lambda>x. f x \<in> A) (at' l)"
    using open_ccpoD[OF _ ch_F, OF A] by (auto simp: eventually_at'_llist f simp del: le_llist_conv_lprefix)
qed

lemma tendsto_Lim_at':
  fixes f :: "'a llist \<Rightarrow> 'b::ccpo_topology"
  assumes f: "\<And>l. f l = Lim (at' l) f'"
  assumes mono: "\<And>x y. x \<le> y \<Longrightarrow> lfinite x \<Longrightarrow> lfinite y \<Longrightarrow> f' x \<le> f' y"
  shows "(f \<longlongrightarrow> f l) (at' l)"
  unfolding f[abs_def]
  apply (subst filterlim_cong[OF refl refl eventually_mono[OF eventually_lfinite Lim_at'_lfinite]])
  apply assumption
  apply (rule tendsto_LimI[OF tendsto_Sup_at'[OF mono]])
  apply assumption+
  done

lemma isCont_lmap[THEN isCont_o2[rotated]]: "isCont (lmap f) l"
  by (simp add: isCont_def tendsto_lmap tendsto_ident_at)

lemma isCont_lappend[THEN isCont_o2[rotated]]: "isCont (lappend xs) ys"
  by (simp add: isCont_def tendsto_lappend2 tendsto_ident_at)

lemma isCont_lset[THEN isCont_o2[rotated]]: "isCont lset xs"
  by(simp add: isCont_def tendsto_lset tendsto_ident_at)

subsection {* Define @{term lfilter} as continuous extension *}

definition "lfilter' P l = Lim (at' l) (\<lambda>xs. llist_of (filter P (list_of xs)))"

lemma tendsto_lfilter: "(lfilter' P \<longlongrightarrow> lfilter' P xs) (at' xs)"
  by (rule tendsto_Lim_at'[OF lfilter'_def]) (auto simp add: lfinite_eq_range_llist_of less_eq_list_def prefix_def)

lemma isCont_lfilter[THEN isCont_o2[rotated]]: "isCont (lfilter' P) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_lfilter)

lemma lfilter'_lfinite[simp]: "lfinite xs \<Longrightarrow> lfilter' P xs = llist_of (filter P (list_of xs))"
  by (simp add: lfilter'_def Lim_at'_lfinite)

lemma lfilter'_LCons [simp]: "lfilter' P (LCons a xs) = (if P a then LCons a (lfilter' P xs) else lfilter' P xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto intro!: isCont_lfilter isCont_LCons isCont_If)

lemma ldistinct_lfilter': "ldistinct l \<Longrightarrow> ldistinct (lfilter' P l)"
  by (rule tendsto_closed[OF closed_ldistinct', OF isCont_lfilter])
     (auto intro!: distinct_filter dest: ldistinct_lprefix simp: lfinite_eq_range_llist_of)

lemma lfilter'_lmap: "lfilter' P (lmap f xs) = lmap f (lfilter' (P \<circ> f) xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto simp add: filter_map comp_def intro!: isCont_lmap isCont_lfilter)

lemma lfilter'_lfilter': "lfilter' P (lfilter' Q xs) = lfilter' (\<lambda>x. Q x \<and> P x) xs"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont]) (auto intro!: isCont_lfilter)

lemma lset_lfilter': "lset (lfilter' P xs) = lset xs \<inter> {x. P x}"
  by(rule tendsto_closed[OF closed_Collect_eq_isCont])
    (auto 4 3 intro: isCont_lset isCont_lfilter isCont_inf2)

lemma lfilter'_eq_LNil_iff: "lfilter' P xs = LNil \<longleftrightarrow> (\<forall>x\<in>lset xs. \<not> P x)"
  using lset_lfilter'[of P xs] by auto

lemma lfilter'_eq_lfilter: "lfilter' P xs = lfilter P xs"
using isCont_lfilter
proof(rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
  fix ys :: "'a llist"
  assume "lfinite ys"
  thus "lfilter' P ys = lfilter P ys" by induction simp_all
qed(simp_all add: isCont_def tendsto_mcont_llist mcont_lfilter)

subsection {* Define @{term lconcat} as continuous extension*}

definition "lconcat' xs = Lim (at' xs) (\<lambda>xs. foldr lappend (list_of xs) LNil)"

lemma tendsto_lconcat': "(lconcat' \<longlongrightarrow> lconcat' xss) (at' xss)"
  apply (rule tendsto_Lim_at'[OF lconcat'_def])
  apply (auto simp add: lfinite_eq_range_llist_of less_eq_list_def prefix_def)
  apply (induct_tac xa)
  apply simp_all
  done

lemma isCont_lconcat'[THEN isCont_o2[rotated]]: "isCont lconcat' l"
  by (simp add: isCont_def filterlim_at'_list tendsto_lconcat')

lemma lconcat'_lfinite[simp]: "lfinite xs \<Longrightarrow> lconcat' xs = foldr lappend (list_of xs) LNil"
  by (simp add: lconcat'_def Lim_at'_lfinite)

lemma lconcat'_LNil: "lconcat' LNil = LNil"
  by simp

lemma lconcat'_LCons [simp]: "lconcat' (LCons l xs) = lappend l (lconcat' xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto intro!: isCont_lconcat' isCont_lappend isCont_LCons)

lemma lmap_lconcat: "lmap f (lconcat' xss) = lconcat' (lmap (lmap f) (xss::'a llist llist))"
proof (rule tendsto_closed[where x=xss, OF closed_Collect_eq_isCont])
  fix xs :: "'a llist llist"
  assume "lfinite xs"
  then show "lmap f (lconcat' xs) = lconcat' (lmap (lmap f) xs)"
    by (induct xs rule: lfinite.induct) (auto simp: lmap_lappend_distrib)
qed (intro isCont_lconcat' isCont_lappend isCont_LCons continuous_ident isCont_lmap)+

lemmas tendsto_Sup[THEN tendsto_compose, tendsto_intros] =
  mcont_SUP[OF mcont_id' mcont_const, THEN tendsto_mcont]

lemma
  assumes fin: "\<forall>xs\<in>lset xss. lfinite xs"
  shows "lset (lconcat' xss) = (\<Union>xs\<in>lset xss. lset xs)" (is "?lhs = ?rhs")
proof(rule tendsto_unique_eventually[OF at'_bot])
  show "eventually (\<lambda>x. lset (lconcat' x) = (\<Union>y\<in>lset x. lset y)) (at' xss)"
  proof(rule eventually_at'_llistI)
    fix xss'
    assume "lfinite xss'" "xss' \<le> xss"
    hence "\<forall>xs\<in>lset xss'. lfinite xs" using fin by (auto dest!: lprefix_lsetD)
    with `lfinite xss'` show "lset (lconcat' xss') = (\<Union>xs\<in>lset xss'. lset xs)"
      by (induct xss') auto
  qed
qed (rule tendsto_intros tendsto_lconcat' tendsto_id_at')+

subsection {* Define @{term ldropWhile} as continuous extension *}

definition "ldropWhile' P xs = Lim (at' xs) (\<lambda>xs. llist_of (dropWhile P (list_of xs)))"

lemma tendsto_ldropWhile':
  "(ldropWhile' P \<longlongrightarrow> ldropWhile' P xs) (at' xs)"
  by (rule tendsto_Lim_at'[OF ldropWhile'_def])
     (auto simp add: lfinite_eq_range_llist_of less_eq_list_def prefix_def dropWhile_append dropWhile_False)

lemma isCont_ldropWhile'[THEN isCont_o2[rotated]]: "isCont (ldropWhile' P) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_ldropWhile')

lemma ldropWhile'_lfinite[simp]: "lfinite xs \<Longrightarrow> ldropWhile' P xs = llist_of (dropWhile P (list_of xs))"
  by (simp add: ldropWhile'_def Lim_at'_lfinite)

lemma ldropWhile'_LNil: "ldropWhile' P LNil = LNil"
  by simp

lemma ldropWhile'_LCons [simp]: "ldropWhile' P (LCons l xs) = (if P l then ldropWhile' P xs else LCons l xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto intro!: isCont_ldropWhile' isCont_If isCont_LCons)

lemma "ldropWhile' P (lmap f xs) = lmap f (ldropWhile' (P \<circ> f) xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto simp add: dropWhile_map comp_def intro!: isCont_lmap isCont_ldropWhile')

lemma ldropWhile'_LNil_I[simp]: "\<forall>x \<in> lset xs. P x \<Longrightarrow> ldropWhile' P xs = LNil"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto simp add: llist_of_eq_LNil_conv intro!: isCont_lmap isCont_ldropWhile' dest!: lprefix_lsetD)

lemma lnull_ldropWhile': "lnull (ldropWhile' P xs) \<longleftrightarrow> (\<forall>x \<in> lset xs. P x)" (is "?lhs \<longleftrightarrow> _")
proof (intro iffI ballI)
  fix x assume "x \<in> lset xs" ?lhs then show "P x" by induct (simp_all split: if_split_asm)
qed simp

lemma lhd_lfilter': "lhd (lfilter' P xs) = lhd (ldropWhile' (Not \<circ> P) xs)"
proof cases
  assume "\<exists>x\<in>lset xs. P x"
  then obtain x where "x \<in> lset xs" and "P x" by blast
  from `x \<in> lset xs` show ?thesis by induct (simp_all add: `P x`)
qed simp

subsection {* Define @{text ldrop} as continuous extension *}

primrec edrop where
  "edrop n [] = []"
| "edrop n (x # xs) = (case n of eSuc n \<Rightarrow> edrop n xs | 0 \<Rightarrow> x # xs)"

lemma mono_edrop: "edrop n xs \<le> edrop n (xs @ ys)"
  by (induct xs arbitrary: n) (auto split: enat_cosplit)

lemma edrop_mono: "xs \<le> ys \<Longrightarrow> edrop n xs \<le> edrop n ys"
  using mono_edrop[of n xs] by (auto simp add: less_eq_list_def prefix_def)

definition "ldrop' n xs = Lim (at' xs) (llist_of \<circ> edrop n \<circ> list_of)"

lemma ldrop'_lfinite[simp]: "lfinite xs \<Longrightarrow> ldrop' n xs = llist_of (edrop n (list_of xs))"
  by (simp add: ldrop'_def Lim_at'_lfinite)

lemma tendsto_ldrop': "(ldrop' n \<longlongrightarrow> ldrop' n l) (at' l)"
  by (rule tendsto_Lim_at'[OF ldrop'_def]) (auto simp add: lfinite_eq_range_llist_of intro!: edrop_mono)

lemma isCont_ldrop'[THEN isCont_o2[rotated]]: "isCont (ldrop' n) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_ldrop')

lemma "ldrop' n LNil = LNil"
  by simp

lemma "ldrop' n (LCons x xs) = (case n of 0 \<Rightarrow> LCons x xs | eSuc n \<Rightarrow> ldrop' n xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto intro!: isCont_ldrop' isCont_enat_case isCont_LCons split: enat_cosplit)

primrec up :: "'a :: order \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "up a [] = []"
| "up a (x # xs) = (if a < x then x # up x xs else up a xs)"

lemma set_upD: "x \<in> set (up y xs) \<Longrightarrow> x \<in> set xs \<and> y < x"
  by (induct xs arbitrary: y) (auto split: if_split_asm intro: less_trans)

lemma prefix_up: "prefix (up a xs) (up a (xs @  ys))"
  by (induction xs arbitrary: a) auto

lemma mono_up: "xs \<le> ys \<Longrightarrow> up a xs \<le> up a ys"
  unfolding less_eq_list_def by (subst (asm) prefix_def) (auto intro!: prefix_up)

lemma sorted_up: "sorted (up a xs)"
  by (induction xs arbitrary: a) (auto dest: set_upD intro: less_imp_le sorted.Cons)

subsection {* Define more functions on lazy lists as continuous extensions *}

definition "lup a xs = Lim (at' xs) (\<lambda>xs. llist_of (up a (list_of xs)))"

lemma tendsto_lup: "(lup a \<longlongrightarrow> lup a xs) (at' xs)"
  by (rule tendsto_Lim_at'[OF lup_def]) (auto simp: lfinite_eq_range_llist_of mono_up)

lemma isCont_lup[THEN isCont_o2[rotated]]: "isCont (lup a) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_lup)

lemma lup_lfinite[simp]: "lfinite xs \<Longrightarrow> lup a xs = llist_of (up a (list_of xs))"
  by (simp add: lup_def Lim_at'_lfinite)

lemma lup_LNil: "lup a LNil = LNil"
  by simp

lemma lup_LCons [simp]: "lup a (LCons x xs) = (if a < x then LCons x (lup x xs) else lup a xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto intro!: isCont_lup isCont_If isCont_LCons)

lemma lset_lup: "lset (lup x xs) \<subseteq> lset xs \<inter> {y. x < y}"
  by (rule tendsto_le_ccpo[where g="\<lambda>xs. lset (lup x xs)" and f="\<lambda>xs. lset xs \<inter> {y. x < y}" and F="at' xs"])
     (auto dest!: lprefix_lsetD set_upD intro!:  tendsto_intros at'_bot tendsto_lup eventually_at'_llistI)

lemma lsorted_lup: "lsorted (lup (a::'a::linorder) l)"
  by (rule tendsto_closed[OF closed_lsorted', OF isCont_lup])
     (auto intro!: sorted_up simp: lprefix_conv_lappend)

context notes [[function_internals]]
begin

partial_function (llist) lup' :: "'a :: ord \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  "lup' a xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> if a < x then LCons x (lup' x xs) else lup' a xs)"

end

declare lup'.mono[cont_intro]

lemma monotone_lup': "monotone (rel_prod op = lprefix) lprefix (\<lambda>(a, xs). lup' a xs)"
by(rule llist.fixp_preserves_mono2[OF lup'.mono lup'_def]) simp

lemma mono2mono_lup'2[THEN llist.mono2mono, simp, cont_intro]:
  shows monotone_lup'2: "monotone lprefix lprefix (lup' a)"
using monotone_lup' by auto

lemma mcont_lup': "mcont (prod_lub the_Sup lSup) (rel_prod op = lprefix) lSup lprefix (\<lambda>(a, xs). lup' a xs)"
by(rule llist.fixp_preserves_mcont2[OF lup'.mono lup'_def]) simp

lemma mcont2mcont_lup'2[THEN llist.mcont2mcont, simp, cont_intro]:
  shows mcont_lup'2: "mcont lSup lprefix lSup lprefix (lup' a)"
using mcont_lup' by auto

simps_of_case lup'_simps [simp]: lup'.simps

lemma lset_lup'_subset:
  fixes x :: "_ :: preorder"
  shows "lset (lup' x xs) \<subseteq> lset xs \<inter> {y. x < y}"
by(induction xs arbitrary: x)(auto intro: less_trans)

lemma in_lset_lup'D:
  fixes x :: "_ :: preorder"
  assumes "y \<in> lset (lup' x xs)"
  shows "y \<in> lset xs \<and> x < y"
using lset_lup'_subset[of x xs] assms by auto

lemma lsorted_lup':
  fixes x :: "_ :: preorder"
  shows "lsorted (lup' x xs)"
by(induction xs arbitrary: x)(auto simp add: lsorted_LCons dest: in_lset_lup'D intro: less_imp_le)

lemma ldistinct_lup':
  fixes x :: "_ :: preorder"
  shows "ldistinct (lup' x xs)"
by(induction xs arbitrary: x)(auto dest: in_lset_lup'D)

context fixes f :: "'a \<Rightarrow> 'a" begin

partial_function (llist) iterate :: "'a \<Rightarrow> 'a llist"
where "iterate x = LCons x (iterate (f x))"

lemma lmap_iterate: "lmap f (iterate x) = iterate (f x)"
by(induction arbitrary: x rule: iterate.fixp_induct) simp_all

end

fun extup extdown  :: "int \<Rightarrow> int list \<Rightarrow> int list" where
  "extup i [] = []"
| "extup i (x # xs) = (if i \<le> x then extup x xs else i # extdown x xs)"
| "extdown i [] = []"
| "extdown i (x # xs) = (if i \<ge> x then extdown x xs else i # extup x xs)"

lemma prefix_ext:
  "prefix (extup a xs) (extup a (xs @  ys))"
  "prefix (extdown a xs) (extdown a (xs @  ys))"
  by (induction xs arbitrary: a) auto

lemma mono_ext: assumes "xs \<le> ys" shows "extup a xs \<le> extup a ys" "extdown a xs \<le> extdown a ys"
  using assms[unfolded less_eq_list_def prefix_def] by (auto simp: less_eq_list_def prefix_ext)

lemma set_ext: "set (extup a xs) \<subseteq> {a} \<union> set xs" "set (extdown a xs) \<subseteq> {a} \<union> set xs"
  by (induction xs arbitrary: a) auto

definition "lextup i l = Lim (at' l) (llist_of \<circ> extup i \<circ> list_of)"
definition "lextdown i l = Lim (at' l) (llist_of \<circ> extdown i \<circ> list_of)"

lemma tendsto_lextup[tendsto_intros]: "(lextup i \<longlongrightarrow> lextup i xs) (at' xs)"
  by (rule tendsto_Lim_at'[OF lextup_def]) (auto simp: lfinite_eq_range_llist_of mono_ext)

lemma tendsto_lextdown[tendsto_intros]: "(lextdown i \<longlongrightarrow> lextdown i xs) (at' xs)"
  by (rule tendsto_Lim_at'[OF lextdown_def]) (auto simp: lfinite_eq_range_llist_of mono_ext)

lemma isCont_lextup[THEN isCont_o2[rotated]]: "isCont (lextup a) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_lextup)

lemma isCont_lextdown[THEN isCont_o2[rotated]]: "isCont (lextdown a) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_lextdown)

lemma lextup_lfinite[simp]: "lfinite xs \<Longrightarrow> lextup i xs = llist_of (extup i (list_of xs))"
  by (simp add: lextup_def Lim_at'_lfinite)

lemma lextdown_lfinite[simp]: "lfinite xs \<Longrightarrow> lextdown i xs = llist_of (extdown i (list_of xs))"
  by (simp add: lextdown_def Lim_at'_lfinite)

lemma "lextup i LNil = LNil" "lextdown i LNil = LNil"
  by simp_all

lemma "lextup i (LCons x xs) = (if i \<le> x then lextup x xs else LCons i (lextdown x xs))"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto intro!: isCont_lextdown isCont_lextup isCont_If isCont_LCons)

lemma "lextdown i (LCons x xs) = (if x \<le> i then lextdown x xs else LCons i (lextup x xs))"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto intro!: isCont_lextdown isCont_lextup isCont_If isCont_LCons)

lemma "lset (lextup a xs) \<subseteq> {a} \<union> lset xs"
  apply (rule tendsto_le_ccpo[where g="\<lambda>xs. lset (lextup a xs)" and f="\<lambda>xs. {a} \<union> lset xs" and F="at' xs"])
  apply (rule tendsto_intros at'_bot tendsto_lup eventually_at'_llistI tendsto_id_at')+
  apply (auto dest!: lprefix_lsetD set_ext[THEN set_mp])
  done

lemma "lset (lextdown a xs) \<subseteq> {a} \<union> lset xs"
  apply (rule tendsto_le_ccpo[where g="\<lambda>xs. lset (lextdown a xs)" and f="\<lambda>xs. {a} \<union> lset xs" and F="at' xs"])
  apply (rule tendsto_intros at'_bot tendsto_lup eventually_at'_llistI tendsto_id_at')+
  apply (auto dest!: lprefix_lsetD set_ext[THEN set_mp])
  done

lemma distinct_ext:
  assumes "distinct xs" "a \<notin> set xs"
  shows "distinct (extup a xs)" "distinct (extdown a xs)"
  using assms set_ext
  apply (induction xs arbitrary: a)
  apply auto
  apply (metis eq_iff insert_iff subset_iff)+
  done

lemma "ldistinct xs \<Longrightarrow> a \<notin> lset xs \<Longrightarrow> ldistinct (lextup a xs)"
  by (rule_tac tendsto_closed[OF closed_ldistinct', OF isCont_lextup])
     (force simp: lfinite_eq_range_llist_of intro!: distinct_ext dest: ldistinct_lprefix dest: lprefix_lsetD)+

definition esum_list :: "ereal llist \<Rightarrow> ereal" where
  "esum_list xs = Lim (at' xs) (sum_list \<circ> list_of)"

lemma esum_list_lfinite[simp]: "lfinite xs \<Longrightarrow> esum_list xs = sum_list (list_of xs)"
  by (simp add: esum_list_def Lim_at'_lfinite)

lemma esum_list_LNil: "esum_list LNil = 0"
  by simp

context
  fixes xs :: "ereal llist"
  assumes xs: "\<And>x. x \<in> lset xs \<Longrightarrow> 0 \<le> x"
begin

lemma esum_list_tendsto_SUP:
  "((sum_list\<circ>list_of) \<longlongrightarrow> (SUP ys : {ys. lfinite ys \<and> ys \<le> xs}. esum_list ys)) (at' xs)"
    (is "(_ \<longlongrightarrow> ?y) _")
proof (rule order_tendstoI)
  fix a assume "a < ?y"
  then obtain ys where "llist_of ys \<le> xs" "a < sum_list ys"
    by (auto simp: less_SUP_iff lfinite_eq_range_llist_of)
  moreover
  { fix zs assume "ys \<le> zs" "llist_of zs \<le> xs"
    then obtain ys' where zs: "zs = ys @ ys'"
      by (auto simp: prefix_def less_eq_list_def)
    with `llist_of zs \<le> xs` have nonneg: "0 \<le> sum_list ys'"
      using xs by (auto simp: lprefix_conv_lappend sum_list_sum_nth intro: sum_nonneg)
    note `a < sum_list ys`
    also have "sum_list ys \<le> sum_list zs"
      using zs ereal_add_mono[OF order_refl nonneg] by auto
    finally have "a < sum_list zs" . }
  ultimately show "eventually (\<lambda>x. a < (sum_list\<circ>list_of) x) (at' xs)"
    unfolding eventually_at'_llist by (auto simp: lfinite_eq_range_llist_of)
next
  fix a assume "?y < a" then show "eventually (\<lambda>x. (sum_list\<circ>list_of) x < a) (at' xs)"
    by (auto intro!: eventually_at'_llistI dest: SUP_lessD)
qed

lemma tendsto_esum_list: "(esum_list \<longlongrightarrow> esum_list xs) (at' xs)"
  apply (rule filterlim_cong[where g="sum_list \<circ> list_of", THEN iffD2, OF refl refl])
  apply (rule eventually_mono[OF eventually_lfinite])
  apply simp
  unfolding esum_list_def
  apply (rule tendsto_LimI)
  apply (rule esum_list_tendsto_SUP)
  done

lemma isCont_esum_list: "isCont esum_list xs"
  by (simp add: isCont_def filterlim_at'_list tendsto_esum_list)

end

lemma esum_list_nonneg:
  "(\<And>x. x \<in> lset xs \<Longrightarrow> 0 \<le> x) \<Longrightarrow> 0 \<le> esum_list xs"
  by (rule tendsto_le[OF at'_bot tendsto_esum_list tendsto_const])
     (auto intro!: eventually_at'_llistI sum_nonneg
           simp: lprefix_conv_lappend sum_list_sum_nth lfinite_eq_range_llist_of)

lemma esum_list_LCons:
  assumes x: "0 \<le> x" "\<And>x. x \<in> lset xs \<Longrightarrow> 0 \<le> x" shows "esum_list (LCons x xs) = x + esum_list xs"
proof (rule tendsto_unique_eventually[OF at'_bot])
  from x show "((\<lambda>xs. esum_list (LCons x xs)) \<longlongrightarrow> esum_list (LCons x xs)) (at' xs)"
    by (intro tendsto_compose[OF filterlim_at'_list[OF tendsto_esum_list] tendsto_LCons]) auto
  show "eventually (\<lambda>xa. esum_list (LCons x xa) = x + esum_list xa) (at' xs)"
    using eventually_lfinite by eventually_elim simp
  from x show "((\<lambda>xa. x + esum_list xa) \<longlongrightarrow> x + esum_list xs) (at' xs)"
    by (intro esum_list_nonneg tendsto_esum_list tendsto_add_ereal) auto
qed

lemma esum_list_lfilter':
  assumes nn: "\<And>x. x \<in> lset xs \<Longrightarrow> 0 \<le> x" shows "esum_list (lfilter' (\<lambda>x. x \<noteq> 0) xs) = esum_list xs"
proof (rule tendsto_unique_eventually[OF at'_bot])
  show "(esum_list \<longlongrightarrow> esum_list xs) (at' xs)"
    using nn by (rule tendsto_esum_list)
  from nn show "((\<lambda>xs. esum_list (lfilter' (\<lambda>x. x \<noteq> 0) xs)) \<longlongrightarrow> esum_list (lfilter' (\<lambda>x. x \<noteq> 0) xs)) (at' xs)"
    by (intro tendsto_compose[OF filterlim_at'_list[OF tendsto_esum_list] tendsto_lfilter]) (auto simp: lset_lfilter')
  show "eventually (\<lambda>xs. esum_list (lfilter' (\<lambda>x. x \<noteq> 0) xs) = esum_list xs) (at' xs)"
    using eventually_lfinite
    by eventually_elim (simp add: sum_list_map_filter[where f = "\<lambda>x. x" and P="\<lambda>x. x \<noteq> 0", simplified])
qed

function f:: "nat list \<Rightarrow> nat list" where
  "f [] = []"
| "f (x#xs) = (x * 2) # f (f xs)"
  by auto pat_completeness

termination f
proof (relation "inv_image natLess length")
  fix x xs assume "f_dom xs" then show "(f xs, x # xs) \<in> inv_image natLess length"
    by induct (auto simp: f.psimps natLess_def)
qed (auto intro: wf_less simp add: natLess_def)

lemma length_f[simp]: "length (f xs) = length xs"
  by (induct rule: f.induct) simp_all

lemma f_mono': "\<exists>ys'. f (xs @ ys) = f xs @ ys'"
proof (induct "length xs" arbitrary: xs ys rule: less_induct)
  case less then show ?case
    apply (cases xs)
    apply auto
    apply (metis length_f lessI)
    done
qed

lemma f_mono: "xs \<le> ys \<Longrightarrow> f xs \<le> f ys"
  by (auto simp: less_eq_list_def prefix_def f_mono')

definition "f' l = Lim (at' l) (\<lambda>l. llist_of (f (list_of l)))"

lemma f'_lfinite[simp]: "lfinite xs \<Longrightarrow> f' xs = llist_of (f (list_of xs))"
  by (simp add: f'_def Lim_at'_lfinite)

lemma tendsto_f': "(f' \<longlongrightarrow> f' l) (at' l)"
  by (rule tendsto_Lim_at'[OF f'_def]) (auto simp add: lfinite_eq_range_llist_of intro!: f_mono)

lemma isCont_f'[THEN isCont_o2[rotated]]: "isCont f' l"
  by (simp add: isCont_def filterlim_at'_list tendsto_f')

lemma "f' LNil = LNil"
  by simp

lemma "f' (LCons x xs) = LCons (x * 2) (f' (f' xs))"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq_isCont])
     (auto intro!: isCont_f' isCont_LCons)

end


theory Model_Namespace
  imports
    Main
begin

section "Definitions"

datatype ('nametype) Namespace = Root | Identifier "('nametype) Namespace \<times> 'nametype"
type_synonym ('nametype) Id = "('nametype) Namespace \<times> 'nametype"

subsection "Notation"

notation Root ("(\<bottom>)" 1000)

abbreviation identifier_notation :: "('nt) Id \<Rightarrow> 'nt \<Rightarrow> ('nt) Id" (infixl "\<^enum>" 50) where
  "ns\<^enum>n \<equiv> (Identifier ns, n)"

abbreviation root_namespace_notation :: "'nt \<Rightarrow> ('nt) Id" ("\<bottom>\<^enum>_" [1000] 1000) where
  "\<bottom>\<^enum>n \<equiv> (\<bottom>, n)"

subsection "Domain"

subsubsection "Namespaces"

inductive_set namespace_domain :: "'nt Namespace set"
  where
    rule_root: "\<bottom> \<in> namespace_domain" |
    rule_nested: "ns \<in> namespace_domain \<Longrightarrow> Identifier (ns, n) \<in> namespace_domain"

lemma namespace_domainI: "ns \<in> namespace_domain"
proof (induct ns)
  case Root
  then show ?case
    by (fact namespace_domain.rule_root)
next
  case (Identifier x)
  then show ?case
    using fsts.intros namespace_domain.rule_nested prod.exhaust_sel
    by metis
qed

lemma namespace_domain_alt: "namespace_domain = UNIV"
proof
  show "namespace_domain \<subseteq> UNIV"
    by simp
next
  show "UNIV \<subseteq> namespace_domain"
  proof
    fix x :: "'nt Namespace"
    show "x \<in> namespace_domain"
      by (fact namespace_domainI)
  qed
qed

subsubsection "Identifiers"

inductive_set identifier_domain :: "'nt Id set"
  where
    rule_identifier: "(\<bottom>, i) \<in> identifier_domain" |
    rule_nested: "ns \<in> identifier_domain \<Longrightarrow> (Identifier ns, i) \<in> identifier_domain"

lemma identifier_domain_subset: "Identifier ` identifier_domain \<subseteq> namespace_domain"
  by (simp add: namespace_domain_alt)

lemma identifier_domainI: "i \<in> identifier_domain"
proof (induct i)
  case (Pair a b)
  then show ?case
  proof (induct a)
    case Root
    then show ?case
      by (fact identifier_domain.rule_identifier)
  next
    case (Identifier x)
    then show ?case
      using eq_fst_iff fsts.intros identifier_domain.simps
      by metis
  qed
qed

lemma identifier_domain_alt: "identifier_domain = UNIV"
proof
  show "identifier_domain \<subseteq> UNIV"
    by simp
next
  show "UNIV \<subseteq> identifier_domain"
  proof
    fix x :: "'nt Id"
    show "x \<in> identifier_domain"
      by (fact identifier_domainI)
  qed
qed

subsection "Helper functions"

fun ns_to_id :: "'t Namespace \<Rightarrow> 't Id" where
  "ns_to_id (Identifier x) = x" |
  "ns_to_id Root = undefined"

definition ns :: "('nt) Id \<Rightarrow> ('nt) Namespace" where
  "ns identifier = fst identifier"

subsection "Subnamespaces"

fun ns_in_ns :: "('nt) Namespace \<Rightarrow> ('nt) Namespace \<Rightarrow> bool" where
  "ns_in_ns (Root) _ = False" |
  "ns_in_ns (Identifier x) y = (if fst x = y then True else ns_in_ns (fst x) y)"

lemma identifier_in_root[simp]: "ns_in_ns (Identifier x) \<bottom>"
proof (induct x)
  case (Pair a b)
  then show ?case
  proof (induct a)
    case Root
    then show ?case
      by auto
  next
    case (Identifier x)
    then show ?case
      using fsts.intros by fastforce
  qed
qed

lemma ns_in_parent_ns[simp]: "ns_in_ns x (Identifier y) \<Longrightarrow> ns_in_ns x (ns y)"
proof (induct x)
  case Root
  then show ?case
    by simp
next
  case (Identifier x)
  then show ?case
    using fsts.intros ns_def ns_in_ns.simps(2)
    by metis
qed

lemma ns_extend_in_ns[simp]: "ns_in_ns (fst x) y \<Longrightarrow> ns_in_ns (Identifier x) y"
proof (induct x)
  case (Pair a b)
  then show ?case
  proof (induct a)
    case Root
    then show ?case
      by auto
  next
    case (Identifier x)
    then show ?case
      by simp
  qed
qed

lemma ns_not_in_itself[simp]: "\<not>ns_in_ns x x"
proof (induct x)
  case Root
  then show ?case
    by simp
next
  case (Identifier x)
  then show ?case
    using fsts.simps ns_def ns_in_ns.simps(2) ns_in_parent_ns
    by metis
qed

definition id_in_ns :: "('nt) Id \<Rightarrow> ('nt) Namespace \<Rightarrow> bool" where
  "id_in_ns identifier \<equiv> ns_in_ns (Identifier identifier)"

lemma id_in_root_alt[simp]: "id_in_ns x \<bottom>"
  unfolding id_in_ns_def
  by (fact identifier_in_root)

lemma id_in_parent_ns[simp]: "id_in_ns x (Identifier y) \<Longrightarrow> id_in_ns x (ns y)"
  unfolding id_in_ns_def
  by (fact ns_in_parent_ns)

lemma id_extend_in_ns[simp]: "id_in_ns x y \<Longrightarrow> id_in_ns (x\<^enum>b) y"
  unfolding id_in_ns_def
  by simp

lemma id_not_in_ns_itself[simp]: "\<not>id_in_ns x (Identifier x)"
  unfolding id_in_ns_def
  by simp

end


(*  Title:      HOL/Nitpick_Examples/Integer_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2012

Examples featuring Nitpick applied to natural numbers and integers.
*)

section \<open>Examples Featuring Nitpick Applied to Natural Numbers and Integers\<close>

theory Integer_Nits
imports Main
begin

nitpick_params [verbose, card = 1-5, bits = 1,2,3,4,6,
                sat_solver = MiniSat, max_threads = 1, timeout = 240]

lemma "Suc x = x + 1"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x < Suc x"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x + y \<ge> (x::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "y \<noteq> 0 \<Longrightarrow> x + y > (x::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x + y = y + (x::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x > y \<Longrightarrow> x - y \<noteq> (0::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x \<le> y \<Longrightarrow> x - y = (0::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x - (0::nat) = x"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<noteq> (0::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "0 * y = (0::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "y * 0 = (0::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (x::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (y::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x * y div y = (x::nat)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "y \<noteq> 0 \<Longrightarrow> x * y div y = (x::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "5 * 55 < (260::nat)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
nitpick [binary_ints, bits = 9, expect = genuine]
oops

lemma "nat (of_nat n) = n"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x + y \<ge> (x::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "\<lbrakk>x \<ge> 0; y \<ge> 0\<rbrakk> \<Longrightarrow> x + y \<ge> (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "y \<ge> 0 \<Longrightarrow> x + y \<ge> (x::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x \<ge> 0 \<Longrightarrow> x + y \<ge> (y::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x \<ge> 0 \<Longrightarrow> x + y \<ge> (x::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "\<lbrakk>x \<le> 0; y \<le> 0\<rbrakk> \<Longrightarrow> x + y \<le> (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "y \<noteq> 0 \<Longrightarrow> x + y > (x::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "x + y = y + (x::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x > y \<Longrightarrow> x - y \<noteq> (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "x \<le> y \<Longrightarrow> x - y = (0::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "x - (0::int) = x"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<noteq> (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "0 * y = (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "y * 0 = (0::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (x::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> x * y \<ge> (y::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "x * y div y = (x::int)"
nitpick [unary_ints, expect = genuine]
nitpick [binary_ints, expect = genuine]
oops

lemma "y \<noteq> 0 \<Longrightarrow> x * y div y = (x::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, card = 1-4, bits = 1-4, expect = none]
sorry

lemma "(x * y < 0) \<longleftrightarrow> (x > 0 \<and> y < 0) \<or> (x < 0 \<and> y > (0::int))"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

lemma "-5 * 55 > (-260::int)"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
nitpick [binary_ints, bits = 9, expect = genuine]
oops

lemma "nat (of_nat n) = n"
nitpick [unary_ints, expect = none]
nitpick [binary_ints, expect = none]
sorry

datatype tree = Null | Node nat tree tree

primrec labels where
"labels Null = {}" |
"labels (Node x t u) = {x} \<union> labels t \<union> labels u"

lemma "labels (Node x t u) \<noteq> labels (Node y v w)"
nitpick [expect = potential] (* unfortunate *)
oops

lemma "labels (Node x t u) \<noteq> {}"
nitpick [expect = none]
oops

lemma "card (labels t) > 0"
nitpick [expect = potential] (* unfortunate *)
oops

lemma "(\<Sum>n \<in> labels t. n + 2) \<ge> 2"
nitpick [expect = potential] (* unfortunate *)
oops

lemma "t \<noteq> Null \<Longrightarrow> (\<Sum>n \<in> labels t. n + 2) \<ge> 2"
nitpick [expect = potential] (* unfortunate *)
sorry

lemma "(\<Sum>i \<in> labels (Node x t u). f i::nat) = f x + (\<Sum>i \<in> labels t. f i) + (\<Sum>i \<in> labels u. f i)"
nitpick [expect = potential] (* unfortunate *)
oops

end