theory Locality
  imports Sets PredicateTransformers
begin

no_notation
  one_class.one ("1") and
  times (infixl "*" 70)

notation pmult (infixl "*" 80)

section {* Locality *}

text {*
  Calcagno and O'Hearn define locality as state transformers f where \<forall>x y. f(x * y) \<le> f x * {y}
*}

definition local_stran :: "('a :: partial_semigroup \<Rightarrow> 'a set) \<Rightarrow> bool" where
  "local_stran f \<equiv> \<forall>x y. f(x * y) \<le> f x * {y}"

text {*
  The Hoare triple can be defined in terms of state transformers
*}

definition ht_stran :: "'a set \<Rightarrow> ('a :: partial_semigroup \<Rightarrow> 'a set) \<Rightarrow> 'a set \<Rightarrow> bool" ("\<turnstile> \<guillemotleft>_\<guillemotright> _ \<guillemotleft>_\<guillemotright>") where
  "\<turnstile> \<guillemotleft>p\<guillemotright> f \<guillemotleft>q\<guillemotright> \<equiv> \<forall>x \<in> p. f x \<le> q"

text {*
  Locality suffices to prove the frame rule
*}

lemma frame_sl_stran: "\<lbrakk>local_stran f; \<turnstile> \<guillemotleft>p\<guillemotright> f \<guillemotleft>q\<guillemotright>\<rbrakk> \<Longrightarrow> \<turnstile> \<guillemotleft>p * r\<guillemotright> f \<guillemotleft>q * r\<guillemotright>"
proof (simp add: ht_stran_def, default)
  fix x :: 'a assume assms: "local_stran f" "\<forall>x \<in> p. f x \<le> q" "x \<in> p * r"
  then obtain y z where yz: "x = y * z \<and> y \<in> p \<and> z \<in> r"
    by (auto simp add: pmult_set_def)
  have "f (y * z) \<le> f y * {z}"
    by (metis assms(1) local_stran_def)
  also have "... \<le> f y * r"
    by (metis Sup_pmult.Sup.qisol empty_subsetI insert_subset yz)
  also have "... \<le> q * r"
    by (metis Sup_pmult.Sup.qisor assms(2) yz)
  finally show "f x \<subseteq> q * r"
    by (metis yz)
qed

text {*
  Locality can be defined for predicate transformers
*}

definition local_ptran :: "('a :: partial_semigroup set \<Rightarrow> 'a set) \<Rightarrow> bool" where
  "local_ptran F \<equiv> \<forall>x y. (F x) * y \<le> F (x * y)"

text {*
  Locality for predicate transformers is weaker than the one for state transformers
  Maybe that's why Calgano has a top element?
*}

(* Liftins state transformers to predicate transformers*)
definition stran :: "'a rel \<Rightarrow> 'a :: partial_semigroup \<Rightarrow> 'a set" where
  "stran R \<equiv> \<lambda>a. {b. (a, b) \<in> R}"

definition ptran :: "('a :: partial_semigroup \<Rightarrow> 'a set) \<Rightarrow> ('a set \<Rightarrow> 'a set)" where
  "ptran f \<equiv> \<lambda>Y. {x. f x \<subseteq> Y}"

definition ptran_forward :: "('a :: partial_semigroup \<Rightarrow> 'a set) \<Rightarrow> ('a set \<Rightarrow> 'a set)" where
  "ptran_forward f \<equiv> \<lambda>X. \<Union> {f x | x. x \<in> X}"

lemma "ptran_forward (stran R) X \<subseteq> Y \<longleftrightarrow> X \<subseteq> ptran (stran R) Y"
  by (auto simp: ptran_forward_def ptran_def stran_def)

lemma "ptran (stran (R \<union> S)) = ptran (stran R) \<sqinter> ptran (stran S)"
  by (auto simp: stran_def ptran_def intro!: ext)

lemma "ptran (stran (R \<inter> S)) = ptran (stran R) + ptran(stran S)"
  nitpick oops

lemma "ptran (stran (R O S)) = ptran (stran R) o ptran (stran S)"
  apply (simp add: stran_def ptran_def)
  apply (rule ext)
  by auto

lemma "ptran (stran (R O S)) = (\<lambda>x.(ptran (stran R))((ptran (stran S)) x))"
  apply (simp add: stran_def ptran_def)
  apply (rule ext)
  by auto

lemma local_stran_ptran: "local_stran f \<Longrightarrow> local_ptran (ptran f)"
proof (simp add: local_ptran_def, rule allI, rule allI, safe)
  fix x x' X Y
  assume assms: "local_stran f"  "x \<in> ptran f X * Y" "x' \<in> f x"
  then obtain y z :: 'a where yz: "x = y * z \<and> y ## z \<and> f y \<le> X \<and> z \<in> Y"
    by (auto simp: pmult_set_def)
  from assms and this have "f x \<le> (f y) * {z}"
    by (simp add: pmult_set_def local_stran_def)
  also have "... \<le> X * Y" using yz
    by (metis (erased, hide_lams) Sup.order_trans Sup_pmult.Sup.qisol Sup_pmult.Sup.qisor empty_subsetI insert_subset)
  finally show "x' \<in> X * Y" using assms by auto
qed

lemma "local_ptran (ptran f) \<Longrightarrow> local_stran f"
  nitpick oops

lemma "local_ptran (ptran f) \<Longrightarrow> x ## y \<Longrightarrow> f(x * y) \<le> f x * {y}"
proof -
  assume ptran: "local_ptran (ptran f)" and defined: "x ## y"
  have "\<And>Z. (f x * {y} \<le> Z) = (\<exists>X. X * {y} \<le> Z \<and> f x \<le> X)"
    by (auto simp: pmult_set_def)
  also have "\<And>Z. (\<exists>X. X * {y} \<le> Z \<and> f x \<le> X) = (\<exists>X. X * {y} \<le> Z \<and> x \<in> (ptran f) X)"
    by auto
  also have  "\<And>Z.(\<exists>X. X * {y} \<le> Z \<and> x \<in> (ptran f) X) \<le> (\<exists>X. X * {y} \<le> Z \<and> x * y \<in> (ptran f) X * {y})"
    using defined by (auto simp: pmult_set_def)
  also have  "\<And>Z.(\<exists>X. X * {y} \<le> Z \<and> x * y \<in> (ptran f) X * {y}) \<le> (\<exists>X. X * {y} \<le> Z \<and> x * y \<in> (ptran f) (X * {y}))"
    using ptran by (force simp: local_ptran_def)
  also have  "\<And>Z.(\<exists>X. X * {y} \<le> Z \<and> x * y \<in> (ptran f) (X * {y})) = (\<exists>X. X * {y} \<le> Z \<and> f (x * y) \<le> X * {y})"
    by auto
  also have  "\<And>Z.(\<exists>X. X * {y} \<le> Z \<and> f (x * y) \<le> X * {y}) \<le> (f (x * y) \<le> Z)"
    by auto
  finally show ?thesis
    by simp
qed

lemma "local_ptran (ptran f) \<Longrightarrow> x ## y \<Longrightarrow> f(x * y) \<le> f x * {y}"
proof -
  fix Z
  assume ptran: "local_ptran (ptran f)" and defined: "x ## y"
  have "(f x * {y} \<le> Z) = (\<exists>X. X * {y} \<le> Z \<and> f x \<le> X)"
    by (auto simp: pmult_set_def)
  also have "... = (\<exists>X. X * {y} \<le> Z \<and> x \<in> (ptran f) X)"
    by auto
  also have  "... \<le> (\<exists>X. X * {y} \<le> Z \<and> x * y \<in> (ptran f) X * {y})"
    using defined by (auto simp: pmult_set_def)
  also have  "... \<le> (\<exists>X. X * {y} \<le> Z \<and> x * y \<in> (ptran f) (X * {y}))"
    using ptran by (force simp: local_ptran_def)
  also have  "... = (\<exists>X. X * {y} \<le> Z \<and> f (x * y) \<le> X * {y})"
    by auto
  also have  "... \<le> (f (x * y) \<le> Z)"
    by auto
  finally show ?thesis
    apply simp
    apply default
    sorry
qed

text {*
  Locality defined for predicate transforemrs is equivalent to F * id \<le> F
*}

(* It needs to prove that predicate transformers form a partial quantale (which it is obvious) *)

definition local :: "('a :: partial_semigroup \<Rightarrow> 'a set) \<Rightarrow> bool" where
  "local F \<equiv> F \<cdot> id \<le> F"

lemma local_ptran_eq1: "local_ptran F \<Longrightarrow> local F"
proof (simp add: local_def, rule le_funI)
  fix x assume "local_ptran F"
  hence "\<forall>y z. x = y * z \<longrightarrow> (F y) * z \<le> F x"
    by (auto simp: local_ptran_def)
  moreover have "(F * id) x = \<Squnion> {F y * id z | y z. x = y * z}"
    by simp
  ultimately show "(F * id) x \<le> F x"
    by auto
qed

lemma local_ptran_eq2: "local F \<Longrightarrow> local_ptran F"
proof (simp add: local_ptran_def local_def, default, default)
  fix y z assume assms: "F * id \<le> F"
  obtain x :: "'a set" where xyz: "x = y * z" by simp
  have "F y * z \<le> \<Squnion> {F y * z | y z. x = y * z}" using xyz
    by (auto intro: Sup_upper)
  also have "... = (F * id) x"
    by simp
  also have "... \<le> F x"
    by (metis assms le_funD)
  finally show "F y * z \<le> F (y * z)"
    by (metis xyz)
qed

theorem local_ptran_eq: "local_ptran F = local F"
  by (metis local_ptran_eq1 local_ptran_eq2)

lemma local_ptran: "local F \<Longrightarrow> F x * y \<le> F (x * y)"
  by (metis local_ptran_def local_ptran_eq2)

end


theory Indexed_FSet
imports
  "~~/src/HOL/Library/FSet"
begin

text \<open>It is convenient to address the members of a finite set by a natural number, and
also to convert a finite set to a list.\<close>

context includes fset.lifting
begin
lift_definition fset_from_list :: "'a list => 'a fset" is set by (rule finite_set)
lemma mem_fset_from_list[simp]: "x |\<in>| fset_from_list l  \<longleftrightarrow> x \<in> set l" by transfer rule
lemma fimage_fset_from_list[simp]: "f |`| fset_from_list l = fset_from_list (map f l)"  by transfer auto
lemma fset_fset_from_list[simp]: "fset (fset_from_list l) = set l"  by transfer auto
lemmas fset_simps[simp] = set_simps[Transfer.transferred]
lemma size_fset_from_list[simp]: "distinct l \<Longrightarrow> size (fset_from_list l) = length l"
  by (induction l) auto

definition list_of_fset :: "'a fset \<Rightarrow> 'a list" where
  "list_of_fset s = (SOME l. fset_from_list l = s \<and> distinct l)"

lemma fset_from_list_of_fset[simp]: "fset_from_list (list_of_fset s) = s"
  and distinct_list_of_fset[simp]: "distinct (list_of_fset s)"
  unfolding atomize_conj list_of_fset_def
  by (transfer, rule someI_ex, rule finite_distinct_list)

lemma length_list_of_fset[simp]: "length (list_of_fset s) = size s"
  by (metis distinct_list_of_fset fset_from_list_of_fset size_fset_from_list)

lemma nth_list_of_fset_mem[simp]: "i < size s \<Longrightarrow> list_of_fset s ! i |\<in>| s"
  by (metis fset_from_list_of_fset length_list_of_fset mem_fset_from_list nth_mem)

inductive indexed_fmember :: "'a \<Rightarrow> nat \<Rightarrow> 'a fset \<Rightarrow> bool" ("_ |\<in>|\<^bsub>_\<^esub> _" [50,50,50] 50 ) where
  "i < size s \<Longrightarrow> list_of_fset s ! i |\<in>|\<^bsub>i\<^esub> s"

lemma indexed_fmember_is_fmember: "x |\<in>|\<^bsub>i\<^esub> s \<Longrightarrow> x |\<in>| s"
proof (induction rule: indexed_fmember.induct)
case (goal1 i s)
   hence "i < length (list_of_fset s)" by (metis length_list_of_fset)
   hence "list_of_fset s ! i \<in> set (list_of_fset s)" by (rule nth_mem)
   thus "list_of_fset s ! i |\<in>| s" by (metis mem_fset_from_list fset_from_list_of_fset)
qed

lemma fmember_is_indexed_fmember:
  assumes "x |\<in>| s"
  shows "\<exists>i. x |\<in>|\<^bsub>i\<^esub> s"
proof-
  from assms
  have "x \<in> set (list_of_fset s)" using mem_fset_from_list by fastforce
  then obtain i where "i < length (list_of_fset s)" and "x = list_of_fset s ! i" by (metis in_set_conv_nth)
  hence "x |\<in>|\<^bsub>i\<^esub> s"  by (simp add: indexed_fmember.simps)
  thus ?thesis..
qed

lemma indexed_fmember_unique: "x |\<in>|\<^bsub>i\<^esub> s \<Longrightarrow> y |\<in>|\<^bsub>j\<^esub> s \<Longrightarrow> x = y \<longleftrightarrow> i = j"
  by (metis distinct_list_of_fset indexed_fmember.cases length_list_of_fset nth_eq_iff_index_eq)

definition indexed_members :: "'a fset \<Rightarrow> (nat \<times> 'a) list" where
  "indexed_members s = zip [0..<size s] (list_of_fset s)"

lemma mem_set_indexed_members:
  "(i,x) \<in> set (indexed_members s) \<longleftrightarrow> x |\<in>|\<^bsub>i\<^esub> s"
  unfolding indexed_members_def indexed_fmember.simps
  by (force simp add: set_zip)

lemma mem_set_indexed_members'[simp]:
  "t \<in> set (indexed_members s) \<longleftrightarrow> snd t |\<in>|\<^bsub>fst t\<^esub> s"
  by (cases t, simp add: mem_set_indexed_members)

definition fnth (infixl "|!|" 100)  where
  "s |!| n = list_of_fset s ! n"
lemma fnth_indexed_fmember: "i < size s \<Longrightarrow> s |!| i |\<in>|\<^bsub>i\<^esub> s"
  unfolding fnth_def by (rule indexed_fmember.intros)
lemma indexed_fmember_fnth: "x |\<in>|\<^bsub>i\<^esub> s \<longleftrightarrow> (s |!| i = x \<and> i < size s)"
 unfolding fnth_def by (metis indexed_fmember.simps)
end

definition fidx :: "'a fset \<Rightarrow> 'a \<Rightarrow> nat" where
  "fidx s x = (SOME i. x |\<in>|\<^bsub>i\<^esub> s)"

lemma fidx_eq[simp]: "x |\<in>|\<^bsub>i\<^esub> s \<Longrightarrow> fidx s x = i"
  unfolding fidx_def
  by (rule someI2)(auto simp add: indexed_fmember_fnth fnth_def nth_eq_iff_index_eq)

lemma fidx_inj[simp]: "x |\<in>| s \<Longrightarrow> y |\<in>| s \<Longrightarrow> fidx s x = fidx s y \<longleftrightarrow> x = y"
  by (auto dest!: fmember_is_indexed_fmember simp add: indexed_fmember_unique)

lemma inj_on_fidx: "inj_on (fidx vertices) (fset vertices)"
  by (rule inj_onI) (auto simp: fmember.rep_eq [symmetric])

end


(* Author: Alexander Maletzky *)

section \<open>Utilities\<close>

theory General_Utils
  imports Polynomials.Utils Dube_Prelims
begin

lemma image_image_Collect: "f ` {g x | x. P x} = {f (g x) | x. P x}"
  by auto

subsection \<open>Sums\<close>

lemma sum_head_int: "a \<le> (b::int) \<Longrightarrow> sum f {a..b} = f a + sum f {a + 1..b}"
  by (smt atLeastAtMost_iff finite_atLeastAtMost_int simp_from_to sum.insert)

lemma sum_tail_int: "a \<le> (b::int) \<Longrightarrow> sum f {a..b} = f b + sum f {a..b - 1}"
  by (smt Icc_eq_Icc atLeastAtMostPlus1_int_conv finite_atLeastAtMost_int insert_absorb sum.insert)

lemma sum_nat_int_conv: "sum f {a..b} = (\<Sum>i=int a..int b. f (nat i))"
  by (metis (mono_tags, lifting) comp_def nat_int sum.atLeast_int_atMost_int_shift sum.cong)

lemma sum_int_nat_conv: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> sum f {a..b} = (\<Sum>i=nat a..nat b. f (int i))"
  by (smt imageE image_int_atLeastAtMost int_nat_eq nat_int sum.cong sum_nat_int_conv)

lemma sum_int_nat_conv': "0 < a \<Longrightarrow> sum f {a..b} = (\<Sum>i=nat a..nat b. f (int i))"
  by (smt atLeastAtMost_iff nat_0_iff sum.cong sum.not_neutral_contains_not_neutral sum_int_nat_conv)

subsection \<open>Lists\<close>

lemma length_le_1:
  assumes "length xs \<le> 1" and "x \<in> set xs" and "y \<in> set xs"
  shows "x = y"
proof (cases xs)
  case Nil
  with assms(2) show ?thesis by simp
next
  case (Cons z zs)
  with assms(1) have "zs = []" by simp
  with Cons assms(2, 3) show ?thesis by simp
qed

subsubsection \<open>@{const last}\<close>

lemma last_take_conv_nth: "n < length xs \<Longrightarrow> last (take (Suc n) xs) = xs ! n"
  by (simp add: take_Suc_conv_app_nth)

subsubsection \<open>@{const map_of}\<close>

lemma map_of_filter: "map_of (filter (\<lambda>x. fst x = y) xs) y = map_of xs y"
  by (induct xs, auto)

lemma map_of_remdups_wrt: "map_of (remdups_wrt fst (rev xs)) = map_of xs"
proof (induct xs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  have "dom [fst x \<mapsto> snd x] \<inter> dom (map_of [a\<leftarrow>remdups_wrt fst (rev xs) . fst a \<noteq> fst x]) = {}"
    by (auto simp add: dom_map_of_conv_image_fst)
  hence eq: "[fst x \<mapsto> snd x] ++ map_of [a\<leftarrow>remdups_wrt fst (rev xs) . fst a \<noteq> fst x] =
          map_of [a\<leftarrow>remdups_wrt fst (rev xs) . fst a \<noteq> fst x] ++ [fst x \<mapsto> snd x]"
    by (rule map_add_comm)
  show ?case
  proof (simp add: remdups_wrt_append eq, rule, simp, rule)
    fix y
    assume "y \<noteq> fst x"
    have *: "filter (\<lambda>x. fst x = y) (remdups_wrt fst (rev xs)) =
          filter (\<lambda>x. fst x = y) (filter (\<lambda>a. fst a \<noteq> fst x) (remdups_wrt fst (rev xs)))"
      by (simp, rule filter_cong, auto simp add: \<open>y \<noteq> fst x\<close>)
    have "map_of xs y = map_of (remdups_wrt fst (rev xs)) y" by (simp only: Cons)
    also have "... = map_of (filter (\<lambda>x. fst x = y) (remdups_wrt fst (rev xs))) y"
      by (rule map_of_filter[symmetric])
    also have "... = map_of (filter (\<lambda>x. fst x = y) (filter (\<lambda>a. fst a \<noteq> fst x) (remdups_wrt fst (rev xs)))) y"
      by (simp only: *)
    also have "... = map_of [a\<leftarrow>remdups_wrt fst (rev xs) . fst a \<noteq> fst x] y" by (rule map_of_filter)
    finally show "map_of [a\<leftarrow>remdups_wrt fst (rev xs) . fst a \<noteq> fst x] y = map_of xs y" by (simp only:)
  qed
qed

subsubsection \<open>@{const sorted_wrt}\<close>

lemma sorted_wrt_cong_strong:
  assumes "sorted_wrt P xs" and "map f xs = map f' ys"
    and "\<And>x1 x2 y1 y2. x1 \<in> set xs \<Longrightarrow> x2 \<in> set xs \<Longrightarrow> y1 \<in> set ys \<Longrightarrow> y2 \<in> set ys \<Longrightarrow>
            f x1 = f' y1 \<Longrightarrow> f x2 = f' y2 \<Longrightarrow> P x1 x2 = Q y1 y2"
  shows "sorted_wrt Q ys"
  using assms
proof (induct xs arbitrary: ys)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  from Cons(2) have "sorted_wrt P xs" and 0: "Ball (set xs) (P x)" by simp_all
  from Cons(3) obtain y ys' where ys: "ys = y # ys'" and 1: "f x = f' y" and 2: "map f xs = map f' ys'"
    by auto
  from \<open>sorted_wrt P xs\<close> 2 have "sorted_wrt Q ys'"
  proof (rule Cons(1))
    fix a1 a2 b1 b2
    assume "a1 \<in> set xs" and "a2 \<in> set xs" and "b1 \<in> set ys'" and "b2 \<in> set ys'"
    hence "a1 \<in> set (x # xs)" and "a2 \<in> set (x # xs)" and "b1 \<in> set ys" and "b2 \<in> set ys"
      by (simp_all add: ys)
    moreover assume "f a1 = f' b1" and "f a2 = f' b2"
    ultimately show "P a1 a2 = Q b1 b2" by (rule Cons(4))
  qed
  moreover have "Ball (set ys') (Q y)"
  proof
    fix b
    assume "b \<in> set ys'"
    hence "f' b \<in> f' ` set ys'" by (rule imageI)
    also have "... = set (map f' ys')" by simp
    also have "... = set (map f xs)" by (simp only: 2)
    also have "... = f ` set xs" by simp
    finally obtain a where "a \<in> set xs" and "f' b = f a" ..
    from 0 this(1) have "P x a" ..
    also have "P x a = Q y b" by (rule Cons(4), simp_all add: \<open>a \<in> set xs\<close> \<open>b \<in> set ys'\<close> ys 1 \<open>f' b = f a\<close>)
    finally show "Q y b" .
  qed
  ultimately show ?case by (simp add: ys)
qed

subsubsection \<open>@{const insort_wrt} and @{const merge_wrt}\<close>

lemma insort_wrt_cong:
  assumes "f y = f y'" and "map f xs = map f xs'" and "\<And>x x'. f x = f x' \<Longrightarrow> r y x \<longleftrightarrow> r y' x'"
  shows "map f (insort_wrt r y xs) = map f (insort_wrt r y' xs')"
  using assms(2)
proof (induct xs arbitrary: xs')
  case Nil
  from Nil have "xs' = []" by simp
  with assms(1) show ?case by simp
next
  case (Cons x xs)
  from Cons(2) obtain x' xs0 where xs': "xs' = x' # xs0" and eq1: "f x = f x'" and eq2: "map f xs = map f xs0"
    by auto
  from this(3) have eq3: "map f (insort_wrt r y xs) = map f (insort_wrt r y' xs0)" by (rule Cons(1))
  from \<open>f x = f x'\<close> have eq4: "r y x \<longleftrightarrow> r y' x'" by (rule assms(3))
  show ?case by (simp add: xs' eq1 eq2 eq3 eq4 assms(1))
qed

lemma merge_wrt_cong:
  assumes "map f xs = map f xs'" and "map f ys = map f ys'" and "set xs \<inter> set ys = {}"
    and "set xs' \<inter> set ys' = {}"
    and "\<And>x x' y y'. f x = f x' \<Longrightarrow> f y = f y' \<Longrightarrow> r x y \<longleftrightarrow> r x' y'"
  shows "map f (merge_wrt r xs ys) = map f (merge_wrt r xs' ys')"
  using assms
proof (induct r xs ys arbitrary: xs' ys' rule: merge_wrt.induct)
  case (1 uu xs)
  from 1(2) have "ys' = []" by simp
  with 1(1) show ?case by simp
next
  case (2 rel y ys)
  from 2(1) have "xs' = []" by simp
  from 2(2) obtain y' ys0 where "ys' = y' # ys0" and "f y = f y'" and "map f ys = map f ys0"
    by auto
  with \<open>xs' = []\<close> show ?case by simp
next
  case (3 rel x xs y ys)
  from 3(6) have "x \<noteq> y" and 1: "set xs \<inter> set (y # ys) = {}"
    and 2: "set (x # xs) \<inter> set ys = {}" and 4: "set xs \<inter> set ys = {}" by auto
  from 3(4) obtain x' xs0 where xs': "xs' = x' # xs0" and eq1: "f x = f x'" and eq2: "map f xs = map f xs0"
    by auto
  from 3(5) obtain y' ys0 where ys': "ys' = y' # ys0" and eq3: "f y = f y'" and eq4: "map f ys = map f ys0"
    by auto
  from 3(7) have "x' \<noteq> y'" and 5: "set xs0 \<inter> set ys' = {}" and 6: "set xs' \<inter> set ys0 = {}"
    by (auto simp: xs' ys')
  from eq1 eq3 have eq5: "rel x y \<longleftrightarrow> rel x' y'" by (rule 3(8))
  have eq7: "map f (merge_wrt rel xs (y # ys)) = map f (merge_wrt rel xs0 ys')"
    if "rel x y" using \<open>x \<noteq> y\<close> that eq2 3(5) 1 5 3(8) by (rule 3(2))
  have eq8: "map f (merge_wrt rel (x # xs) ys) = map f (merge_wrt rel xs' ys0)"
    if "\<not> rel x y" using \<open>x \<noteq> y\<close> that 3(4) eq4 2 6 3(8) by (rule 3(3))
  show ?case by (simp add: xs' ys' eq5 eq1 eq2 eq3 eq4 eq7 eq8 \<open>x \<noteq> y\<close> \<open>x' \<noteq> y'\<close>)
qed

subsubsection \<open>@{const map}\<close>

lemma map_cong_strong:
  assumes "map f xs = map f' ys" and "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> f x = f' y \<Longrightarrow> g x = g' y"
  shows "map g xs = map g' ys"
  using assms
proof (induct xs arbitrary: ys)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  from Cons(2) obtain y ys' where ys: "ys = y # ys'" and 1: "f x = f' y" and 2: "map f xs = map f' ys'"
    by auto
  have "g x = g' y" by (rule Cons(3), simp_all add: ys 1)
  moreover from 2 have "map g xs = map g' ys'"
  proof (rule Cons(1))
    fix a b
    assume "a \<in> set xs" and "b \<in> set ys'"
    hence "a \<in> set (x # xs)" and "b \<in> set ys" by (simp_all add: ys)
    moreover assume "f a = f' b"
    ultimately show "g a = g' b" by (rule Cons(3))
  qed
  ultimately show ?case by (simp add: ys)
qed

end (* theory *)


section \<open> Relational Operational Semantics \<close>

theory utp_rel_opsem
  imports
    utp_rel_laws
    utp_hoare
begin

text \<open> This theory uses the laws of relational calculus to create a basic operational semantics.
  It is based on Chapter 10 of the UTP book~\<^cite>\<open>"Hoare&98"\<close>. \<close>

fun trel :: "'\<alpha> usubst \<times> '\<alpha> hrel \<Rightarrow> '\<alpha> usubst \<times> '\<alpha> hrel \<Rightarrow> bool" (infix "\<rightarrow>\<^sub>u" 85) where
"(\<sigma>, P) \<rightarrow>\<^sub>u (\<rho>, Q) \<longleftrightarrow> (\<langle>\<sigma>\<rangle>\<^sub>a ;; P) \<sqsubseteq> (\<langle>\<rho>\<rangle>\<^sub>a ;; Q)"

lemma trans_trel:
  "\<lbrakk> (\<sigma>, P) \<rightarrow>\<^sub>u (\<rho>, Q); (\<rho>, Q) \<rightarrow>\<^sub>u (\<phi>, R) \<rbrakk> \<Longrightarrow> (\<sigma>, P) \<rightarrow>\<^sub>u (\<phi>, R)"
  by auto

lemma skip_trel: "(\<sigma>, II) \<rightarrow>\<^sub>u (\<sigma>, II)"
  by simp

lemma assigns_trel: "(\<sigma>, \<langle>\<rho>\<rangle>\<^sub>a) \<rightarrow>\<^sub>u (\<rho> \<circ> \<sigma>, II)"
  by (simp add: assigns_comp)

lemma assign_trel:
  "(\<sigma>, x := v) \<rightarrow>\<^sub>u (\<sigma>(&x \<mapsto>\<^sub>s \<sigma> \<dagger> v), II)"
  by (simp add: assigns_comp usubst)

lemma seq_trel:
  assumes "(\<sigma>, P) \<rightarrow>\<^sub>u (\<rho>, Q)"
  shows "(\<sigma>, P ;; R) \<rightarrow>\<^sub>u (\<rho>, Q ;; R)"
  by (metis (no_types, lifting) assms order_refl seqr_assoc seqr_mono trel.simps)

lemma seq_skip_trel:
  "(\<sigma>, II ;; P) \<rightarrow>\<^sub>u (\<sigma>, P)"
  by simp

lemma nondet_left_trel:
  "(\<sigma>, P \<sqinter> Q) \<rightarrow>\<^sub>u (\<sigma>, P)"
  by (metis (no_types, opaque_lifting) disj_comm disj_upred_def semilattice_sup_class.sup.absorb_iff1 semilattice_sup_class.sup.left_idem seqr_or_distr trel.simps)

lemma nondet_right_trel:
  "(\<sigma>, P \<sqinter> Q) \<rightarrow>\<^sub>u (\<sigma>, Q)"
  by (simp add: seqr_mono)

lemma rcond_true_trel:
  assumes "\<sigma> \<dagger> b = true"
  shows "(\<sigma>, P \<triangleleft> b \<triangleright>\<^sub>r Q) \<rightarrow>\<^sub>u (\<sigma>, P)"
  using assms
  by (simp add: assigns_r_comp usubst alpha cond_unit_T)

lemma rcond_false_trel:
  assumes "\<sigma> \<dagger> b = false"
  shows "(\<sigma>, P \<triangleleft> b \<triangleright>\<^sub>r Q) \<rightarrow>\<^sub>u (\<sigma>, Q)"
  using assms
  by (simp add: assigns_r_comp usubst alpha cond_unit_F)

lemma while_true_trel:
  assumes "\<sigma> \<dagger> b = true"
  shows "(\<sigma>, while b do P od) \<rightarrow>\<^sub>u (\<sigma>, P ;; while b do P od)"
  by (metis assms rcond_true_trel while_unfold)

lemma while_false_trel:
  assumes "\<sigma> \<dagger> b = false"
  shows "(\<sigma>, while b do P od) \<rightarrow>\<^sub>u (\<sigma>, II)"
  by (metis assms rcond_false_trel while_unfold)

text \<open> Theorem linking Hoare calculus and operational semantics. If we start $Q$ in a state $\sigma_0$
  satisfying $p$, and $Q$ reaches final state $\sigma_1$ then $r$ holds in this final state. \<close>

theorem hoare_opsem_link:
  "\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u = (\<forall> \<sigma>\<^sub>0 \<sigma>\<^sub>1. `\<sigma>\<^sub>0 \<dagger> p` \<and> (\<sigma>\<^sub>0, Q) \<rightarrow>\<^sub>u (\<sigma>\<^sub>1, II) \<longrightarrow> `\<sigma>\<^sub>1 \<dagger> r`)"
  apply (rel_auto)
  apply (rename_tac a b)
  apply (drule_tac x="\<lambda> _. a" in spec, simp)
  apply (drule_tac x="\<lambda> _. b" in spec, simp)
  done

declare trel.simps [simp del]

end


theory T29
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T88
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T57
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory Soft_Types
  imports Pure
begin

text \<open>
  We define a meta-type of types, which is isomorphic to Pure predicates, that is
  @{typ "'a => prop"}. Pi-types and intersections can then be introduced as definitions.

  We define some syntax translations to introduce a telescope-like syntax.
\<close>

subsection \<open> Notion of soft type \<close>

(* Just an embedding of Pure predicates into a new type, for more explicit handling.
Note the type argument: We can assign a soft type to any object in Pure, including
meta-level functions. *)
typedecl 'a type

axiomatization
  Type :: "('a \<Rightarrow> prop) \<Rightarrow> 'a type"
  and pred_of :: "'a type \<Rightarrow> 'a \<Rightarrow> prop"
  where pred_of_Type: "pred_of (Type t) \<equiv> t"

definition has_type :: "'a \<Rightarrow> 'a type \<Rightarrow> prop" (infix ":::" 40)
  where "x ::: T \<equiv> pred_of T x"

lemma has_type_Type[simp]: "x ::: Type P \<equiv> P x"
  unfolding has_type_def pred_of_Type .

subsection \<open> Pi-Types \<close>

definition Pi_type :: "'a type \<Rightarrow> ('a \<Rightarrow> 'b type) \<Rightarrow> ('a \<Rightarrow> 'b) type"
  where
  "Pi_type \<sigma> \<tau> \<equiv> Type (\<lambda>f. (\<And>x. x ::: \<sigma> \<Longrightarrow> f x ::: \<tau> x))"

syntax
  "_telescope" :: "[pttrn, 'a type, 'b type] \<Rightarrow> 'c type"  ("'(_ : _') \<Rightarrow> _" 50)
translations
  "(x : A) \<Rightarrow> B" \<rightleftharpoons> "CONST Pi_type A (\<lambda>x. B)"

term "(x : A) \<Rightarrow> (y : B) \<Rightarrow> C y"

lemma Pi_typeI:
  assumes a: "\<And>x. x ::: A \<Longrightarrow> f x ::: B x"
  shows "f ::: (x:A) \<Rightarrow> B x"
  unfolding Pi_type_def has_type_Type
  by (rule a)

lemma Pi_typeE:
  assumes 1: "f ::: (x: A) \<Rightarrow> B x"
  assumes 2: "x ::: A"
  shows "f x ::: B x"
proof -
  from 2
  show "PROP ?thesis"
    by (rule 1[unfolded Pi_type_def has_type_Type, rule_format])
qed

subsection \<open> Intersections \<close>

definition Int_Type :: "'a type \<Rightarrow> 'a type \<Rightarrow> 'a type" (infixl "\<bar>" 100)
where "A \<bar> B \<equiv> Type (\<lambda>x. (x ::: A &&& x ::: B))"

lemma Int_TypeI:
  "x ::: A \<Longrightarrow> x ::: B \<Longrightarrow> x ::: A \<bar> B"
  unfolding Int_Type_def has_type_Type
  by (rule conjunctionI)

lemma Int_TypeD1:
  "x ::: A \<bar> B \<Longrightarrow> x ::: A"
  unfolding Int_Type_def has_type_Type
  by (rule conjunctionD1)

lemma Int_TypeD2:
  "x ::: A \<bar> B \<Longrightarrow> x ::: B"
  unfolding Int_Type_def has_type_Type
  by (rule conjunctionD2)

subsection \<open> Tooling \<close>

ML_file "soft_type.ML"
ML_file "soft_type_context.ML"
ML_file "soft_type_inference.ML"

end


(*  Title:      Inductive definition of termination
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)
theory PsTermi imports PsLang begin

subsection\<open>Termination\<close>

inductive
  termi :: "com \<Rightarrow> state \<Rightarrow> bool" (infixl "\<down>" 50)
where
    Do[iff]: "f s \<noteq> {} \<Longrightarrow> Do f \<down> s"
  | Semi[intro!]:   "\<lbrakk> c1 \<down> s0; \<And>s1. s0 -c1\<rightarrow> s1 \<Longrightarrow> c2 \<down> s1 \<rbrakk>
            \<Longrightarrow> (c1;c2) \<down> s0"

  | IfTrue[intro,simp]: "\<lbrakk> b s; c1 \<down> s \<rbrakk> \<Longrightarrow> IF b THEN c1 ELSE c2 \<down> s"
  | IfFalse[intro,simp]: "\<lbrakk> \<not>b s; c2 \<down> s \<rbrakk> \<Longrightarrow> IF b THEN c1 ELSE c2 \<down> s"

  | WhileFalse: "\<not>b s \<Longrightarrow> WHILE b DO c \<down> s"

  | WhileTrue:  "\<lbrakk> b s; c \<down> s; \<And>t. s -c\<rightarrow> t \<Longrightarrow> WHILE b DO c \<down> t \<rbrakk>
                \<Longrightarrow> WHILE b DO c \<down> s"

  | "body p \<down> s \<Longrightarrow> CALL p \<down> s"

  | Local: "c \<down> f s \<Longrightarrow> LOCAL f;c;g \<down> s"

lemma [iff]: "((c1;c2) \<down> s0) = (c1 \<down> s0 \<and> (\<forall>s1. s0 -c1\<rightarrow> s1 \<longrightarrow> c2 \<down> s1))"
apply(rule iffI)
 prefer 2
 apply(best intro:termi.intros)
apply(erule termi.cases)
apply blast+
done

lemma [iff]: "(IF b THEN c1 ELSE c2 \<down> s) =
              ((if b s then c1 else c2) \<down> s)"
apply simp
apply(rule conjI)
apply(rule impI)
apply(rule iffI)
prefer 2
apply(blast intro:termi.intros)
apply(erule termi.cases)
apply blast+
apply(rule impI)
apply(rule iffI)
prefer 2
apply(blast intro:termi.intros)
apply(erule termi.cases)
apply blast+
done

lemma [iff]: "(CALL p \<down> s) = (body p \<down> s)"
by(fast elim: termi.cases intro:termi.intros)

lemma [iff]: "(LOCAL f;c;g \<down> s) = (c \<down> f s)"
by(fast elim: termi.cases intro:termi.intros)

lemma termi_while_lemma[rule_format]:
 "w\<down>fk \<Longrightarrow>
 (\<forall>k b c. fk = f k \<and> w = WHILE b DO c \<and> (\<forall>i. f i -c\<rightarrow> f(Suc i))
          \<longrightarrow> (\<exists>i. \<not>b(f i)))"
apply(erule termi.induct)
apply simp_all
apply blast
apply blast
done

lemma termi_while:
 "\<lbrakk> (WHILE b DO c) \<down> f k;  \<forall>i. f i -c\<rightarrow> f(Suc i) \<rbrakk> \<Longrightarrow> \<exists>i. \<not>b(f i)"
by(blast intro:termi_while_lemma)

lemma wf_termi: "wf {(t,s). WHILE b DO c \<down> s \<and> b s \<and> s -c\<rightarrow> t}"
apply(subst wf_iff_no_infinite_down_chain)
apply(rule notI)
apply clarsimp
apply(insert termi_while)
apply blast
done

end


(*  Title:      HOL/Imperative_HOL/ex/Sublist.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section {* Slices of lists *}

theory Sublist
imports "~~/src/HOL/Library/Multiset"
begin

lemma sublist_split: "i \<le> j \<and> j \<le> k \<Longrightarrow> sublist xs {i..<j} @ sublist xs {j..<k} = sublist xs {i..<k}"
apply (induct xs arbitrary: i j k)
apply simp
apply (simp only: sublist_Cons)
apply simp
apply safe
apply simp
apply (erule_tac x="0" in meta_allE)
apply (erule_tac x="j - 1" in meta_allE)
apply (erule_tac x="k - 1" in meta_allE)
apply (subgoal_tac "0 \<le> j - 1 \<and> j - 1 \<le> k - 1")
apply simp
apply (subgoal_tac "{ja. Suc ja < j} = {0..<j - Suc 0}")
apply (subgoal_tac "{ja. j \<le> Suc ja \<and> Suc ja < k} = {j - Suc 0..<k - Suc 0}")
apply (subgoal_tac "{j. Suc j < k} = {0..<k - Suc 0}")
apply simp
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply (erule_tac x="i - 1" in meta_allE)
apply (erule_tac x="j - 1" in meta_allE)
apply (erule_tac x="k - 1" in meta_allE)
apply (subgoal_tac " {ja. i \<le> Suc ja \<and> Suc ja < j} = {i - 1 ..<j - 1}")
apply (subgoal_tac " {ja. j \<le> Suc ja \<and> Suc ja < k} = {j - 1..<k - 1}")
apply (subgoal_tac "{j. i \<le> Suc j \<and> Suc j < k} = {i - 1..<k - 1}")
apply (subgoal_tac " i - 1 \<le> j - 1 \<and> j - 1 \<le> k - 1")
apply simp
apply fastforce
apply fastforce
apply fastforce
apply fastforce
done

lemma sublist_update1: "i \<notin> inds \<Longrightarrow> sublist (xs[i := v]) inds = sublist xs inds"
apply (induct xs arbitrary: i inds)
apply simp
apply (case_tac i)
apply (simp add: sublist_Cons)
apply (simp add: sublist_Cons)
done

lemma sublist_update2: "i \<in> inds \<Longrightarrow> sublist (xs[i := v]) inds = (sublist xs inds)[(card {k \<in> inds. k < i}):= v]"
proof (induct xs arbitrary: i inds)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  thus ?case
  proof (cases i)
    case 0 with Cons show ?thesis by (simp add: sublist_Cons)
  next
    case (Suc i')
    with Cons show ?thesis
      apply simp
      apply (simp add: sublist_Cons)
      apply auto
      apply (auto simp add: nat.split)
      apply (simp add: card_less_Suc[symmetric])
      apply (simp add: card_less_Suc2)
      done
  qed
qed

lemma sublist_update: "sublist (xs[i := v]) inds = (if i \<in> inds then (sublist xs inds)[(card {k \<in> inds. k < i}) := v] else sublist xs inds)"
by (simp add: sublist_update1 sublist_update2)

lemma sublist_take: "sublist xs {j. j < m} = take m xs"
apply (induct xs arbitrary: m)
apply simp
apply (case_tac m)
apply simp
apply (simp add: sublist_Cons)
done

lemma sublist_take': "sublist xs {0..<m} = take m xs"
apply (induct xs arbitrary: m)
apply simp
apply (case_tac m)
apply simp
apply (simp add: sublist_Cons sublist_take)
done

lemma sublist_all[simp]: "sublist xs {j. j < length xs} = xs"
apply (induct xs)
apply simp
apply (simp add: sublist_Cons)
done

lemma sublist_all'[simp]: "sublist xs {0..<length xs} = xs"
apply (induct xs)
apply simp
apply (simp add: sublist_Cons)
done

lemma sublist_single: "a < length xs \<Longrightarrow> sublist xs {a} = [xs ! a]"
apply (induct xs arbitrary: a)
apply simp
apply(case_tac aa)
apply simp
apply (simp add: sublist_Cons)
apply simp
apply (simp add: sublist_Cons)
done

lemma sublist_is_Nil: "\<forall>i \<in> inds. i \<ge> length xs \<Longrightarrow> sublist xs inds = []"
apply (induct xs arbitrary: inds)
apply simp
apply (simp add: sublist_Cons)
apply auto
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply auto
done

lemma sublist_Nil': "sublist xs inds = [] \<Longrightarrow> \<forall>i \<in> inds. i \<ge> length xs"
apply (induct xs arbitrary: inds)
apply simp
apply (simp add: sublist_Cons)
apply (auto split: if_splits)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (case_tac x, auto)
done

lemma sublist_Nil[simp]: "(sublist xs inds = []) = (\<forall>i \<in> inds. i \<ge> length xs)"
apply (induct xs arbitrary: inds)
apply simp
apply (simp add: sublist_Cons)
apply auto
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (case_tac x, auto)
done

lemma sublist_eq_subseteq: " \<lbrakk> inds' \<subseteq> inds; sublist xs inds = sublist ys inds \<rbrakk> \<Longrightarrow> sublist xs inds' = sublist ys inds'"
apply (induct xs arbitrary: ys inds inds')
apply simp
apply (drule sym, rule sym)
apply (simp add: sublist_Nil, fastforce)
apply (case_tac ys)
apply (simp add: sublist_Nil, fastforce)
apply (auto simp add: sublist_Cons)
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds'}" in meta_allE)
apply fastforce
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds'}" in meta_allE)
apply fastforce
done

lemma sublist_eq: "\<lbrakk> \<forall>i \<in> inds. ((i < length xs) \<and> (i < length ys)) \<or> ((i \<ge> length xs ) \<and> (i \<ge> length ys)); \<forall>i \<in> inds. xs ! i = ys ! i \<rbrakk> \<Longrightarrow> sublist xs inds = sublist ys inds"
apply (induct xs arbitrary: ys inds)
apply simp
apply (rule sym, simp add: sublist_Nil)
apply (case_tac ys)
apply (simp add: sublist_Nil)
apply (auto simp add: sublist_Cons)
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply fastforce
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply fastforce
done

lemma sublist_eq_samelength: "\<lbrakk> length xs = length ys; \<forall>i \<in> inds. xs ! i = ys ! i \<rbrakk> \<Longrightarrow> sublist xs inds = sublist ys inds"
by (rule sublist_eq, auto)

lemma sublist_eq_samelength_iff: "length xs = length ys \<Longrightarrow> (sublist xs inds = sublist ys inds) = (\<forall>i \<in> inds. xs ! i = ys ! i)"
apply (induct xs arbitrary: ys inds)
apply simp
apply (rule sym, simp add: sublist_Nil)
apply (case_tac ys)
apply (simp add: sublist_Nil)
apply (auto simp add: sublist_Cons)
apply (case_tac i)
apply auto
apply (case_tac i)
apply auto
done

section {* Another sublist function *}

function sublist' :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "sublist' n m [] = []"
| "sublist' n 0 xs = []"
| "sublist' 0 (Suc m) (x#xs) = (x#sublist' 0 m xs)"
| "sublist' (Suc n) (Suc m) (x#xs) = sublist' n m xs"
by pat_completeness auto
termination by lexicographic_order

subsection {* Proving equivalence to the other sublist command *}

lemma sublist'_sublist: "sublist' n m xs = sublist xs {j. n \<le> j \<and> j < m}"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac n)
apply (case_tac m)
apply simp
apply (simp add: sublist_Cons)
apply (case_tac m)
apply simp
apply (simp add: sublist_Cons)
done

lemma "sublist' n m xs = sublist xs {n..<m}"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac n, case_tac m)
apply simp
apply simp
apply (simp add: sublist_take')
apply (case_tac m)
apply simp
apply (simp add: sublist_Cons sublist'_sublist)
done

subsection {* Showing equivalence to use of drop and take for definition *}

lemma "sublist' n m xs = take (m - n) (drop n xs)"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

subsection {* General lemma about sublist *}

lemma sublist'_Nil[simp]: "sublist' i j [] = []"
by simp

lemma sublist'_Cons[simp]: "sublist' i (Suc j) (x#xs) = (case i of 0 \<Rightarrow> (x # sublist' 0 j xs) | Suc i' \<Rightarrow>  sublist' i' j xs)"
by (cases i) auto

lemma sublist'_Cons2[simp]: "sublist' i j (x#xs) = (if (j = 0) then [] else ((if (i = 0) then [x] else []) @ sublist' (i - 1) (j - 1) xs))"
apply (cases j)
apply auto
apply (cases i)
apply auto
done

lemma sublist_n_0: "sublist' n 0 xs = []"
by (induct xs, auto)

lemma sublist'_Nil': "n \<ge> m \<Longrightarrow> sublist' n m xs = []"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma sublist'_Nil2: "n \<ge> length xs \<Longrightarrow> sublist' n m xs = []"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma sublist'_Nil3: "(sublist' n m xs = []) = ((n \<ge> m) \<or> (n \<ge> length xs))"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma sublist'_notNil: "\<lbrakk> n < length xs; n < m \<rbrakk> \<Longrightarrow> sublist' n m xs \<noteq> []"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma sublist'_single: "n < length xs \<Longrightarrow> sublist' n (Suc n) xs = [xs ! n]"
apply (induct xs arbitrary: n)
apply simp
apply simp
apply (case_tac n)
apply (simp add: sublist_n_0)
apply simp
done

lemma sublist'_update1: "i \<ge> m \<Longrightarrow> sublist' n m (xs[i:=v]) = sublist' n m xs"
apply (induct xs arbitrary: n m i)
apply simp
apply simp
apply (case_tac i)
apply simp
apply simp
done

lemma sublist'_update2: "i < n \<Longrightarrow> sublist' n m (xs[i:=v]) = sublist' n m xs"
apply (induct xs arbitrary: n m i)
apply simp
apply simp
apply (case_tac i)
apply simp
apply simp
done

lemma sublist'_update3: "\<lbrakk>n \<le> i; i < m\<rbrakk> \<Longrightarrow> sublist' n m (xs[i := v]) = (sublist' n m xs)[i - n := v]"
proof (induct xs arbitrary: n m i)
  case Nil thus ?case by auto
next
  case (Cons x xs)
  thus ?case
    apply -
    apply auto
    apply (cases i)
    apply auto
    apply (cases i)
    apply auto
    done
qed

lemma "\<lbrakk> sublist' i j xs = sublist' i j ys; n \<ge> i; m \<le> j \<rbrakk> \<Longrightarrow> sublist' n m xs = sublist' n m ys"
proof (induct xs arbitrary: i j ys n m)
  case Nil
  thus ?case
    apply -
    apply (rule sym, drule sym)
    apply (simp add: sublist'_Nil)
    apply (simp add: sublist'_Nil3)
    apply arith
    done
next
  case (Cons x xs i j ys n m)
  note c = this
  thus ?case
  proof (cases m)
    case 0 thus ?thesis by (simp add: sublist_n_0)
  next
    case (Suc m')
    note a = this
    thus ?thesis
    proof (cases n)
      case 0 note b = this
      show ?thesis
      proof (cases ys)
        case Nil  with a b Cons.prems show ?thesis by (simp add: sublist'_Nil3)
      next
        case (Cons y ys)
        show ?thesis
        proof (cases j)
          case 0 with a b Cons.prems show ?thesis by simp
        next
          case (Suc j') with a b Cons.prems Cons show ?thesis
            apply -
            apply (simp, rule Cons.hyps [of "0" "j'" "ys" "0" "m'"], auto)
            done
        qed
      qed
    next
      case (Suc n')
      show ?thesis
      proof (cases ys)
        case Nil with Suc a Cons.prems show ?thesis by (auto simp add: sublist'_Nil3)
      next
        case (Cons y ys) with Suc a Cons.prems show ?thesis
          apply -
          apply simp
          apply (cases j)
          apply simp
          apply (cases i)
          apply simp
          apply (rule_tac j="nat" in Cons.hyps [of "0" _ "ys" "n'" "m'"])
          apply simp
          apply simp
          apply simp
          apply simp
          apply (rule_tac i="nata" and j="nat" in Cons.hyps [of _ _ "ys" "n'" "m'"])
          apply simp
          apply simp
          apply simp
          done
      qed
    qed
  qed
qed

lemma length_sublist': "j \<le> length xs \<Longrightarrow> length (sublist' i j xs) = j - i"
by (induct xs arbitrary: i j, auto)

lemma sublist'_front: "\<lbrakk> i < j; i < length xs \<rbrakk> \<Longrightarrow> sublist' i j xs = xs ! i # sublist' (Suc i) j xs"
apply (induct xs arbitrary: i j)
apply simp
apply (case_tac j)
apply simp
apply (case_tac i)
apply simp
apply simp
done

lemma sublist'_back: "\<lbrakk> i < j; j \<le> length xs \<rbrakk> \<Longrightarrow> sublist' i j xs = sublist' i (j - 1) xs @ [xs ! (j - 1)]"
apply (induct xs arbitrary: i j)
apply simp
apply simp
done

(* suffices that j \<le> length xs and length ys *)
lemma sublist'_eq_samelength_iff: "length xs = length ys \<Longrightarrow> (sublist' i j xs  = sublist' i j ys) = (\<forall>i'. i \<le> i' \<and> i' < j \<longrightarrow> xs ! i' = ys ! i')"
proof (induct xs arbitrary: ys i j)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  thus ?case
    apply -
    apply (cases ys)
    apply simp
    apply simp
    apply auto
    apply (case_tac i', auto)
    apply (erule_tac x="Suc i'" in allE, auto)
    apply (erule_tac x="i' - 1" in allE, auto)
    apply (erule_tac x="Suc i'" in allE, auto)
    done
qed

lemma sublist'_all[simp]: "sublist' 0 (length xs) xs = xs"
by (induct xs, auto)

lemma sublist'_sublist': "sublist' n m (sublist' i j xs) = sublist' (i + n) (min (i + m) j) xs"
by (induct xs arbitrary: i j n m) (auto simp add: min_diff)

lemma sublist'_append: "\<lbrakk> i \<le> j; j \<le> k \<rbrakk> \<Longrightarrow>(sublist' i j xs) @ (sublist' j k xs) = sublist' i k xs"
by (induct xs arbitrary: i j k) auto

lemma nth_sublist': "\<lbrakk> k < j - i; j \<le> length xs \<rbrakk> \<Longrightarrow> (sublist' i j xs) ! k = xs ! (i + k)"
apply (induct xs arbitrary: i j k)
apply simp
apply (case_tac k)
apply auto
done

lemma set_sublist': "set (sublist' i j xs) = {x. \<exists>k. i \<le> k \<and> k < j \<and> k < List.length xs \<and> x = xs ! k}"
apply (simp add: sublist'_sublist)
apply (simp add: set_sublist)
apply auto
done

lemma all_in_set_sublist'_conv: "(\<forall>j. j \<in> set (sublist' l r xs) \<longrightarrow> P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < List.length xs \<longrightarrow> P (xs ! k))"
unfolding set_sublist' by blast

lemma ball_in_set_sublist'_conv: "(\<forall>j \<in> set (sublist' l r xs). P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < List.length xs \<longrightarrow> P (xs ! k))"
unfolding set_sublist' by blast

lemma multiset_of_sublist:
assumes l_r: "l \<le> r \<and> r \<le> List.length xs"
assumes left: "\<forall> i. i < l \<longrightarrow> (xs::'a list) ! i = ys ! i"
assumes right: "\<forall> i. i \<ge> r \<longrightarrow> (xs::'a list) ! i = ys ! i"
assumes multiset: "multiset_of xs = multiset_of ys"
  shows "multiset_of (sublist' l r xs) = multiset_of (sublist' l r ys)"
proof -
  from l_r have xs_def: "xs = (sublist' 0 l xs) @ (sublist' l r xs) @ (sublist' r (List.length xs) xs)" (is "_ = ?xs_long")
    by (simp add: sublist'_append)
  from multiset have length_eq: "List.length xs = List.length ys" by (rule multiset_of_eq_length)
  with l_r have ys_def: "ys = (sublist' 0 l ys) @ (sublist' l r ys) @ (sublist' r (List.length ys) ys)" (is "_ = ?ys_long")
    by (simp add: sublist'_append)
  from xs_def ys_def multiset have "multiset_of ?xs_long = multiset_of ?ys_long" by simp
  moreover
  from left l_r length_eq have "sublist' 0 l xs = sublist' 0 l ys"
    by (auto simp add: length_sublist' nth_sublist' intro!: nth_equalityI)
  moreover
  from right l_r length_eq have "sublist' r (List.length xs) xs = sublist' r (List.length ys) ys"
    by (auto simp add: length_sublist' nth_sublist' intro!: nth_equalityI)
  ultimately show ?thesis by (simp add: multiset_of_append)
qed

end


(*  Title:      HOL/Meson.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Tobias Nipkow, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2001  University of Cambridge
*)

section {* MESON Proof Method *}

theory Meson
imports Nat
begin

subsection {* Negation Normal Form *}

text {* de Morgan laws *}

lemma not_conjD: "~(P&Q) ==> ~P | ~Q"
  and not_disjD: "~(P|Q) ==> ~P & ~Q"
  and not_notD: "~~P ==> P"
  and not_allD: "!!P. ~(\<forall>x. P(x)) ==> \<exists>x. ~P(x)"
  and not_exD: "!!P. ~(\<exists>x. P(x)) ==> \<forall>x. ~P(x)"
  by fast+

text {* Removal of @{text "-->"} and @{text "<->"} (positive and
negative occurrences) *}

lemma imp_to_disjD: "P-->Q ==> ~P | Q"
  and not_impD: "~(P-->Q) ==> P & ~Q"
  and iff_to_disjD: "P=Q ==> (~P | Q) & (~Q | P)"
  and not_iffD: "~(P=Q) ==> (P | Q) & (~P | ~Q)"
    -- {* Much more efficient than @{prop "(P & ~Q) | (Q & ~P)"} for computing CNF *}
  and not_refl_disj_D: "x ~= x | P ==> P"
  by fast+

subsection {* Pulling out the existential quantifiers *}

text {* Conjunction *}

lemma conj_exD1: "!!P Q. (\<exists>x. P(x)) & Q ==> \<exists>x. P(x) & Q"
  and conj_exD2: "!!P Q. P & (\<exists>x. Q(x)) ==> \<exists>x. P & Q(x)"
  by fast+

text {* Disjunction *}

lemma disj_exD: "!!P Q. (\<exists>x. P(x)) | (\<exists>x. Q(x)) ==> \<exists>x. P(x) | Q(x)"
  -- {* DO NOT USE with forall-Skolemization: makes fewer schematic variables!! *}
  -- {* With ex-Skolemization, makes fewer Skolem constants *}
  and disj_exD1: "!!P Q. (\<exists>x. P(x)) | Q ==> \<exists>x. P(x) | Q"
  and disj_exD2: "!!P Q. P | (\<exists>x. Q(x)) ==> \<exists>x. P | Q(x)"
  by fast+

lemma disj_assoc: "(P|Q)|R ==> P|(Q|R)"
  and disj_comm: "P|Q ==> Q|P"
  and disj_FalseD1: "False|P ==> P"
  and disj_FalseD2: "P|False ==> P"
  by fast+

text{* Generation of contrapositives *}

text{*Inserts negated disjunct after removing the negation; P is a literal.
  Model elimination requires assuming the negation of every attempted subgoal,
  hence the negated disjuncts.*}
lemma make_neg_rule: "~P|Q ==> ((~P==>P) ==> Q)"
by blast

text{*Version for Plaisted's "Postive refinement" of the Meson procedure*}
lemma make_refined_neg_rule: "~P|Q ==> (P ==> Q)"
by blast

text{*@{term P} should be a literal*}
lemma make_pos_rule: "P|Q ==> ((P==>~P) ==> Q)"
by blast

text{*Versions of @{text make_neg_rule} and @{text make_pos_rule} that don't
insert new assumptions, for ordinary resolution.*}

lemmas make_neg_rule' = make_refined_neg_rule

lemma make_pos_rule': "[|P|Q; ~P|] ==> Q"
by blast

text{* Generation of a goal clause -- put away the final literal *}

lemma make_neg_goal: "~P ==> ((~P==>P) ==> False)"
by blast

lemma make_pos_goal: "P ==> ((P==>~P) ==> False)"
by blast

subsection {* Lemmas for Forward Proof *}

text{*There is a similarity to congruence rules*}

(*NOTE: could handle conjunctions (faster?) by
    nf(th RS conjunct2) RS (nf(th RS conjunct1) RS conjI) *)
lemma conj_forward: "[| P'&Q';  P' ==> P;  Q' ==> Q |] ==> P&Q"
by blast

lemma disj_forward: "[| P'|Q';  P' ==> P;  Q' ==> Q |] ==> P|Q"
by blast

(*Version of @{text disj_forward} for removal of duplicate literals*)
lemma disj_forward2:
    "[| P'|Q';  P' ==> P;  [| Q'; P==>False |] ==> Q |] ==> P|Q"
apply blast
done

lemma all_forward: "[| \<forall>x. P'(x);  !!x. P'(x) ==> P(x) |] ==> \<forall>x. P(x)"
by blast

lemma ex_forward: "[| \<exists>x. P'(x);  !!x. P'(x) ==> P(x) |] ==> \<exists>x. P(x)"
by blast

subsection {* Clausification helper *}

lemma TruepropI: "P \<equiv> Q \<Longrightarrow> Trueprop P \<equiv> Trueprop Q"
by simp

lemma ext_cong_neq: "F g \<noteq> F h \<Longrightarrow> F g \<noteq> F h \<and> (\<exists>x. g x \<noteq> h x)"
apply (erule contrapos_np)
apply clarsimp
apply (rule cong[where f = F])
by auto

text{* Combinator translation helpers *}

definition COMBI :: "'a \<Rightarrow> 'a" where
"COMBI P = P"

definition COMBK :: "'a \<Rightarrow> 'b \<Rightarrow> 'a" where
"COMBK P Q = P"

definition COMBB :: "('b => 'c) \<Rightarrow> ('a => 'b) \<Rightarrow> 'a \<Rightarrow> 'c" where
"COMBB P Q R = P (Q R)"

definition COMBC :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'c" where
"COMBC P Q R = P R Q"

definition COMBS :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" where
"COMBS P Q R = P R (Q R)"

lemma abs_S: "\<lambda>x. (f x) (g x) \<equiv> COMBS f g"
apply (rule eq_reflection)
apply (rule ext)
apply (simp add: COMBS_def)
done

lemma abs_I: "\<lambda>x. x \<equiv> COMBI"
apply (rule eq_reflection)
apply (rule ext)
apply (simp add: COMBI_def)
done

lemma abs_K: "\<lambda>x. y \<equiv> COMBK y"
apply (rule eq_reflection)
apply (rule ext)
apply (simp add: COMBK_def)
done

lemma abs_B: "\<lambda>x. a (g x) \<equiv> COMBB a g"
apply (rule eq_reflection)
apply (rule ext)
apply (simp add: COMBB_def)
done

lemma abs_C: "\<lambda>x. (f x) b \<equiv> COMBC f b"
apply (rule eq_reflection)
apply (rule ext)
apply (simp add: COMBC_def)
done

subsection {* Skolemization helpers *}

definition skolem :: "'a \<Rightarrow> 'a" where
"skolem = (\<lambda>x. x)"

lemma skolem_COMBK_iff: "P \<longleftrightarrow> skolem (COMBK P (i\<Colon>nat))"
unfolding skolem_def COMBK_def by (rule refl)

lemmas skolem_COMBK_I = iffD1 [OF skolem_COMBK_iff]
lemmas skolem_COMBK_D = iffD2 [OF skolem_COMBK_iff]

subsection {* Meson package *}

ML_file "Tools/Meson/meson.ML"
ML_file "Tools/Meson/meson_clausify.ML"
ML_file "Tools/Meson/meson_tactic.ML"

hide_const (open) COMBI COMBK COMBB COMBC COMBS skolem
hide_fact (open) not_conjD not_disjD not_notD not_allD not_exD imp_to_disjD
    not_impD iff_to_disjD not_iffD not_refl_disj_D conj_exD1 conj_exD2 disj_exD
    disj_exD1 disj_exD2 disj_assoc disj_comm disj_FalseD1 disj_FalseD2 TruepropI
    ext_cong_neq COMBI_def COMBK_def COMBB_def COMBC_def COMBS_def abs_I abs_K
    abs_B abs_C abs_S skolem_def skolem_COMBK_iff skolem_COMBK_I skolem_COMBK_D

end


header {*\isaheader{Implementation of Annotated Lists by 2-3 Finger Trees}*}
theory FTAnnotatedListImpl
imports
  "../../../Finger-Trees/FingerTree"
  "../tools/Locale_Code"
  "../tools/Record_Intf"
  "../spec/AnnotatedListSpec"
begin

(*@impl AnnotatedList
  @type ('a,'b::monoid_add) ft
  @abbrv ft
  Annotated lists implemented by 2-3 finger trees.
*)

type_synonym ('a,'b) ft = "('a,'b) FingerTree"
subsection "Definitions"

definition ft_\<alpha> where
  "ft_\<alpha> \<equiv> FingerTree.toList"
abbreviation (input) ft_invar :: "('a,'b) FingerTree \<Rightarrow> bool" where
  "ft_invar \<equiv> \<lambda>_. True"
definition ft_empty where
  "ft_empty \<equiv> \<lambda>_::unit. FingerTree.empty"
definition ft_isEmpty where
  "ft_isEmpty \<equiv> FingerTree.isEmpty"
definition ft_count where
  "ft_count \<equiv> FingerTree.count"
definition ft_consl where
  "ft_consl e a s = FingerTree.lcons (e,a) s"
definition ft_consr where
  "ft_consr s e a = FingerTree.rcons s (e,a)"
definition ft_head where
  "ft_head \<equiv> FingerTree.head"
definition ft_tail where
  "ft_tail \<equiv> FingerTree.tail"
definition ft_headR where
  "ft_headR \<equiv> FingerTree.headR"
definition ft_tailR where
  "ft_tailR \<equiv> FingerTree.tailR"
definition ft_foldl where
  "ft_foldl \<equiv> FingerTree.foldl"
definition ft_foldr where
  "ft_foldr \<equiv> FingerTree.foldr"
definition ft_app where
  "ft_app \<equiv> FingerTree.app"
definition ft_annot where
  "ft_annot \<equiv> FingerTree.annot"
definition ft_splits where
  "ft_splits \<equiv> FingerTree.splitTree"

lemmas ft_defs =
  ft_\<alpha>_def
  ft_empty_def
  ft_isEmpty_def
  ft_count_def
  ft_consl_def
  ft_consr_def
  ft_head_def
  ft_tail_def
  ft_headR_def
  ft_tailR_def
  ft_foldl_def
  ft_foldr_def
  ft_app_def
  ft_annot_def
  ft_splits_def

lemma ft_empty_impl: "al_empty ft_\<alpha> ft_invar ft_empty"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.empty_correct)
  done

lemma ft_consl_impl: "al_consl ft_\<alpha> ft_invar ft_consl"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.lcons_correct)
done

lemma ft_consr_impl: "al_consr ft_\<alpha> ft_invar ft_consr"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.rcons_correct)
done

lemma ft_isEmpty_impl: "al_isEmpty ft_\<alpha> ft_invar ft_isEmpty"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.isEmpty_correct FingerTree.empty_correct)
  done

lemma ft_count_impl: "al_count ft_\<alpha> ft_invar ft_count"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.count_correct)
  done

lemma ft_head_impl: "al_head ft_\<alpha> ft_invar ft_head"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.head_correct FingerTree.empty_correct)
done

lemma ft_tail_impl: "al_tail ft_\<alpha> ft_invar ft_tail"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.tail_correct FingerTree.empty_correct)
done

lemma ft_headR_impl: "al_headR ft_\<alpha> ft_invar ft_headR"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.headR_correct FingerTree.empty_correct)
done

lemma ft_tailR_impl: "al_tailR ft_\<alpha> ft_invar ft_tailR"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.tailR_correct FingerTree.empty_correct)
    done

lemma ft_foldl_impl: "al_foldl ft_\<alpha> ft_invar ft_foldl"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.foldl_correct)
  done

lemma ft_foldr_impl: "al_foldr ft_\<alpha> ft_invar ft_foldr"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.foldr_correct)
  done

lemma ft_foldl_cunfold[code_unfold]:
  "List.foldl f \<sigma> (ft_\<alpha> t) = ft_foldl f \<sigma> t"
  apply (auto simp add: ft_defs FingerTree.foldl_correct)
  done

lemma ft_foldr_cunfold[code_unfold]:
  "List.foldr f (ft_\<alpha> t) \<sigma> = ft_foldr f t \<sigma>"
  apply (auto simp add: ft_defs FingerTree.foldr_correct)
  done

lemma ft_app_impl: "al_app ft_\<alpha> ft_invar ft_app"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.app_correct)
  done

lemma ft_annot_impl: "al_annot ft_\<alpha> ft_invar ft_annot"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.annot_correct)
  done

lemma ft_splits_impl: "al_splits ft_\<alpha> ft_invar ft_splits"
  apply unfold_locales
  apply (unfold ft_defs)
  apply (simp only: FingerTree.annot_correct[symmetric])
  apply (frule (3) FingerTree.splitTree_correct(1))
  apply (frule (3) FingerTree.splitTree_correct(2))
  apply (frule (3) FingerTree.splitTree_correct(3))
  apply (simp only: FingerTree.annot_correct[symmetric])
  apply simp
  done

subsubsection "Record Based Implementation"

definition [icf_rec_def]: "ft_ops = \<lparr>
  alist_op_\<alpha> = ft_\<alpha>,
  alist_op_invar = ft_invar,
  alist_op_empty = ft_empty,
  alist_op_isEmpty = ft_isEmpty,
  alist_op_count = ft_count,
  alist_op_consl = ft_consl,
  alist_op_consr = ft_consr,
  alist_op_head = ft_head,
  alist_op_tail = ft_tail,
  alist_op_headR = ft_headR,
  alist_op_tailR = ft_tailR,
  alist_op_app = ft_app,
  alist_op_annot = ft_annot,
  alist_op_splits = ft_splits
  \<rparr>"

setup Locale_Code.open_block
interpretation ft!: StdAL ft_ops
  apply (rule StdAL.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule
    ft_empty_impl
    ft_consl_impl
    ft_consr_impl
    ft_isEmpty_impl
    ft_count_impl
    ft_head_impl
    ft_tail_impl
    ft_headR_impl
    ft_tailR_impl
    ft_foldl_impl
    ft_foldr_impl
    ft_app_impl
    ft_annot_impl
    ft_splits_impl
  )+
  done
interpretation ft!: StdAL_no_invar ft_ops
  by (unfold_locales) (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "ft"*}

definition "test_codegen \<equiv> (
  ft.empty,
  ft.isEmpty,
  ft.count,
  ft.consl,
  ft.consr,
  ft.head,
  ft.tail,
  ft.headR,
  ft.tailR,
  ft.app,
  ft.annot,
  ft.splits,
  ft.foldl,
  ft.foldr
)"

export_code test_codegen in SML

end


section \<open>Core Lens Laws\<close>

theory Lens_Laws
imports
  Two Interp
begin

subsection \<open>Lens Signature\<close>

text \<open>This theory introduces the signature of lenses and indentifies the core algebraic hierarchy of lens
  classes, including laws for well-behaved, very well-behaved, and bijective lenses~\cite{Foster07,Fischer2015,Gibbons17}.\<close>

record ('a, 'b) lens =
  lens_get :: "'b \<Rightarrow> 'a" ("get\<index>")
  lens_put :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" ("put\<index>")

type_notation
  lens (infixr "\<Longrightarrow>" 0)

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=6cm]{figures/Lens}
  \end{center}
  \vspace{-5ex}
  \caption{Visualisation of a simple lens}
  \label{fig:Lens}
  \end{figure}

  A lens $X : \view \lto \src$, for source type $\src$ and view type $\view$, identifies
  $\view$ with a subregion of $\src$~\cite{Foster07,Foster09}, as illustrated in Figure~\ref{fig:Lens}. The arrow denotes
  $X$ and the hatched area denotes the subregion $\view$ it characterises. Transformations on
  $\view$ can be performed without affecting the parts of $\src$ outside the hatched area. The lens
  signature consists of a pair of functions $\lget_X : \src \Rightarrow \view$ that extracts a view
  from a source, and $\lput_X : \src \Rightarrow \view \Rightarrow \src$ that updates a view within
  a given source. \<close>

named_theorems lens_defs

text \<open> @{text lens_source} gives the set of constructible sources; that is those that can be built
  by putting a value into an arbitrary source. \<close>

definition lens_source :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'b set" ("\<S>\<index>") where
"lens_source X = {s. \<exists> v s'. s = put\<^bsub>X\<^esub> s' v}"

abbreviation some_source :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'b" ("src\<index>") where
"some_source X \<equiv> (SOME s. s \<in> \<S>\<^bsub>X\<^esub>)"

definition lens_create :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("create\<index>") where
[lens_defs]: "create\<^bsub>X\<^esub> v = put\<^bsub>X\<^esub> (src\<^bsub>X\<^esub>) v"

text \<open> Function $\lcreate_X~v$ creates an instance of the source type of $X$ by injecting $v$
  as the view, and leaving the remaining context arbitrary. \<close>

subsection \<open>Weak Lenses\<close>

text \<open> Weak lenses are the least constrained class of lenses in our algebraic hierarchy. They
  simply require that the PutGet law~\cite{Foster09,Fischer2015} is satisfied, meaning that
  $\lget$ is the inverse of $\lput$. \<close>

locale weak_lens =
  fixes x :: "'a \<Longrightarrow> 'b" (structure)
  assumes put_get: "get (put \<sigma> v) = v"
begin
  lemma source_nonempty: "\<exists> s. s \<in> \<S>"
    by (auto simp add: lens_source_def)

  lemma put_closure: "put \<sigma> v \<in> \<S>"
    by (auto simp add: lens_source_def)

  lemma create_closure: "create v \<in> \<S>"
    by (simp add: lens_create_def put_closure)

  lemma src_source [simp]: "src \<in> \<S>"
    using some_in_eq source_nonempty by auto

  lemma create_get: "get (create v) = v"
    by (simp add: lens_create_def put_get)

  lemma create_inj: "inj create"
    by (metis create_get injI)

  text \<open> The update function is analogous to the record update function which lifts a function
    on a view type to one on the source type. \<close>

  definition update :: "('a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b)" where
  [lens_defs]: "update f \<sigma> = put \<sigma> (f (get \<sigma>))"

  lemma get_update: "get (update f \<sigma>) = f (get \<sigma>)"
    by (simp add: put_get update_def)

  lemma view_determination:
    assumes "put \<sigma> u = put \<rho> v"
    shows "u = v"
    by (metis assms put_get)

  lemma put_inj: "inj (put \<sigma>)"
    by (simp add: injI view_determination)
end

declare weak_lens.put_get [simp]
declare weak_lens.create_get [simp]

subsection \<open>Well-behaved Lenses\<close>

text \<open> Well-behaved lenses add to weak lenses that requirement that the GetPut law~\cite{Foster09,Fischer2015}
  is satisfied, meaning that $\lput$ is the inverse of $\lget$. \<close>

locale wb_lens = weak_lens +
  assumes get_put: "put \<sigma> (get \<sigma>) = \<sigma>"
begin

  lemma put_twice: "put (put \<sigma> v) v = put \<sigma> v"
    by (metis get_put put_get)

  lemma put_surjectivity: "\<exists> \<rho> v. put \<rho> v = \<sigma>"
    using get_put by blast

  lemma source_stability: "\<exists> v. put \<sigma> v = \<sigma>"
    using get_put by auto

  lemma source_UNIV [simp]: "\<S> = UNIV"
    by (metis UNIV_eq_I put_closure wb_lens.source_stability wb_lens_axioms)

end

declare wb_lens.get_put [simp]

lemma wb_lens_weak [simp]: "wb_lens x \<Longrightarrow> weak_lens x"
  by (simp add: wb_lens_def)

subsection \<open> Mainly Well-behaved Lenses \<close>

text \<open> Mainly well-behaved lenses extend weak lenses with the PutPut law that shows how one put
  override a previous one. \<close>

locale mwb_lens = weak_lens +
  assumes put_put: "put (put \<sigma> v) u = put \<sigma> u"
begin

  text \<open> Mainly well-behaved lenses give rise to a weakened version of the $get-put$ law,
    where the source must be within the set of constructible sources. \<close>

  lemma weak_get_put: "\<sigma> \<in> \<S> \<Longrightarrow> put \<sigma> (get \<sigma>) = \<sigma>"
    by (auto simp add: lens_source_def put_get put_put)

  lemma weak_source_determination:
    assumes "\<sigma> \<in> \<S>" "\<rho> \<in> \<S>" "get \<sigma> = get \<rho>" "put \<sigma> v = put \<rho> v"
    shows "\<sigma> = \<rho>"
    by (metis assms put_put weak_get_put)

   lemma weak_put_eq:
     assumes "\<sigma> \<in> \<S>" "get \<sigma> = k" "put \<sigma> u = put \<rho> v"
     shows "put \<rho> k = \<sigma>"
     by (metis assms put_put weak_get_put)

  text \<open> Provides $s$ is constructible, then @{term get} can be uniquely determined from @{term put} \<close>

  lemma weak_get_via_put: "s \<in> \<S> \<Longrightarrow> get s = (THE v. put s v = s)"
    by (rule sym, auto intro!: the_equality weak_get_put, metis put_get)

end

declare mwb_lens.put_put [simp]
declare mwb_lens.weak_get_put [simp]

lemma mwb_lens_weak [simp]:
  "mwb_lens x \<Longrightarrow> weak_lens x"
  by (simp add: mwb_lens.axioms(1))

subsection \<open>Very Well-behaved Lenses\<close>

text \<open>Very well-behaved lenses combine all three laws, as in the literature~\cite{Foster09,Fischer2015}.\<close>

locale vwb_lens = wb_lens + mwb_lens
begin

  lemma source_determination:
    assumes "get \<sigma> = get \<rho>" "put \<sigma> v = put \<rho> v"
    shows "\<sigma> = \<rho>"
    by (metis assms get_put put_put)

 lemma put_eq:
   assumes "get \<sigma> = k" "put \<sigma> u = put \<rho> v"
   shows "put \<rho> k = \<sigma>"
   using assms weak_put_eq[of \<sigma> k u \<rho> v] by (simp)

  text \<open> @{term get} can be uniquely determined from @{term put} \<close>

  lemma get_via_put: "get s = (THE v. put s v = s)"
    by (simp add: weak_get_via_put)

end

lemma vwb_lens_wb [simp]: "vwb_lens x \<Longrightarrow> wb_lens x"
  by (simp add: vwb_lens_def)

lemma vwb_lens_mwb [simp]: "vwb_lens x \<Longrightarrow> mwb_lens x"
  using vwb_lens_def by auto

subsection \<open> Ineffectual Lenses \<close>

text \<open>Ineffectual lenses can have no effect on the view type -- application of the $\lput$ function
  always yields the same source. They are thus, trivially, very well-behaved lenses.\<close>

locale ief_lens = weak_lens +
  assumes put_inef: "put \<sigma> v = \<sigma>"
begin

sublocale vwb_lens
proof
  fix \<sigma> v u
  show "put \<sigma> (get \<sigma>) = \<sigma>"
    by (simp add: put_inef)
  show "put (put \<sigma> v) u = put \<sigma> u"
    by (simp add: put_inef)
qed

lemma ineffectual_const_get:
  "\<exists> v.  \<forall> \<sigma>\<in>\<S>. get \<sigma> = v"
  using put_get put_inef by auto

end

abbreviation "eff_lens X \<equiv> (weak_lens X \<and> (\<not> ief_lens X))"

subsection \<open> Bijective Lenses \<close>

text \<open>Bijective lenses characterise the situation where the source and view type are equivalent:
  in other words the view type full characterises the whole source type. It is often useful
  when the view type and source type are syntactically different, but nevertheless correspond
  precisely in terms of what they observe. Bijective lenses are formulates using
  the strong GetPut law~\cite{Foster09,Fischer2015}.\<close>

locale bij_lens = weak_lens +
  assumes strong_get_put: "put \<sigma> (get \<rho>) = \<rho>"
begin

sublocale vwb_lens
proof
  fix \<sigma> v u
  show "put \<sigma> (get \<sigma>) = \<sigma>"
    by (simp add: strong_get_put)
  show "put (put \<sigma> v) u = put \<sigma> u"
    by (metis bij_lens.strong_get_put bij_lens_axioms put_get)
qed

  lemma put_bij: "bij_betw (put \<sigma>) UNIV UNIV"
    by (metis bijI put_inj strong_get_put surj_def)

  lemma get_create: "\<sigma> \<in> \<S> \<Longrightarrow> create (get \<sigma>) = \<sigma>"
    by (simp add: lens_create_def strong_get_put)

end

declare bij_lens.strong_get_put [simp]
declare bij_lens.get_create [simp]

lemma bij_lens_weak [simp]:
  "bij_lens x \<Longrightarrow> weak_lens x"
  by (simp_all add: bij_lens_def)

lemma bij_lens_vwb [simp]: "bij_lens x \<Longrightarrow> vwb_lens x"
  by (metis bij_lens.strong_get_put bij_lens_weak mwb_lens.intro mwb_lens_axioms.intro vwb_lens_def wb_lens.intro wb_lens_axioms.intro weak_lens.put_get)

subsection \<open>Lens Independence\<close>

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=6cm]{figures/Independence}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Independence}
  \label{fig:Indep}
  \end{figure}

  Lens independence shows when two lenses $X$ and $Y$ characterise disjoint regions of the
  source type, as illustrated in Figure~\ref{fig:Indep}. We specify this by requiring that the $\lput$
  functions of the two lenses commute, and that the $\lget$ function of each lens is unaffected by
  application of $\lput$ from the corresponding lens. \<close>

locale lens_indep =
  fixes X :: "'a \<Longrightarrow> 'c" and Y :: "'b \<Longrightarrow> 'c"
  assumes lens_put_comm: "put\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \<sigma> v) u = put\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<sigma> u) v"
  and lens_put_irr1: "get\<^bsub>X\<^esub> (put\<^bsub>Y\<^esub> \<sigma> v) = get\<^bsub>X\<^esub> \<sigma>"
  and lens_put_irr2: "get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<sigma> u) = get\<^bsub>Y\<^esub> \<sigma>"

notation lens_indep (infix "\<bowtie>" 50)

lemma lens_indepI:
  "\<lbrakk> \<And> u v \<sigma>. lens_put x (lens_put y \<sigma> v) u = lens_put y (lens_put x \<sigma> u) v;
     \<And> v \<sigma>. lens_get x (lens_put y \<sigma> v) = lens_get x \<sigma>;
     \<And> u \<sigma>. lens_get y (lens_put x \<sigma> u) = lens_get y \<sigma> \<rbrakk> \<Longrightarrow> x \<bowtie> y"
  by (simp add: lens_indep_def)

text \<open>Lens independence is symmetric.\<close>

lemma lens_indep_sym:  "x \<bowtie> y \<Longrightarrow> y \<bowtie> x"
  by (simp add: lens_indep_def)

lemma lens_indep_comm:
  "x \<bowtie> y \<Longrightarrow> lens_put x (lens_put y \<sigma> v) u = lens_put y (lens_put x \<sigma> u) v"
  by (simp add: lens_indep_def)

lemma lens_indep_get [simp]:
  assumes "x \<bowtie> y"
  shows "lens_get x (lens_put y \<sigma> v) = lens_get x \<sigma>"
  using assms lens_indep_def by fastforce

end


(* Author: Simon Wimmer *)
theory More_List
  imports
    Main
    Instantiate_Existentials
begin

section \<open>First and Last Elements of Lists\<close>

lemma (in -) hd_butlast_last_id:
  "hd xs # tl (butlast xs) @ [last xs] = xs" if "length xs > 1"
  using that by (cases xs) auto

section \<open>@{term list_all}\<close>

lemma (in -) list_all_map:
  assumes inv: "\<And> x. P x \<Longrightarrow> \<exists> y. f y = x"
    and all: "list_all P as"
  shows "\<exists> as'. map f as' = as"
  using all
    apply (induction as)
   apply (auto dest!: inv)
  subgoal for as' a
    by (inst_existentials "a # as'") simp
  done

section \<open>@{term list_all2}\<close>

lemma list_all2_op_map_iff:
  "list_all2 (\<lambda> a b. b = f a) xs ys \<longleftrightarrow> map f xs = ys"
  unfolding list_all2_iff
  proof (induction xs arbitrary: ys)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs ys)
    then show ?case by (cases ys) auto
  qed

lemma list_all2_last:
  "R (last xs) (last ys)" if "list_all2 R xs ys" "xs \<noteq> []"
  using that
  unfolding list_all2_iff
  proof (induction xs arbitrary: ys)
    case Nil
    then show ?case by simp
  next
    case (Cons a xs ys)
    then show ?case by (cases ys) auto
  qed

lemma list_all2_set1:
  "\<forall>x\<in>set xs. \<exists>xa\<in>set as. P x xa" if "list_all2 P xs as"
  using that
proof (induction xs arbitrary: as)
  case Nil
  then show ?case by auto
next
  case (Cons a xs as)
  then show ?case by (cases as) auto
qed

lemma list_all2_swap:
  "list_all2 P xs ys \<longleftrightarrow> list_all2 (\<lambda> x y. P y x) ys xs"
  unfolding list_all2_iff by (fastforce simp: in_set_zip)+

lemma list_all2_set2:
  "\<forall>x\<in>set as. \<exists>xa\<in>set xs. P xa x" if "list_all2 P xs as"
  using that by - (rule list_all2_set1, subst (asm) list_all2_swap)

section \<open>Distinct lists\<close>

(* XXX Duplication with Floyd_Warshall.thy *)
lemma distinct_length_le:"finite s \<Longrightarrow> set xs \<subseteq> s \<Longrightarrow> distinct xs \<Longrightarrow> length xs \<le> card s"
  by (metis card_mono distinct_card)

section \<open>@{term filter}\<close>

lemma filter_eq_appendD:
  "\<exists> xs' ys'. filter P xs' = xs \<and> filter P ys' = ys \<and> as = xs' @ ys'" if "filter P as = xs @ ys"
  using that
proof (induction xs arbitrary: as)
  case Nil
  then show ?case
    by (inst_existentials "[] :: 'a list" as) auto
next
  case (Cons a xs)
  from filter_eq_ConsD[OF Cons.prems[simplified]] obtain us vs where
    "as = us @ a # vs" "\<forall>u\<in>set us. \<not> P u" "P a" "filter P vs = xs @ ys"
    by auto
  moreover from Cons.IH[OF \<open>_ = xs @ ys\<close>] obtain xs' ys where
    "filter P xs' = xs" "vs = xs' @ ys"
    by auto
  ultimately show ?case
    by (inst_existentials "us @ [a] @ xs'" ys) auto
qed

lemma list_all2_elem_filter:
  assumes "list_all2 P xs us" "x \<in> set xs"
  shows "length (filter (P x) us) \<ge> 1"
  using assms by (induction xs arbitrary: us) (auto simp: list_all2_Cons1)

lemma list_all2_replicate_elem_filter:
  assumes "list_all2 P (concat (replicate n xs)) ys" "x \<in> set xs"
  shows "length (filter (P x) ys) \<ge> n"
  using assms
  by (induction n arbitrary: ys; fastforce dest: list_all2_elem_filter simp: list_all2_append1)

section \<open>Sublists\<close>

lemma nths_split:
  "nths xs (A \<union> B) = nths xs A @ nths xs B" if "\<forall> i \<in> A. \<forall> j \<in> B. i < j"
  using that
  proof (induction xs arbitrary: A B)
    case Nil
    then show ?case by simp
  next
    case (Cons a xs)
    let ?A = "{j. Suc j \<in> A}" and ?B = "{j. Suc j \<in> B}"
    from Cons.prems have *: "\<forall>i\<in>?A. \<forall>a\<in>?B. i < a"
      by auto
    have [simp]: "{j. Suc j \<in> A \<or> Suc j \<in> B} = ?A \<union> ?B"
      by auto
    show ?case
      unfolding nths_Cons
    proof (clarsimp, safe, goal_cases)
      case 2
      with Cons.prems have "A = {}"
        by auto
      with Cons.IH[OF *] show ?case by auto
    qed (use Cons.prems Cons.IH[OF *] in auto)
  qed

lemma nths_nth:
  "nths xs {i} = [xs ! i]" if "i < length xs"
  using that
  proof (induction xs arbitrary: i)
    case Nil
    then show ?case by simp
  next
    case (Cons a xs)
    then show ?case
      by (cases i) (auto simp: nths_Cons)
  qed

lemma nths_shift:
  "nths (xs @ ys) S = nths ys {x - length xs | x. x \<in> S}" if
  "\<forall> i \<in> S. length xs \<le> i"
  using that
proof (induction xs arbitrary: S)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  have [simp]: "{x - length xs |x. Suc x \<in> S} = {x - Suc (length xs) |x. x \<in> S}" if "0 \<notin> S"
    using that apply safe
     apply force
    subgoal for x x'
      by (cases x') auto
    done
  from Cons.prems show ?case
    by (simp, subst nths_Cons, subst Cons.IH; auto)
qed

lemma nths_eq_ConsD:
  assumes "nths xs I = x # as"
  shows
    "\<exists> ys zs.
      xs = ys @ x # zs \<and> length ys \<in> I \<and> (\<forall> i \<in> I. i \<ge> length ys)
      \<and> nths zs ({i - length ys - 1 | i. i \<in> I \<and> i > length ys}) = as"
  using assms
proof (induction xs arbitrary: I x as)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  from Cons.prems show ?case
    unfolding nths_Cons
    apply (auto split: if_split_asm)
    subgoal
      by (inst_existentials "[] :: 'a list" xs; force intro: arg_cong2[of xs xs _ _ nths])
    subgoal
      apply (drule Cons.IH)
      apply safe
      subgoal for ys zs
        apply (inst_existentials "a # ys" zs)
           apply simp+
         apply standard
        subgoal for i
          by (cases i; auto)
        apply (rule arg_cong2[of zs zs _ _ nths])
         apply simp
        apply safe
        subgoal for _ i
          by (cases i; auto)
        by force
      done
    done
qed

lemma nths_out_of_bounds:
  "nths xs I = []" if "\<forall>i \<in> I. i \<ge> length xs"
  using that
  (* Found by sledgehammer *)
proof -
  have
    "\<forall>N as.
      (\<exists>n. n \<in> N \<and> \<not> length (as::'a list) \<le> n)
      \<or> (\<forall>asa. nths (as @ asa) N = nths asa {n - length as |n. n \<in> N})"
    using nths_shift by blast
  then obtain nn :: "nat set \<Rightarrow> 'a list \<Rightarrow> nat" where
    "\<forall>N as.
      nn N as \<in> N \<and> \<not> length as \<le> nn N as
    \<or> (\<forall>asa. nths (as @ asa) N = nths asa {n - length as |n. n \<in> N})"
    by moura
  then have
    "\<And>as. nths as {n - length xs |n. n \<in> I} = nths (xs @ as) I
      \<or> nths (xs @ []) I = []"
    using that by fastforce
  then have "nths (xs @ []) I = []"
    by (metis (no_types) nths_nil)
  then show ?thesis
    by simp
qed

lemma nths_eq_appendD:
  assumes "nths xs I = as @ bs"
  shows
    "\<exists> ys zs.
        xs = ys @ zs \<and> nths ys I = as
        \<and> nths zs {i - length ys | i. i \<in> I \<and> i \<ge> length ys} = bs"
  using assms
proof (induction as arbitrary: xs I)
  case Nil
  then show ?case
    by (inst_existentials "[] :: 'a list" "nths bs") auto
next
  case (Cons a ys xs)
  from nths_eq_ConsD[of xs I a "ys @ bs"] Cons.prems obtain ys' zs' where
    "xs = ys' @ a # zs'" "length ys' \<in> I" "\<forall>i \<in> I. i \<ge> length ys'"
    "nths zs' {i - length ys' - 1 |i. i \<in> I \<and> i > length ys'} = ys @ bs"
    by auto
  moreover from Cons.IH[OF \<open>nths zs' _ = _\<close>] guess ys'' zs'' by clarify
  ultimately show ?case
    apply (inst_existentials "ys' @ a # ys''" zs'')
      apply (simp; fail)
    subgoal
      by (simp add: nths_out_of_bounds nths_append nths_Cons)
        (rule arg_cong2[of ys'' ys'' _ _ nths]; force)
    subgoal
      by safe (rule arg_cong2[of zs'' zs'' _ _ nths]; force) (* Slow *)
    done
qed

lemma filter_nths_length:
  "length (filter P (nths xs I)) \<le> length (filter P xs)"
proof (induction xs arbitrary: I)
  case Nil
  then show ?case
    by simp
next
  case Cons
  then show ?case
  (* Found by sledgehammer *)
  proof -
    fix a :: 'a and xsa :: "'a list" and Ia :: "nat set"
    assume a1: "\<And>I. length (filter P (nths xsa I)) \<le> length (filter P xsa)"
    have f2:
      "\<forall>b bs N. if 0 \<in> N then nths ((b::'a) # bs) N =
        [b] @ nths bs {n. Suc n \<in> N} else nths (b # bs) N = [] @ nths bs {n. Suc n \<in> N}"
      by (simp add: nths_Cons)
    have f3:
      "nths (a # xsa) Ia = [] @ nths xsa {n. Suc n \<in> Ia}
        \<longrightarrow> length (filter P (nths (a # xsa) Ia)) \<le> length (filter P xsa)"
      using a1 by (metis append_Nil)
    have f4: "length (filter P (nths xsa {n. Suc n \<in> Ia})) + 0 \<le> length (filter P xsa) + 0"
      using a1 by simp
    have f5:
      "Suc (length (filter P (nths xsa {n. Suc n \<in> Ia})) + 0)
      = length (a # filter P (nths xsa {n. Suc n \<in> Ia}))"
      by force
    have f6: "Suc (length (filter P xsa) + 0) = length (a # filter P xsa)"
      by simp
    { assume "\<not> length (filter P (nths (a # xsa) Ia)) \<le> length (filter P (a # xsa))"
      { assume "nths (a # xsa) Ia \<noteq> [a] @ nths xsa {n. Suc n \<in> Ia}"
        moreover
        { assume
            "nths (a # xsa) Ia = [] @ nths xsa {n. Suc n \<in> Ia}
            \<and> length (filter P (a # xsa)) \<le> length (filter P xsa)"
          then have "length (filter P (nths (a # xsa) Ia)) \<le> length (filter P (a # xsa))"
            using a1 by (metis (no_types) append_Nil filter.simps(2) impossible_Cons) }
        ultimately have "length (filter P (nths (a # xsa) Ia)) \<le> length (filter P (a # xsa))"
          using f3 f2 by (meson dual_order.trans le_cases) }
      then have "length (filter P (nths (a # xsa) Ia)) \<le> length (filter P (a # xsa))"
        using f6 f5 f4 a1 by (metis Suc_le_mono append_Cons append_Nil filter.simps(2)) }
    then show "length (filter P (nths (a # xsa) Ia)) \<le> length (filter P (a # xsa))"
      by meson
  qed
qed

end (* Theory *)


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_25
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

fun max :: "Nat => Nat => Nat" where
"max (Z) z = z"
| "max (S z2) (Z) = S z2"
| "max (S z2) (S x2) = S (max z2 x2)"

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

theorem property0 :
  "((x (max a b) b) = (t2 a b))"
  oops

end


theory prop_80
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = Nil2"
  | "take (S z) (Nil2) = Nil2"
  | "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"
  fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
  | "minus (S z) (Z) = S z"
  | "minus (S z) (S x2) = minus z x2"
  fun len :: "'a list => Nat" where
  "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster take minus len append *)
  theorem x0 :
    "(take n (append xs ys)) =
       (append (take n xs) (take (minus n (len xs)) ys))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

header "Automata based scanner"

theory AutoMaxChop
imports DA MaxChop
begin

primrec auto_split :: "('a,'s)da => 's  => 'a list * 'a list => 'a list => 'a splitter" where
"auto_split A q res ps []     = (if fin A q then (ps,[]) else res)" |
"auto_split A q res ps (x#xs) =
   auto_split A (next A x q) (if fin A q then (ps,x#xs) else res) (ps@[x]) xs"

definition
 auto_chop :: "('a,'s)da => 'a chopper" where
"auto_chop A = chop (%xs. auto_split A (start A) ([],xs) [] xs)"

lemma delta_snoc: "delta A (xs@[y]) q = next A y (delta A xs q)";
by simp

lemma auto_split_lemma:
 "!!q ps res. auto_split A (delta A ps q) res ps xs =
              maxsplit (%ys. fin A (delta A ys q)) res ps xs"
apply (induct xs)
 apply simp
apply (simp add: delta_snoc[symmetric] del: delta_append)
done

lemma auto_split_is_maxsplit:
 "auto_split A (start A) res [] xs = maxsplit (accepts A) res [] xs"
apply (unfold accepts_def)
apply (subst delta_Nil[where ?s = "start A", symmetric])
apply (subst auto_split_lemma)
apply simp
done

lemma is_maxsplitter_auto_split:
 "is_maxsplitter (accepts A) (%xs. auto_split A (start A) ([],xs) [] xs)"
by (simp add: auto_split_is_maxsplit is_maxsplitter_maxsplit)

lemma is_maxchopper_auto_chop:
 "is_maxchopper (accepts A) (auto_chop A)"
apply (unfold auto_chop_def)
apply (rule is_maxchopper_chop)
apply (rule is_maxsplitter_auto_split)
done

end


(*  Title:      HOL/Metis_Examples/Abstraction.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Example featuring Metis's support for lambda-abstractions.
*)

section {* Example Featuring Metis's Support for Lambda-Abstractions *}

theory Abstraction
imports "~~/src/HOL/Library/FuncSet"
begin

(* For Christoph Benzmüller *)
lemma "x < 1 \<and> ((op =) = (op =)) \<Longrightarrow> ((op =) = (op =)) \<and> x < (2::nat)"
by (metis nat_1_add_1 trans_less_add2)

lemma "(op = ) = (\<lambda>x y. y = x)"
by metis

consts
  monotone :: "['a => 'a, 'a set, ('a *'a)set] => bool"
  pset  :: "'a set => 'a set"
  order :: "'a set => ('a * 'a) set"

lemma "a \<in> {x. P x} \<Longrightarrow> P a"
proof -
  assume "a \<in> {x. P x}"
  thus "P a" by (metis mem_Collect_eq)
qed

lemma Collect_triv: "a \<in> {x. P x} \<Longrightarrow> P a"
by (metis mem_Collect_eq)

lemma "a \<in> {x. P x --> Q x} \<Longrightarrow> a \<in> {x. P x} \<Longrightarrow> a \<in> {x. Q x}"
by (metis Collect_imp_eq ComplD UnE)

lemma "(a, b) \<in> Sigma A B \<Longrightarrow> a \<in> A \<and> b \<in> B a"
proof -
  assume A1: "(a, b) \<in> Sigma A B"
  hence F1: "b \<in> B a" by (metis mem_Sigma_iff)
  have F2: "a \<in> A" by (metis A1 mem_Sigma_iff)
  have "b \<in> B a" by (metis F1)
  thus "a \<in> A \<and> b \<in> B a" by (metis F2)
qed

lemma Sigma_triv: "(a, b) \<in> Sigma A B \<Longrightarrow> a \<in> A & b \<in> B a"
by (metis SigmaD1 SigmaD2)

lemma "(a, b) \<in> (SIGMA x:A. {y. x = f y}) \<Longrightarrow> a \<in> A \<and> a = f b"
by (metis (full_types, lifting) CollectD SigmaD1 SigmaD2)

lemma "(a, b) \<in> (SIGMA x:A. {y. x = f y}) \<Longrightarrow> a \<in> A \<and> a = f b"
proof -
  assume A1: "(a, b) \<in> (SIGMA x:A. {y. x = f y})"
  hence F1: "a \<in> A" by (metis mem_Sigma_iff)
  have "b \<in> {R. a = f R}" by (metis A1 mem_Sigma_iff)
  hence "a = f b" by (metis (full_types) mem_Collect_eq)
  thus "a \<in> A \<and> a = f b" by (metis F1)
qed

lemma "(cl, f) \<in> CLF \<Longrightarrow> CLF = (SIGMA cl: CL.{f. f \<in> pset cl}) \<Longrightarrow> f \<in> pset cl"
by (metis Collect_mem_eq SigmaD2)

lemma "(cl, f) \<in> CLF \<Longrightarrow> CLF = (SIGMA cl: CL.{f. f \<in> pset cl}) \<Longrightarrow> f \<in> pset cl"
proof -
  assume A1: "(cl, f) \<in> CLF"
  assume A2: "CLF = (SIGMA cl:CL. {f. f \<in> pset cl})"
  have "\<forall>v u. (u, v) \<in> CLF \<longrightarrow> v \<in> {R. R \<in> pset u}" by (metis A2 mem_Sigma_iff)
  hence "\<forall>v u. (u, v) \<in> CLF \<longrightarrow> v \<in> pset u" by (metis mem_Collect_eq)
  thus "f \<in> pset cl" by (metis A1)
qed

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
by (metis (no_types) Collect_mem_eq Sigma_triv)

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
proof -
  assume A1: "(cl, f) \<in> (SIGMA cl:CL. {f. f \<in> pset cl \<rightarrow> pset cl})"
  have "f \<in> {R. R \<in> pset cl \<rightarrow> pset cl}" using A1 by simp
  thus "f \<in> pset cl \<rightarrow> pset cl" by (metis mem_Collect_eq)
qed

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
by (metis (no_types) Collect_conj_eq Int_def Sigma_triv inf_idem)

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
proof -
  assume A1: "(cl, f) \<in> (SIGMA cl:CL. {f. f \<in> pset cl \<inter> cl})"
  have "f \<in> {R. R \<in> pset cl \<inter> cl}" using A1 by simp
  hence "f \<in> Id_on cl `` pset cl" by (metis Int_commute Image_Id_on mem_Collect_eq)
  hence "f \<in> cl \<inter> pset cl" by (metis Image_Id_on)
  thus "f \<in> pset cl \<inter> cl" by (metis Int_commute)
qed

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl & monotone f (pset cl) (order cl)}) \<Longrightarrow>
   (f \<in> pset cl \<rightarrow> pset cl)  &  (monotone f (pset cl) (order cl))"
by auto

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF \<subseteq> (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
by (metis (lifting) CollectD Sigma_triv subsetD)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF = (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
by (metis (lifting) CollectD Sigma_triv)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF \<subseteq> (SIGMA cl': CL. {f. f \<in> pset cl' \<rightarrow> pset cl'}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
by (metis (lifting) CollectD Sigma_triv subsetD)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF = (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
by (metis (lifting) CollectD Sigma_triv)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF = (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl & monotone f (pset cl) (order cl)}) \<Longrightarrow>
   (f \<in> pset cl \<rightarrow> pset cl) & (monotone f (pset cl) (order cl))"
by auto

lemma "map (\<lambda>x. (f x, g x)) xs = zip (map f xs) (map g xs)"
apply (induct xs)
 apply (metis list.map(1) zip_Nil)
by auto

lemma
  "map (\<lambda>w. (w -> w, w \<times> w)) xs =
   zip (map (\<lambda>w. w -> w) xs) (map (\<lambda>w. w \<times> w) xs)"
apply (induct xs)
 apply (metis list.map(1) zip_Nil)
by auto

lemma "(\<lambda>x. Suc (f x)) ` {x. even x} \<subseteq> A \<Longrightarrow> \<forall>x. even x --> Suc (f x) \<in> A"
by (metis mem_Collect_eq image_eqI subsetD)

lemma
  "(\<lambda>x. f (f x)) ` ((\<lambda>x. Suc(f x)) ` {x. even x}) \<subseteq> A \<Longrightarrow>
   (\<forall>x. even x --> f (f (Suc(f x))) \<in> A)"
by (metis mem_Collect_eq imageI set_rev_mp)

lemma "f \<in> (\<lambda>u v. b \<times> u \<times> v) ` A \<Longrightarrow> \<forall>u v. P (b \<times> u \<times> v) \<Longrightarrow> P(f y)"
by (metis (lifting) imageE)

lemma image_TimesA: "(\<lambda>(x, y). (f x, g y)) ` (A \<times> B) = (f ` A) \<times> (g ` B)"
by (metis map_prod_def map_prod_surj_on)

lemma image_TimesB:
    "(\<lambda>(x, y, z). (f x, g y, h z)) ` (A \<times> B \<times> C) = (f ` A) \<times> (g ` B) \<times> (h ` C)"
by force

lemma image_TimesC:
  "(\<lambda>(x, y). (x \<rightarrow> x, y \<times> y)) ` (A \<times> B) =
   ((\<lambda>x. x \<rightarrow> x) ` A) \<times> ((\<lambda>y. y \<times> y) ` B)"
by (metis image_TimesA)

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

header {* Continuity *}

theory OrdinalCont
imports OrdinalInduct
begin

subsection {* Continuous functions *}

locale continuous =
  fixes F :: "ordinal \<Rightarrow> ordinal"
  assumes cont: "F (oLimit f) = oLimit (\<lambda>n. F (f n))"

lemmas continuousD = continuous.cont

lemma (in continuous) mono: "mono F"
 apply (rule monoI)
 apply (cut_tac f="case_nat x (\<lambda>n. y)" in cont)
 apply (subgoal_tac "\<forall>x y. oLimit (case_nat x (\<lambda>n. y)) = max x y")
  apply (subgoal_tac "\<forall>x y n. F (case n of 0 \<Rightarrow> x | Suc n \<Rightarrow> y)
                          = (case n of 0 \<Rightarrow> F x | Suc n \<Rightarrow> F y)")
   apply (simp add: max_def)
   apply (erule ssubst, simp)
  apply (simp split: nat.split)
 apply (clarify, rule order_antisym)
  apply (rule oLimit_leI)
  apply (simp split: nat.split add: max.cobounded1 max.cobounded2)
 apply (simp, safe)
  apply (rule_tac n=0 in le_oLimitI, simp)
 apply (rule_tac n=1 in le_oLimitI, simp)
done

lemma (in continuous) monoD: "x \<le> y \<Longrightarrow> F x \<le> F y"
by (erule monoD[OF mono])

lemma continuousI:
assumes lim: "\<And>f. strict_mono f \<Longrightarrow> F (oLimit f) = oLimit (\<lambda>n. F (f n))"
assumes suc: "\<And>x. F x \<le> F (oSuc x)"
shows "continuous F"
 apply (subgoal_tac "mono F")
  apply (rule continuous.intro)
  apply (case_tac "\<forall>n. f n < oLimit f")
   apply (subgoal_tac "oLimit (\<lambda>n. f (make_mono f n)) = oLimit f")
    apply (erule subst)
    apply (rule trans[OF lim])
     apply (erule strict_mono_f_make_mono)
    apply (rule oLimit_eqI)
     apply (rule exI, rule order_refl)
   apply (rule_tac x=n in exI)
    apply (erule monoD)
    apply (rule le_f_make_mono, assumption)
    apply (induct_tac n, simp)
    apply (simp add: Suc_le_eq)
    apply (erule order_le_less_trans)
    apply (erule make_mono_less)
   apply (erule oLimit_make_mono_eq)
  apply (clarsimp simp add: linorder_not_less)
  apply (drule order_antisym[OF _ le_oLimit], simp)
  apply (rule order_antisym[OF le_oLimit])
  apply (rule oLimit_leI[rule_format])
  apply (erule monoD)
  apply (erule subst)
  apply (rule le_oLimit)
 apply (subgoal_tac "\<forall>y x. x \<le> y \<longrightarrow> F x \<le> F y")
  apply (rule monoI, simp)
 apply (rule allI, rule_tac a=y in oLimit_induct)
   apply simp
  apply (clarsimp, erule le_oSucE)
   apply (drule spec, drule mp, assumption)
   apply (erule order_trans, rule suc)
  apply simp
 apply (clarsimp simp add: lim, erule le_oLimitE)
  apply (drule_tac x=n in spec)
  apply (drule_tac x=x in  spec, drule mp, assumption)
  apply (erule order_trans)
  apply (rule le_oLimit)
 apply (simp add: lim)
done

subsection {* Normal functions *}

locale normal = continuous +
  assumes strict: "strict_mono F"

lemma (in normal) mono: "mono F"
by (rule mono)

lemma (in normal) continuous: "continuous F"
by (rule continuous.intro, rule cont)

lemma (in normal) monoD: "x \<le> y \<Longrightarrow> F x \<le> F y"
by (rule monoD)

lemma (in normal) strict_monoD: "x < y \<Longrightarrow> F x < F y"
by (erule strict_monoD[OF strict])

lemma (in normal) cancel_eq: "(F x = F y) = (x = y)"
by (rule strict_mono_cancel_eq[OF strict])

lemma (in normal) cancel_less: "(F x < F y) = (x < y)"
by (rule strict_mono_cancel_less[OF strict])

lemma (in normal) cancel_le: "(F x \<le> F y) = (x \<le> y)"
by (rule strict_mono_cancel_le[OF strict])

lemma (in normal) oLimit: "F (oLimit f) = oLimit (\<lambda>n. F (f n))"
by (rule cont)

lemma (in normal) increasing: "x \<le> F x"
 apply (rule_tac a=x in oLimit_induct)
   apply simp
  apply (rule oSuc_leI)
  apply (erule order_le_less_trans)
  apply (rule strict_monoD[OF less_oSuc])
 apply (simp add: oLimit)
 apply (rule oLimit_leI, clarify)
 apply (rule order_trans, erule spec)
 apply (rule le_oLimit)
done

lemma normalI:
assumes lim: "\<And>f. strict_mono f \<Longrightarrow> F (oLimit f) = oLimit (\<lambda>n. F (f n))"
assumes suc: "\<And>x. F x < F (oSuc x)"
shows "normal F"
 apply (rule normal.intro[OF _ normal_axioms.intro])
  apply (simp add: continuousI order_less_imp_le suc lim)
 apply (subgoal_tac "\<forall>y x. x < y \<longrightarrow> F x < F y")
  apply (rule strict_monoI, simp)
 apply (rule allI, rule_tac a=y in oLimit_induct)
   apply simp
  apply (clarsimp, erule less_oSucE)
   apply (drule spec, drule mp, assumption)
   apply (erule order_less_trans, rule suc)
  apply (simp add: suc)
 apply (clarsimp simp add: lim, erule less_oLimitE)
 apply (drule spec, drule spec, drule mp, assumption)
 apply (erule order_less_le_trans)
 apply (rule le_oLimit)
done

lemma normal_range_le:
"\<lbrakk>normal F; normal G; range G \<subseteq> range F\<rbrakk> \<Longrightarrow> F x \<le> G x"
 apply (rule_tac a=x in oLimit_induct)
   apply (subgoal_tac "G 0 \<in> range F")
    apply (clarsimp simp add: normal.cancel_le)
   apply (erule subsetD, rule rangeI)
  apply (subgoal_tac "G (oSuc x) \<in> range F")
   apply (clarsimp simp add: normal.cancel_le)
   apply (rename_tac y)
   apply (rule oSuc_leI)
   apply (subgoal_tac "F x < F y", simp add: normal.cancel_less)
   apply (erule order_le_less_trans)
   apply (erule subst)
   apply (simp add: normal.cancel_less)
  apply (erule subsetD, rule rangeI)
 apply (simp only: normal.oLimit)
 apply (rule oLimit_leI[rule_format])
 apply (rule_tac n=n in le_oLimitI)
 apply (erule spec)
done

lemma normal_range_eq:
"\<lbrakk>normal F; normal G; range F = range G\<rbrakk> \<Longrightarrow> F = G"
 apply (rule ext, rule order_antisym)
  apply (simp add: normal_range_le)
 apply (simp add: normal_range_le)
done

end