theory Exercise2
  imports IMP
begin

(* NOTE: Just as with assigned_oe from Exercise 1,
   skip_ua is an inaccurate approximation (in this case,
   an underapproximation of SKIP-equivalent commands, or
   an overapproximation of non-SKIP-equivalent
   commands. Also of note, given the command WHILE g
   DO c, if c is equivalent to SKIP then the while loop
   would never terminate (which we could reasonably say
   is not equivalent behavior to SKIP). Since we have
   already chosen not to explore satisfiability of guards
   with skip_ua, we will just say the WHILE g DO c form
   is not equivalent to SKIP. *)
fun skip_ua :: "com \<Rightarrow> bool" where
skip: "skip_ua (SKIP) = True" |
assign: "skip_ua (x ::= a) = False" |
seq: "skip_ua (a ;; b) = ((skip_ua a) \<and> (skip_ua b))" |
ifthen: "skip_ua (IF g THEN a ELSE b)
  = ((skip_ua a) \<and> (skip_ua b))" |
whiledo: "skip_ua (WHILE g DO a) = False"

theorem skip_ua_impl_equiv: "skip_ua c \<Longrightarrow> c \<sim> SKIP"
proof (induction c)
  case (Seq c1 c2)
  hence "c1 \<sim> SKIP" and "c2 \<sim> SKIP" by simp_all
  hence "(c1 ;; c2) \<sim> (SKIP ;; SKIP)" by blast
  thus "(c1 ;; c2) \<sim> SKIP" by auto
next
  case (If b c1 c2)
  hence "c1 \<sim> SKIP" and "c2 \<sim> SKIP" by simp_all
  thus "(IF b THEN c1 ELSE c2) \<sim> SKIP"
    by blast
qed auto

end


(*****************************************************************************************)
(* Project: Isabelle/UTP Toolkit                                                         *)
(* File: List_Extra.thy                                                                  *)
(* Authors: Simon Foster, Pedro Ribeiro, and Frank Zeyda                                 *)
(* Emails: simon.foster@york.ac.uk, pedro.ribeiro@york.ac.uk, and frank.zeyda@york.ac.uk *)
(*****************************************************************************************)

section \<open> Lists: extra functions and properties \<close>

theory List_Extra
  imports
  "HOL-Library.Sublist"
  "HOL-Library.Monad_Syntax"
  "HOL-Library.Prefix_Order"
  "Optics.Lens_Instances"
begin

subsection \<open> Useful Abbreviations \<close>

abbreviation "list_sum xs \<equiv> foldr (+) xs 0"

subsection \<open> Sets \<close>

lemma set_Fpow [simp]: "set xs \<in> Fpow A \<longleftrightarrow> set xs \<subseteq> A"
  by (auto simp add: Fpow_def)

lemma Fpow_as_Pow: "finite A \<Longrightarrow> Fpow A = Pow A"
  by (auto simp add: Pow_def Fpow_def finite_subset)

lemma Fpow_set [code]:
  "Fpow (set []) = {{}}"
  "Fpow (set (x # xs)) = (let A = Fpow (set xs) in A \<union> insert x ` A)"
  by (simp_all add: Fpow_as_Pow Pow_set del: set_simps)

subsection \<open> Folds \<close>

context abel_semigroup
begin

  lemma foldr_snoc: "foldr (\<^bold>*) (xs @ [x]) k = (foldr (\<^bold>*) xs k) \<^bold>* x"
    by (induct xs, simp_all add: commute left_commute)

end

subsection \<open> List Lookup \<close>

text \<open>
  The following variant of the standard @{text nth} function returns @{text "\<bottom>"} if the index is
  out of range.
\<close>

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>\<^sub>l" [90, 0] 91)
where
  "[]\<langle>i\<rangle>\<^sub>l = None"
| "(x # xs)\<langle>i\<rangle>\<^sub>l = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>\<^sub>l)"

lemma nth_el_appendl[simp]: "i < length xs \<Longrightarrow> (xs @ ys)\<langle>i\<rangle>\<^sub>l = xs\<langle>i\<rangle>\<^sub>l"
  apply (induct xs arbitrary: i)
   apply simp
  apply (case_tac i)
   apply simp_all
  done

lemma nth_el_appendr[simp]: "length xs \<le> i \<Longrightarrow> (xs @ ys)\<langle>i\<rangle>\<^sub>l = ys\<langle>i - length xs\<rangle>\<^sub>l"
  apply (induct xs arbitrary: i)
   apply simp
  apply (case_tac i)
   apply simp_all
  done

subsection \<open> Extra List Theorems \<close>

subsubsection \<open> Map \<close>

lemma map_nth_Cons_atLeastLessThan:
  "map (nth (x # xs)) [Suc m..<n] = map (nth xs) [m..<n - 1]"
proof -
  have "nth xs = nth (x # xs) \<circ> Suc"
    by auto
  hence "map (nth xs) [m..<n - 1] = map (nth (x # xs) \<circ> Suc) [m..<n - 1]"
    by simp
  also have "... = map (nth (x # xs)) (map Suc [m..<n - 1])"
    by simp
  also have "... = map (nth (x # xs)) [Suc m..<n]"
    by (metis Suc_diff_1 le_0_eq length_upt list.simps(8) list.size(3) map_Suc_upt not_less upt_0)
  finally show ?thesis ..
qed

subsubsection \<open> Sorted Lists \<close>

lemma sorted_last [simp]: "\<lbrakk> x \<in> set xs; sorted xs \<rbrakk> \<Longrightarrow> x \<le> last xs"
  by (induct xs, auto)

lemma sorted_prefix:
  assumes "xs \<le> ys" "sorted ys"
  shows "sorted xs"
proof -
  obtain zs where "ys = xs @ zs"
    using Prefix_Order.prefixE assms(1) by auto
  thus ?thesis
    using assms(2) sorted_append by blast
qed

lemma sorted_map: "\<lbrakk> sorted xs; mono f \<rbrakk> \<Longrightarrow> sorted (map f xs)"
  by (simp add: monoD sorted_iff_nth_mono)

lemma sorted_distinct [intro]: "\<lbrakk> sorted (xs); distinct(xs) \<rbrakk> \<Longrightarrow> (\<forall> i<length xs - 1. xs!i < xs!(i + 1))"
  apply (induct xs)
   apply (auto)
  apply (metis (no_types, opaque_lifting) Suc_leI Suc_less_eq Suc_pred gr0_conv_Suc not_le not_less_iff_gr_or_eq nth_Cons_Suc nth_mem nth_non_equal_first_eq)
  done

text \<open> The concatenation of two lists is sorted provided (1) both the lists are sorted, and (2)
  the final and first elements are ordered. \<close>

lemma sorted_append_middle:
  "sorted(xs@ys) = (sorted xs \<and> sorted ys \<and> (xs \<noteq> [] \<and> ys \<noteq> [] \<longrightarrow> xs!(length xs - 1) \<le> ys!0))"
proof -
  have "\<And>x y. \<lbrakk> sorted xs; sorted ys; xs ! (length xs - Suc 0) \<le> ys ! 0 \<rbrakk> \<Longrightarrow> x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> x \<le> y"
  proof -
    fix x y
    assume "sorted xs" "sorted ys" "xs ! (length xs - Suc 0) \<le> ys ! 0" "x \<in> set xs" "y \<in> set ys"
    moreover then obtain i j where i: "x = xs!i" "i < length xs" and j: "y = ys!j" "j < length ys"
      by (auto simp add: in_set_conv_nth)
    moreover have "xs ! i \<le> xs!(length xs - 1)"
      by (metis One_nat_def Suc_diff_Suc Suc_leI Suc_le_mono \<open>i < length xs\<close> \<open>sorted xs\<close> diff_less diff_zero gr_implies_not_zero nat.simps(3) sorted_iff_nth_mono zero_less_iff_neq_zero)
    moreover have "ys!0 \<le> ys ! j"
      by (simp add: calculation(2) calculation(9) sorted_nth_mono)
    ultimately have "xs ! i \<le> ys ! j"
      by (metis One_nat_def dual_order.trans)
    thus "x \<le> y"
      by (simp add: i j)
  qed
  thus ?thesis
    by (auto simp add: sorted_append)
qed

text \<open> Is the given list a permutation of the given set? \<close>

definition is_sorted_list_of_set :: "('a::ord) set \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sorted_list_of_set A xs = ((\<forall> i<length(xs) - 1. xs!i < xs!(i + 1)) \<and> set(xs) = A)"

lemma sorted_is_sorted_list_of_set:
  assumes "is_sorted_list_of_set A xs"
  shows "sorted(xs)" and "distinct(xs)"
using assms proof (induct xs arbitrary: A)
  show "sorted []"
    by auto
next
  show "distinct []"
    by auto
next
  fix A :: "'a set"
  case (Cons x xs) note hyps = this
  assume isl: "is_sorted_list_of_set A (x # xs)"
  hence srt: "(\<forall>i<length xs - Suc 0. xs ! i < xs ! Suc i)"
    using less_diff_conv by (auto simp add: is_sorted_list_of_set_def)
  with hyps(1) have srtd: "sorted xs"
    by (simp add: is_sorted_list_of_set_def)
  with isl show "sorted (x # xs)"
    apply (auto simp add: is_sorted_list_of_set_def)
    apply (metis (mono_tags, lifting) all_nth_imp_all_set less_le_trans linorder_not_less not_less_iff_gr_or_eq nth_Cons_0 sorted_iff_nth_mono zero_order(3))
    done
  from srt hyps(2) have "distinct xs"
    by (simp add: is_sorted_list_of_set_def)
  with isl show "distinct (x # xs)"
  proof -
    have "(\<forall>n. \<not> n < length (x # xs) - 1 \<or> (x # xs) ! n < (x # xs) ! (n + 1)) \<and> set (x # xs) = A"
      by (meson \<open>is_sorted_list_of_set A (x # xs)\<close> is_sorted_list_of_set_def)
  then show ?thesis
    by (metis \<open>distinct xs\<close> add.commute add_diff_cancel_left' distinct.simps(2) leD length_Cons length_greater_0_conv length_pos_if_in_set less_le nth_Cons_0 nth_Cons_Suc plus_1_eq_Suc set_ConsD sorted_wrt.elims(2) srtd)
  qed
qed

term sorted

lemma is_sorted_list_of_set_alt_def:
  "is_sorted_list_of_set A xs \<longleftrightarrow> sorted (xs) \<and> distinct (xs) \<and> set(xs) = A"
  apply (auto intro: sorted_is_sorted_list_of_set)
    apply (auto simp add: is_sorted_list_of_set_def)
  apply (metis Nat.add_0_right One_nat_def add_Suc_right sorted_distinct)
  done

definition sorted_list_of_set_alt :: "('a::ord) set \<Rightarrow> 'a list" where
"sorted_list_of_set_alt A =
  (if (A = {}) then [] else (THE xs. is_sorted_list_of_set A xs))"

lemma is_sorted_list_of_set:
  "finite A \<Longrightarrow> is_sorted_list_of_set A (sorted_list_of_set A)"
  using sorted_distinct sorted_list_of_set(2) by (fastforce simp add: is_sorted_list_of_set_def)

lemma sorted_list_of_set_other_def:
  "finite A \<Longrightarrow> sorted_list_of_set(A) = (THE xs. sorted(xs) \<and> distinct(xs) \<and> set xs = A)"
  apply (rule sym)
  apply (rule the_equality)
   apply (auto)
  apply (simp add: sorted_distinct_set_unique)
  done

lemma sorted_list_of_set_alt [simp]:
  "finite A \<Longrightarrow> sorted_list_of_set_alt(A) = sorted_list_of_set(A)"
  apply (rule sym)
  apply (auto simp add: sorted_list_of_set_alt_def is_sorted_list_of_set_alt_def sorted_list_of_set_other_def)
  done

text \<open> Sorting lists according to a relation \<close>

definition is_sorted_list_of_set_by :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sorted_list_of_set_by R A xs = ((\<forall> i<length(xs) - 1. (xs!i, xs!(i + 1)) \<in> R) \<and> set(xs) = A)"

definition sorted_list_of_set_by :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list" where
"sorted_list_of_set_by R A = (THE xs. is_sorted_list_of_set_by R A xs)"

definition fin_set_lexord :: "'a rel \<Rightarrow> 'a set rel" where
"fin_set_lexord R = {(A, B). finite A \<and> finite B \<and>
                             (\<exists> xs ys. is_sorted_list_of_set_by R A xs \<and> is_sorted_list_of_set_by R B ys
                              \<and> (xs, ys) \<in> lexord R)}"

lemma is_sorted_list_of_set_by_mono:
  "\<lbrakk> R \<subseteq> S; is_sorted_list_of_set_by R A xs \<rbrakk> \<Longrightarrow> is_sorted_list_of_set_by S A xs"
  by (auto simp add: is_sorted_list_of_set_by_def)

lemma lexord_mono':
  "\<lbrakk> (\<And> x y. f x y \<longrightarrow> g x y); (xs, ys) \<in> lexord {(x, y). f x y} \<rbrakk> \<Longrightarrow> (xs, ys) \<in> lexord {(x, y). g x y}"
  by (metis case_prodD case_prodI lexord_take_index_conv mem_Collect_eq)

lemma fin_set_lexord_mono [mono]:
  "(\<And> x y. f x y \<longrightarrow> g x y) \<Longrightarrow> (xs, ys) \<in> fin_set_lexord {(x, y). f x y} \<longrightarrow> (xs, ys) \<in> fin_set_lexord {(x, y). g x y}"
proof
  assume
    fin: "(xs, ys) \<in> fin_set_lexord {(x, y). f x y}" and
    hyp: "(\<And> x y. f x y \<longrightarrow> g x y)"

  from fin have "finite xs" "finite ys"
    using fin_set_lexord_def by fastforce+

  with fin hyp show "(xs, ys) \<in> fin_set_lexord {(x, y). g x y}"
    apply (auto simp add: fin_set_lexord_def)
    apply (rename_tac xs' ys')
    apply (rule_tac x="xs'" in exI)
    apply (auto)
     apply (metis case_prodD case_prodI is_sorted_list_of_set_by_def mem_Collect_eq)
    apply (metis case_prodD case_prodI is_sorted_list_of_set_by_def lexord_mono' mem_Collect_eq)
    done
qed

definition distincts :: "'a set \<Rightarrow> 'a list set" where
"distincts A = {xs \<in> lists A. distinct(xs)}"

lemma tl_element:
  "\<lbrakk> x \<in> set xs; x \<noteq> hd(xs) \<rbrakk> \<Longrightarrow> x \<in> set(tl(xs))"
  by (metis in_set_insert insert_Nil list.collapse list.distinct(2) set_ConsD)

subsubsection \<open> List Update \<close>

lemma listsum_update:
  fixes xs :: "'a::ring list"
  assumes "i < length xs"
  shows "list_sum (xs[i := v]) = list_sum xs - xs ! i + v"
using assms proof (induct xs arbitrary: i)
  case Nil
  then show ?case by (simp)
next
  case (Cons a xs)
  then show ?case
  proof (cases i)
    case 0
    thus ?thesis
      by (simp add: add.commute)
  next
    case (Suc i')
    with Cons show ?thesis
      by (auto)
  qed
qed

subsubsection \<open> Drop While and Take While \<close>

lemma dropWhile_sorted_le_above:
  "\<lbrakk> sorted xs; x \<in> set (dropWhile (\<lambda> x. x \<le> n) xs) \<rbrakk> \<Longrightarrow> x > n"
  apply (induct xs)
   apply (auto)
  apply (rename_tac a xs)
  apply (case_tac "a \<le> n")
   apply (auto)
done

lemma set_dropWhile_le:
  "sorted xs \<Longrightarrow> set (dropWhile (\<lambda> x. x \<le> n) xs) = {x\<in>set xs. x > n}"
  apply (induct xs)
   apply (simp)
  apply (rename_tac x xs)
  apply (subgoal_tac "sorted xs")
   apply (simp)
   apply (safe)
     apply (auto)
done

lemma set_takeWhile_less_sorted:
  "\<lbrakk> sorted I; x \<in> set I; x < n \<rbrakk> \<Longrightarrow> x \<in> set (takeWhile (\<lambda>x. x < n) I)"
proof (induct I arbitrary: x)
  case Nil thus ?case
    by (simp)
next
  case (Cons a I) thus ?case
    by auto
qed

lemma nth_le_takeWhile_ord: "\<lbrakk> sorted xs; i \<ge> length (takeWhile (\<lambda> x. x \<le> n) xs); i < length xs \<rbrakk> \<Longrightarrow> n \<le> xs ! i"
  apply (induct xs arbitrary: i, auto)
  apply (rename_tac x xs i)
  apply (case_tac "x \<le> n")
   apply (auto)
  apply (metis One_nat_def Suc_eq_plus1 le_less_linear le_less_trans less_imp_le list.size(4) nth_mem set_ConsD)
  done

lemma length_takeWhile_less:
  "\<lbrakk> a \<in> set xs; \<not> P a \<rbrakk> \<Longrightarrow> length (takeWhile P xs) < length xs"
  by (metis in_set_conv_nth length_takeWhile_le nat_neq_iff not_less set_takeWhileD takeWhile_nth)

lemma nth_length_takeWhile_less:
  "\<lbrakk> sorted xs; distinct xs; (\<exists> a \<in> set xs. a \<ge> n) \<rbrakk> \<Longrightarrow> xs ! length (takeWhile (\<lambda>x. x < n) xs) \<ge> n"
  by (induct xs, auto)

subsubsection \<open> Last and But Last \<close>

lemma length_gt_zero_butlast_concat:
  assumes "length ys > 0"
  shows "butlast (xs @ ys) = xs @ (butlast ys)"
  using assms by (metis butlast_append length_greater_0_conv)

lemma length_eq_zero_butlast_concat:
  assumes "length ys = 0"
  shows "butlast (xs @ ys) = butlast xs"
  using assms by (metis append_Nil2 length_0_conv)

lemma butlast_single_element:
  shows "butlast [e] = []"
  by (metis butlast.simps(2))

lemma last_single_element:
  shows "last [e] = e"
  by (metis last.simps)

lemma length_zero_last_concat:
  assumes "length t = 0"
  shows "last (s @ t) = last s"
  by (metis append_Nil2 assms length_0_conv)

lemma length_gt_zero_last_concat:
  assumes "length t > 0"
  shows "last (s @ t) = last t"
  by (metis assms last_append length_greater_0_conv)

subsubsection \<open> Prefixes and Strict Prefixes \<close>

lemma prefix_length_eq:
  "\<lbrakk> length xs = length ys; prefix xs ys \<rbrakk> \<Longrightarrow> xs = ys"
  by (metis not_equal_is_parallel parallel_def)

lemma prefix_Cons_elim [elim]:
  assumes "prefix (x # xs) ys"
  obtains ys' where "ys = x # ys'" "prefix xs ys'"
  using assms
  by (metis append_Cons prefix_def)

lemma prefix_map_inj:
  "\<lbrakk> inj_on f (set xs \<union> set ys); prefix (map f xs) (map f ys) \<rbrakk> \<Longrightarrow>
   prefix xs ys"
  apply (induct xs arbitrary:ys)
   apply (simp_all)
  apply (erule prefix_Cons_elim)
  apply (auto)
  apply (metis image_insert insertI1 insert_Diff_if singletonE)
  done

lemma prefix_map_inj_eq [simp]:
  "inj_on f (set xs \<union> set ys) \<Longrightarrow>
   prefix (map f xs) (map f ys) \<longleftrightarrow> prefix xs ys"
  using map_mono_prefix prefix_map_inj by blast

lemma strict_prefix_Cons_elim [elim]:
  assumes "strict_prefix (x # xs) ys"
  obtains ys' where "ys = x # ys'" "strict_prefix xs ys'"
  using assms
  by (metis Sublist.strict_prefixE' Sublist.strict_prefixI' append_Cons)

lemma strict_prefix_map_inj:
  "\<lbrakk> inj_on f (set xs \<union> set ys); strict_prefix (map f xs) (map f ys) \<rbrakk> \<Longrightarrow>
   strict_prefix xs ys"
  apply (induct xs arbitrary:ys)
   apply (auto)
  using prefix_bot.not_eq_extremum apply fastforce
  apply (erule strict_prefix_Cons_elim)
  apply (auto)
  apply (metis (opaque_lifting, full_types) image_insert insertI1 insert_Diff_if singletonE)
  done

lemma strict_prefix_map_inj_eq [simp]:
  "inj_on f (set xs \<union> set ys) \<Longrightarrow>
   strict_prefix (map f xs) (map f ys) \<longleftrightarrow> strict_prefix xs ys"
  by (simp add: inj_on_map_eq_map strict_prefix_def)

lemma prefix_drop:
  "\<lbrakk> drop (length xs) ys = zs; prefix xs ys \<rbrakk>
   \<Longrightarrow> ys = xs @ zs"
  by (metis append_eq_conv_conj prefix_def)

lemma list_append_prefixD [dest]: "x @ y \<le> z \<Longrightarrow> x \<le> z"
  using append_prefixD less_eq_list_def by blast

lemma prefix_not_empty:
  assumes "strict_prefix xs ys" and "xs \<noteq> []"
  shows "ys \<noteq> []"
  using Sublist.strict_prefix_simps(1) assms(1) by blast

lemma prefix_not_empty_length_gt_zero:
  assumes "strict_prefix xs ys" and "xs \<noteq> []"
  shows "length ys > 0"
  using assms prefix_not_empty by auto

lemma butlast_prefix_suffix_not_empty:
  assumes "strict_prefix (butlast xs) ys"
  shows "ys \<noteq> []"
  using assms prefix_not_empty_length_gt_zero by fastforce

lemma prefix_and_concat_prefix_is_concat_prefix:
  assumes "prefix s t" "prefix (e @ t) u"
  shows "prefix (e @ s) u"
  using Sublist.same_prefix_prefix assms(1) assms(2) prefix_order.dual_order.trans by blast

lemma strict_prefix_eq_exists:
  "strict_prefix s t \<longleftrightarrow> (\<exists>xs . s @ xs = t \<and> (length xs) > 0)"
  using prefix_def strict_prefix_def by auto

lemma butlast_strict_prefix_eq_butlast:
  assumes "length s = length t" and "strict_prefix (butlast s) t"
  shows "strict_prefix (butlast s) t \<longleftrightarrow> (butlast s) = (butlast t)"
  by (metis append_butlast_last_id append_eq_append_conv assms(1) assms(2) length_0_conv length_butlast strict_prefix_eq_exists)

lemma butlast_eq_if_eq_length_and_prefix:
  assumes "length s > 0" "length z > 0"
          "length s = length z" "strict_prefix (butlast s) t" "strict_prefix (butlast z) t"
  shows   "(butlast s) = (butlast z)"
  using assms by (auto simp add:strict_prefix_eq_exists)

lemma prefix_imp_length_lteq:
  assumes "prefix s t"
  shows "length s \<le> length t"
  using assms by (simp add: Sublist.prefix_length_le)

lemma prefix_imp_length_not_gt:
  assumes "prefix s t"
  shows "\<not> length t < length s"
  using assms by (simp add: Sublist.prefix_length_le leD)

lemma prefix_and_eq_length_imp_eq_list:
  assumes "prefix s t" and "length t = length s"
  shows "s=t"
  using assms by (simp add: prefix_length_eq)

lemma butlast_prefix_imp_length_not_gt:
  assumes "length s > 0" "strict_prefix (butlast s) t"
  shows "\<not> (length t < length s)"
  using assms prefix_length_less by fastforce

lemma length_not_gt_iff_eq_length:
  assumes "length s > 0" and "strict_prefix (butlast s) t"
  shows "(\<not> (length s < length t)) = (length s = length t)"
proof -
  have "(\<not> (length s < length t)) = ((length t < length s) \<or> (length s = length t))"
      by (metis not_less_iff_gr_or_eq)
  also have "... = (length s = length t)"
      using assms
      by (simp add:butlast_prefix_imp_length_not_gt)

  finally show ?thesis .
qed

lemma list_prefix_iff:
  "(prefix xs ys \<longleftrightarrow> (length xs \<le> length ys \<and> (\<forall> i<length xs. xs!i = ys!i)))"
  apply (auto)
  apply (simp add: prefix_imp_length_lteq)
  apply (metis nth_append prefix_def)
  apply (metis nth_take_lemma order_refl take_all take_is_prefix)
  done

lemma list_le_prefix_iff:
  "(xs \<le> ys \<longleftrightarrow> (length xs \<le> length ys \<and> (\<forall> i<length xs. xs!i = ys!i)))"
  by (simp add: less_eq_list_def list_prefix_iff)

text \<open> Greatest common prefix \<close>

fun gcp :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"gcp [] ys = []" |
"gcp (x # xs) (y # ys) = (if (x = y) then x # gcp xs ys else [])" |
"gcp _ _ = []"

lemma gcp_right [simp]: "gcp xs [] = []"
  by (induct xs, auto)

lemma gcp_append [simp]: "gcp (xs @ ys) (xs @ zs) = xs @ gcp ys zs"
  by (induct xs, auto)

lemma gcp_lb1: "prefix (gcp xs ys) xs"
  apply (induct xs arbitrary: ys, auto)
  apply (case_tac ys, auto)
  done

lemma gcp_lb2: "prefix (gcp xs ys) ys"
  apply (induct ys arbitrary: xs, auto)
  apply (case_tac xs, auto)
  done

interpretation prefix_semilattice: semilattice_inf gcp prefix strict_prefix
proof
  fix xs ys :: "'a list"
  show "prefix (gcp xs ys) xs"
    by (induct xs arbitrary: ys, auto, case_tac ys, auto)
  show "prefix (gcp xs ys) ys"
    by (induct ys arbitrary: xs, auto, case_tac xs, auto)
next
  fix xs ys zs :: "'a list"
  assume "prefix xs ys" "prefix xs zs"
  thus "prefix xs (gcp ys zs)"
    by (simp add: prefix_def, auto)
qed

subsubsection \<open> Lexicographic Order \<close>

lemma lexord_append:
  assumes "(xs\<^sub>1 @ ys\<^sub>1, xs\<^sub>2 @ ys\<^sub>2) \<in> lexord R" "length(xs\<^sub>1) = length(xs\<^sub>2)"
  shows "(xs\<^sub>1, xs\<^sub>2) \<in> lexord R \<or> (xs\<^sub>1 = xs\<^sub>2 \<and> (ys\<^sub>1, ys\<^sub>2) \<in> lexord R)"
using assms
proof (induct xs\<^sub>2 arbitrary: xs\<^sub>1)
  case (Cons x\<^sub>2 xs\<^sub>2') note hyps = this
  from hyps(3) obtain x\<^sub>1 xs\<^sub>1' where xs\<^sub>1: "xs\<^sub>1 = x\<^sub>1 # xs\<^sub>1'" "length(xs\<^sub>1') = length(xs\<^sub>2')"
    by (auto, metis Suc_length_conv)
  with hyps(2) have xcases: "(x\<^sub>1, x\<^sub>2) \<in> R \<or> (xs\<^sub>1' @ ys\<^sub>1, xs\<^sub>2' @ ys\<^sub>2) \<in> lexord R"
    by (auto)
  show ?case
  proof (cases "(x\<^sub>1, x\<^sub>2) \<in> R")
    case True with xs\<^sub>1 show ?thesis
      by (auto)
  next
    case False
    with xcases have "(xs\<^sub>1' @ ys\<^sub>1, xs\<^sub>2' @ ys\<^sub>2) \<in> lexord R"
      by (auto)
    with hyps(1) xs\<^sub>1 have dichot: "(xs\<^sub>1', xs\<^sub>2') \<in> lexord R \<or> (xs\<^sub>1' = xs\<^sub>2' \<and> (ys\<^sub>1, ys\<^sub>2) \<in> lexord R)"
      by (auto)
    have "x\<^sub>1 = x\<^sub>2"
      using False hyps(2) xs\<^sub>1(1) by auto
    with dichot xs\<^sub>1 show ?thesis
      by (simp)
  qed
next
  case Nil thus ?case
    by auto
qed

lemma strict_prefix_lexord_rel:
  "strict_prefix xs ys \<Longrightarrow> (xs, ys) \<in> lexord R"
  by (metis Sublist.strict_prefixE' lexord_append_rightI)

lemma strict_prefix_lexord_left:
  assumes "trans R" "(xs, ys) \<in> lexord R" "strict_prefix xs' xs"
  shows "(xs', ys) \<in> lexord R"
  by (metis assms lexord_trans strict_prefix_lexord_rel)

lemma prefix_lexord_right:
  assumes "trans R" "(xs, ys) \<in> lexord R" "strict_prefix ys ys'"
  shows "(xs, ys') \<in> lexord R"
  by (metis assms lexord_trans strict_prefix_lexord_rel)

lemma lexord_eq_length:
  assumes "(xs, ys) \<in> lexord R" "length xs = length ys"
  shows "\<exists> i. (xs!i, ys!i) \<in> R \<and> i < length xs \<and> (\<forall> j<i. xs!j = ys!j)"
using assms proof (induct xs arbitrary: ys)
  case (Cons x xs) note hyps = this
  then obtain y ys' where ys: "ys = y # ys'" "length ys' = length xs"
    by (metis Suc_length_conv)
  show ?case
  proof (cases "(x, y) \<in> R")
    case True with ys show ?thesis
      by (rule_tac x="0" in exI, simp)
  next
    case False
    with ys hyps(2) have xy: "x = y" "(xs, ys') \<in> lexord R"
      by auto
    with hyps(1,3) ys obtain i where "(xs!i, ys'!i) \<in> R" "i < length xs" "(\<forall> j<i. xs!j = ys'!j)"
      by force
    with xy ys show ?thesis
      apply (rule_tac x="Suc i" in exI)
      apply (auto simp add: less_Suc_eq_0_disj)
    done
  qed
next
  case Nil thus ?case by (auto)
qed

lemma lexord_intro_elems:
  assumes "length xs > i" "length ys > i" "(xs!i, ys!i) \<in> R" "\<forall> j<i. xs!j = ys!j"
  shows "(xs, ys) \<in> lexord R"
using assms proof (induct i arbitrary: xs ys)
  case 0 thus ?case
    by (auto, metis lexord_cons_cons list.exhaust nth_Cons_0)
next
  case (Suc i) note hyps = this
  then obtain x' y' xs' ys' where "xs = x' # xs'" "ys = y' # ys'"
    by (metis Suc_length_conv Suc_lessE)
  moreover with hyps(5) have "\<forall>j<i. xs' ! j = ys' ! j"
    by (auto)
  ultimately show ?case using hyps
    by (auto)
qed

subsection \<open> Distributed Concatenation \<close>

definition uncurry :: "('a \<Rightarrow> 'b \<Rightarrow>  'c) \<Rightarrow> ('a \<times> 'b \<Rightarrow> 'c)" where
[simp]: "uncurry f = (\<lambda>(x, y). f x y)"

definition dist_concat ::
  "'a list set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<^sup>\<frown>" 100) where
"dist_concat ls1 ls2 = (uncurry (@) ` (ls1 \<times> ls2))"

lemma dist_concat_left_empty [simp]:
  "{} \<^sup>\<frown> ys = {}"
  by (simp add: dist_concat_def)

lemma dist_concat_right_empty [simp]:
  "xs \<^sup>\<frown> {} = {}"
  by (simp add: dist_concat_def)

lemma dist_concat_insert [simp]:
"insert l ls1 \<^sup>\<frown> ls2 = ((@) l ` ( ls2)) \<union> (ls1 \<^sup>\<frown> ls2)"
  by (auto simp add: dist_concat_def)

subsection \<open> List Domain and Range \<close>

abbreviation seq_dom :: "'a list \<Rightarrow> nat set" ("dom\<^sub>l") where
"seq_dom xs \<equiv> {0..<length xs}"

abbreviation (input) seq_ran :: "'a list \<Rightarrow> 'a set" ("ran\<^sub>l") where
"seq_ran xs \<equiv> set xs"

subsection \<open> Extracting List Elements \<close>

definition seq_extract :: "nat set \<Rightarrow> 'a list \<Rightarrow> 'a list" (infix "\<upharpoonleft>\<^sub>l" 80) where
"seq_extract A xs = nths xs A"

lemma seq_extract_Nil [simp]: "A \<upharpoonleft>\<^sub>l [] = []"
  by (simp add: seq_extract_def)

lemma seq_extract_Cons:
  "A \<upharpoonleft>\<^sub>l (x # xs) = (if 0 \<in> A then [x] else []) @ {j. Suc j \<in> A} \<upharpoonleft>\<^sub>l xs"
  by (simp add: seq_extract_def nths_Cons)

lemma seq_extract_empty [simp]: "{} \<upharpoonleft>\<^sub>l xs = []"
  by (simp add: seq_extract_def)

lemma seq_extract_ident [simp]: "{0..<length xs} \<upharpoonleft>\<^sub>l xs = xs"
  unfolding list_eq_iff_nth_eq
  by (auto simp add: seq_extract_def length_nths atLeast0LessThan)

lemma seq_extract_split:
  assumes "i \<le> length xs"
  shows "{0..<i} \<upharpoonleft>\<^sub>l xs @ {i..<length xs} \<upharpoonleft>\<^sub>l xs = xs"
using assms
proof (induct xs arbitrary: i)
  case Nil thus ?case by (simp add: seq_extract_def)
next
  case (Cons x xs) note hyp = this
  have "{j. Suc j < i} = {0..<i - 1}"
    by (auto)
  moreover have "{j. i \<le> Suc j \<and> j < length xs} = {i - 1..<length xs}"
    by (auto)
  ultimately show ?case
    using hyp by (force simp add: seq_extract_def nths_Cons)
qed

lemma seq_extract_append:
  "A \<upharpoonleft>\<^sub>l (xs @ ys) = (A \<upharpoonleft>\<^sub>l xs) @ ({j. j + length xs \<in> A} \<upharpoonleft>\<^sub>l ys)"
  by (simp add: seq_extract_def nths_append)

lemma seq_extract_range: "A \<upharpoonleft>\<^sub>l xs = (A \<inter> dom\<^sub>l(xs)) \<upharpoonleft>\<^sub>l xs"
  apply (auto simp add: seq_extract_def nths_def)
  apply (metis (no_types, lifting) atLeastLessThan_iff filter_cong in_set_zip nth_mem set_upt)
done

lemma seq_extract_out_of_range:
  "A \<inter> dom\<^sub>l(xs) = {} \<Longrightarrow> A \<upharpoonleft>\<^sub>l xs = []"
  by (metis seq_extract_def seq_extract_range nths_empty)

lemma seq_extract_length [simp]:
  "length (A \<upharpoonleft>\<^sub>l xs) = card (A \<inter> dom\<^sub>l(xs))"
proof -
  have "{i. i < length(xs) \<and> i \<in> A} = (A \<inter> {0..<length(xs)})"
    by (auto)
  thus ?thesis
    by (simp add: seq_extract_def length_nths)
qed

lemma seq_extract_Cons_atLeastLessThan:
  assumes "m < n"
  shows "{m..<n} \<upharpoonleft>\<^sub>l (x # xs) = (if (m = 0) then x # ({0..<n-1} \<upharpoonleft>\<^sub>l xs) else {m-1..<n-1} \<upharpoonleft>\<^sub>l xs)"
proof -
  have "{j. Suc j < n} = {0..<n - Suc 0}"
    by (auto)
  moreover have "{j. m \<le> Suc j \<and> Suc j < n} = {m - Suc 0..<n - Suc 0}"
    by (auto)

  ultimately show ?thesis using assms
    by (auto simp add: seq_extract_Cons)
qed

lemma seq_extract_singleton:
  assumes "i < length xs"
  shows "{i} \<upharpoonleft>\<^sub>l xs = [xs ! i]"
  using assms
  apply (induct xs arbitrary: i)
  apply (auto simp add: seq_extract_Cons)
  apply (rename_tac xs i)
  apply (subgoal_tac "{j. Suc j = i} = {i - 1}")
  apply (auto)
done

lemma seq_extract_as_map:
  assumes "m < n" "n \<le> length xs"
  shows "{m..<n} \<upharpoonleft>\<^sub>l xs = map (nth xs) [m..<n]"
using assms proof (induct xs arbitrary: m n)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  have "[m..<n] = m # [m+1..<n]"
    using Cons.prems(1) upt_eq_Cons_conv by blast
  moreover have "map (nth (x # xs)) [Suc m..<n] = map (nth xs) [m..<n-1]"
    by (simp add: map_nth_Cons_atLeastLessThan)
  ultimately show ?case
    using Cons upt_rec
    by (auto simp add: seq_extract_Cons_atLeastLessThan)
qed

lemma seq_append_as_extract:
  "xs = ys @ zs \<longleftrightarrow> (\<exists> i\<le>length(xs). ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length(xs)} \<upharpoonleft>\<^sub>l xs)"
proof
  assume xs: "xs = ys @ zs"
  moreover have "ys = {0..<length ys} \<upharpoonleft>\<^sub>l (ys @ zs)"
    by (simp add: seq_extract_append)
  moreover have "zs = {length ys..<length ys + length zs} \<upharpoonleft>\<^sub>l (ys @ zs)"
  proof -
    have "{length ys..<length ys + length zs} \<inter> {0..<length ys} = {}"
      by auto
    moreover have s1: "{j. j < length zs} = {0..<length zs}"
      by auto
    ultimately show ?thesis
      by (simp add: seq_extract_append seq_extract_out_of_range)
  qed
  ultimately show "(\<exists> i\<le>length(xs). ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length(xs)} \<upharpoonleft>\<^sub>l xs)"
    by (rule_tac x="length ys" in exI, auto)
next
  assume "\<exists>i\<le>length xs. ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length xs} \<upharpoonleft>\<^sub>l xs"
  thus "xs = ys @ zs"
    by (auto simp add: seq_extract_split)
qed

subsection \<open> Filtering a list according to a set \<close>

definition seq_filter :: "'a list \<Rightarrow> 'a set \<Rightarrow> 'a list" (infix "\<restriction>\<^sub>l" 80) where
"seq_filter xs A = filter (\<lambda> x. x \<in> A) xs"

lemma seq_filter_Cons_in [simp]:
  "x \<in> cs \<Longrightarrow> (x # xs) \<restriction>\<^sub>l cs = x # (xs \<restriction>\<^sub>l cs)"
  by (simp add: seq_filter_def)

lemma seq_filter_Cons_out [simp]:
  "x \<notin> cs \<Longrightarrow> (x # xs) \<restriction>\<^sub>l cs = (xs \<restriction>\<^sub>l cs)"
  by (simp add: seq_filter_def)

lemma seq_filter_Nil [simp]: "[] \<restriction>\<^sub>l A = []"
  by (simp add: seq_filter_def)

lemma seq_filter_empty [simp]: "xs \<restriction>\<^sub>l {} = []"
  by (simp add: seq_filter_def)

lemma seq_filter_append: "(xs @ ys) \<restriction>\<^sub>l A = (xs \<restriction>\<^sub>l A) @ (ys \<restriction>\<^sub>l A)"
  by (simp add: seq_filter_def)

lemma seq_filter_UNIV [simp]: "xs \<restriction>\<^sub>l UNIV = xs"
  by (simp add: seq_filter_def)

lemma seq_filter_twice [simp]: "(xs \<restriction>\<^sub>l A) \<restriction>\<^sub>l B = xs \<restriction>\<^sub>l (A \<inter> B)"
  by (simp add: seq_filter_def)

subsection \<open> Minus on lists \<close>

instantiation list :: (type) minus
begin

text \<open> We define list minus so that if the second list is not a prefix of the first, then an arbitrary
        list longer than the combined length is produced. Thus we can always determined from the output
        whether the minus is defined or not. \<close>

definition "xs - ys = (if (prefix ys xs) then drop (length ys) xs else [])"

instance ..
end

lemma minus_cancel [simp]: "xs - xs = []"
  by (simp add: minus_list_def)

lemma append_minus [simp]: "(xs @ ys) - xs = ys"
  by (simp add: minus_list_def)

lemma minus_right_nil [simp]: "xs - [] = xs"
  by (simp add: minus_list_def)

lemma list_concat_minus_list_concat: "(s @ t) - (s @ z) = t - z"
  by (simp add: minus_list_def)

lemma length_minus_list: "y \<le> x \<Longrightarrow> length(x - y) = length(x) - length(y)"
  by (simp add: less_eq_list_def minus_list_def)

lemma map_list_minus:
  "xs \<le> ys \<Longrightarrow> map f (ys - xs) = map f ys - map f xs"
  by (simp add: drop_map less_eq_list_def map_mono_prefix minus_list_def)

lemma list_minus_first_tl [simp]:
  "[x] \<le> xs \<Longrightarrow> (xs - [x]) = tl xs"
  by (metis Prefix_Order.prefixE append.left_neutral append_minus list.sel(3) not_Cons_self2 tl_append2)

text \<open> Extra lemmas about @{term prefix} and @{term strict_prefix} \<close>

lemma prefix_concat_minus:
  assumes "prefix xs ys"
  shows "xs @ (ys - xs) = ys"
  using assms by (metis minus_list_def prefix_drop)

lemma prefix_minus_concat:
  assumes "prefix s t"
  shows "(t - s) @ z = (t @ z) - s"
  using assms by (simp add: Sublist.prefix_length_le minus_list_def)

lemma strict_prefix_minus_not_empty:
  assumes "strict_prefix xs ys"
  shows "ys - xs \<noteq> []"
  using assms by (metis append_Nil2 prefix_concat_minus strict_prefix_def)

lemma strict_prefix_diff_minus:
  assumes "prefix xs ys" and "xs \<noteq> ys"
  shows "(ys - xs) \<noteq> []"
  using assms by (simp add: strict_prefix_minus_not_empty)

lemma length_tl_list_minus_butlast_gt_zero:
  assumes "length s < length t" and "strict_prefix (butlast s) t" and "length s > 0"
  shows "length (tl (t - (butlast s))) > 0"
  using assms
  by (metis Nitpick.size_list_simp(2) butlast_snoc hd_Cons_tl length_butlast length_greater_0_conv length_tl less_trans nat_neq_iff strict_prefix_minus_not_empty prefix_order.dual_order.strict_implies_order prefix_concat_minus)

lemma list_minus_butlast_eq_butlast_list:
  assumes "length t = length s" and "strict_prefix (butlast s) t"
  shows "t - (butlast s) = [last t]"
  using assms
  by (metis append_butlast_last_id append_eq_append_conv butlast.simps(1) length_butlast less_numeral_extra(3) list.size(3) prefix_order.dual_order.strict_implies_order prefix_concat_minus prefix_length_less)

lemma butlast_strict_prefix_length_lt_imp_last_tl_minus_butlast_eq_last:
  assumes "length s > 0" "strict_prefix (butlast s) t" "length s < length t"
  shows "last (tl (t - (butlast s))) = (last t)"
  using assms by (metis last_append last_tl length_tl_list_minus_butlast_gt_zero less_numeral_extra(3) list.size(3) append_minus strict_prefix_eq_exists)

lemma tl_list_minus_butlast_not_empty:
  assumes "strict_prefix (butlast s) t" and "length s > 0" and "length t > length s"
  shows "tl (t - (butlast s)) \<noteq> []"
  using assms length_tl_list_minus_butlast_gt_zero by fastforce

lemma tl_list_minus_butlast_empty:
  assumes "strict_prefix (butlast s) t" and "length s > 0" and "length t = length s"
  shows "tl (t - (butlast s)) = []"
  using assms by (simp add: list_minus_butlast_eq_butlast_list)

lemma concat_minus_list_concat_butlast_eq_list_minus_butlast:
  assumes "prefix (butlast u) s"
  shows "(t @ s) - (t @ (butlast u)) = s - (butlast u)"
  using assms by (metis append_assoc prefix_concat_minus append_minus)

lemma tl_list_minus_butlast_eq_empty:
  assumes "strict_prefix (butlast s) t" and "length s = length t"
  shows "tl (t - (butlast s)) = []"
  using assms by (metis list.sel(3) list_minus_butlast_eq_butlast_list)

(* this can be shown using length_tl, but care is needed when list is empty? *)
lemma prefix_length_tl_minus:
  assumes "strict_prefix s t"
  shows "length (tl (t-s)) = (length (t-s)) - 1"
  by (auto)

lemma length_list_minus:
  assumes "strict_prefix s t"
  shows "length(t - s) = length(t) - length(s)"
  using assms by (simp add: minus_list_def prefix_order.dual_order.strict_implies_order)

lemma length_minus_le: "length (ys - xs) \<le> length ys"
  by (simp add: minus_list_def)

lemma length_minus_less: "\<lbrakk> xs \<le> ys; xs \<noteq> [] \<rbrakk> \<Longrightarrow> length (ys - xs) < length ys"
  by (auto simp add: minus_list_def less_eq_list_def)
     (metis diff_less length_greater_0_conv prefix_bot.extremum_uniqueI)

lemma filter_minus [simp]: "ys \<le> xs \<Longrightarrow> filter P (xs - ys) = filter P xs - filter P ys"
  by (simp add: minus_list_def less_eq_list_def filter_mono_prefix)
     (metis filter_append filter_mono_prefix prefix_drop same_append_eq)

subsection \<open> Laws on @{term list_update} \<close>

lemma list_update_0: "length(xs) > 0 \<Longrightarrow> xs[0 := x] = x # tl xs"
  by (metis length_0_conv list.collapse list_update_code(2) nat_less_le)

lemma tl_list_update: "\<lbrakk> length xs > 0; k > 0 \<rbrakk> \<Longrightarrow> tl(xs[k := v]) = (tl xs)[k-1 := v]"
  by (metis One_nat_def Suc_pred length_greater_0_conv list.collapse list.sel(3) list_update_code(3))

subsection \<open> Laws on @{term take}, @{term drop}, and @{term nths} \<close>

lemma take_prefix: "m \<le> n \<Longrightarrow> take m xs \<le> take n xs"
  by (metis Prefix_Order.prefixI append_take_drop_id min_absorb2 take_append take_take)

lemma nths_atLeastAtMost_0_take: "nths xs {0..m} = take (Suc m) xs"
  by (metis atLeast0AtMost lessThan_Suc_atMost nths_upt_eq_take)

lemma nths_atLeastLessThan_0_take: "nths xs {0..<m} = take m xs"
  by (simp add: atLeast0LessThan)

lemma nths_atLeastAtMost_prefix: "m \<le> n \<Longrightarrow> nths xs {0..m} \<le> nths xs {0..n}"
  by (simp add: nths_atLeastAtMost_0_take take_prefix)

lemma sorted_nths_atLeastAtMost_0: "\<lbrakk> m \<le> n; sorted (nths xs {0..n}) \<rbrakk> \<Longrightarrow> sorted (nths xs {0..m})"
  using nths_atLeastAtMost_prefix sorted_prefix by blast

lemma sorted_nths_atLeastLessThan_0: "\<lbrakk> m \<le> n; sorted (nths xs {0..<n}) \<rbrakk> \<Longrightarrow> sorted (nths xs {0..<m})"
  by (metis atLeast0LessThan nths_upt_eq_take sorted_prefix take_prefix)

lemma list_augment_as_update:
  "k < length xs \<Longrightarrow> list_augment xs k x = list_update xs k x"
  by (metis list_augment_def list_augment_idem list_update_overwrite)

lemma nths_list_update_out: "k \<notin> A \<Longrightarrow> nths (list_update xs k x) A = nths xs A"
  apply (induct xs arbitrary: k x A)
   apply (auto)
  apply (rename_tac a xs k x A)
  apply (case_tac k)
   apply (auto simp add: nths_Cons)
  done

lemma nths_list_augment_out: "\<lbrakk> k < length xs; k \<notin> A \<rbrakk> \<Longrightarrow> nths (list_augment xs k x) A = nths xs A"
  by (simp add: list_augment_as_update nths_list_update_out)

lemma nths_none: "\<forall>i \<in> I. i \<ge> length xs \<Longrightarrow> nths xs I = []"
  apply (simp add: nths_def)
  apply (subst filter_False)
   apply (metis atLeastLessThan_iff in_set_zip leD nth_mem set_upt)
  apply simp
  done

lemma nths_uptoLessThan:
  "\<lbrakk> m \<le> n; n < length xs \<rbrakk> \<Longrightarrow> nths xs {m..n} = xs ! m # nths xs {Suc m..n}"
proof (induct xs arbitrary: m n)
case Nil
  then show ?case by (simp)
next
  case (Cons a xs)
  have l1: "\<And> m n. \<lbrakk> 0 < m; m \<le> n \<rbrakk> \<Longrightarrow> {j. m \<le> Suc j \<and> Suc j \<le> n} = {m-1..n-1}"
    by (auto)
  have l2: "\<And> m n. \<lbrakk> 0 < m; m \<le> n \<rbrakk> \<Longrightarrow> {j. m \<le> j \<and> Suc j \<le> n} = {m..n-1}"
    by (auto)
  from Cons show ?case by (auto simp add: nths_Cons l1 l2)
qed

lemma nths_upt_nth: "\<lbrakk> j < i; i < length xs \<rbrakk> \<Longrightarrow> (nths xs {0..<i}) ! j = xs ! j"
  by (metis lessThan_atLeast0 nth_take nths_upt_eq_take)

lemma nths_upt_length: "\<lbrakk> m \<le> n; n \<le> length xs \<rbrakk> \<Longrightarrow> length (nths xs {m..<n}) = n-m"
  by (metis atLeastLessThan_empty diff_is_0_eq length_map length_upt list.size(3) not_less nths_empty seq_extract_as_map seq_extract_def)

lemma nths_upt_le_length:
  "\<lbrakk> m \<le> n; Suc n \<le> length xs \<rbrakk> \<Longrightarrow> length (nths xs {m..n}) = Suc n - m"
  by (metis atLeastLessThanSuc_atLeastAtMost le_SucI nths_upt_length)

lemma sl1: "n > 0 \<Longrightarrow> {j. Suc j \<le> n} = {0..n-1}"
  by (auto)

lemma sl2: "\<lbrakk> 0 < m; m \<le> n \<rbrakk> \<Longrightarrow> {j. m \<le> Suc j \<and> Suc j \<le> n} = {m-1..n-1}"
  by auto

lemma nths_upt_le_nth: "\<lbrakk> m \<le> n; Suc n \<le> length xs; i < Suc n - m \<rbrakk>
  \<Longrightarrow> (nths xs {m..n}) ! i = xs ! (i + m)"
proof (induct xs arbitrary: m n i)
  case Nil
  then show ?case by (simp)
next
  case (Cons a xs)
  then show ?case
  proof (cases "i = 0")
    case True
    with Cons show ?thesis by (auto simp add: nths_Cons sl2)
  next
    case False
    with Cons show ?thesis by (auto simp add: nths_Cons sl1 sl2)
  qed
qed

lemma nths_split_union:
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> B \<Longrightarrow> x < y"
  shows "nths l A @ nths l B = nths l (A \<union> B)"
proof (induct l rule: rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc x xs)
  { assume *: "length xs \<notin> (A \<union> B)"
    then have L: "nths (xs @ [x]) (A \<union> B) = nths xs (A \<union> B)"
      by (simp add: nths_append)
    from * have R: "nths (xs @ [x]) A = nths xs A" "nths (xs @ [x]) B = nths xs B"
      by (simp add: nths_append)+
    have ?case
      using L R snoc by presburger
  } note length_notin = this

  { assume *: "length xs \<in> (A \<union> B)"
    then have new_nths: "nths (xs @ [x]) (A \<union> B) = nths xs (A \<union> B) @ [x]"
      by (simp add: nths_append)
    from * consider (A) "length xs \<in> A" | (B) "length xs \<in> B"
      using assms by auto
    then have ?case
    proof cases
      case A
      then have "i \<in> B \<Longrightarrow> i > length xs" for i
        using assms by force
      then have nths_B: "nths (xs @ [x]) B = []"
        by (metis Suc_less_eq le_simps(2) length_Cons length_rotate1 nths_none rotate1.simps(2))
      from A have "nths (xs @ [x]) A = nths xs A @ [x]"
        by (simp add: nths_append)
      then have "nths (xs @ [x]) A @ nths (xs @ [x]) B = (nths xs A @ nths xs B) @ [x]"
        by (metis append_is_Nil_conv nths_B nths_append self_append_conv)
      then show ?thesis
        using snoc new_nths by presburger
    next
      case B
      then have "length xs \<notin> A"
        using assms by blast
      then have "nths (xs @ [x]) A = nths xs A"
        by (simp add: nths_append)
      moreover have "nths (xs @ [x]) B = nths xs B @ [x]"
        by (simp add: B nths_append)
      ultimately show ?thesis
        by (simp add: new_nths snoc)
    qed
  } note length_in=this

  show ?case
    using length_in length_notin by blast
qed

corollary nths_upt_le_append_split:
  "j \<le> i \<Longrightarrow> nths xs {0..<j} @ nths xs {j..i} = nths xs {0..i}"
proof -
  assume "j \<le> i"
  have "\<And>x y. x \<in> {0..<j} \<Longrightarrow> y \<in> {j..i} \<Longrightarrow> x < y"
    by auto
  then have "nths xs {0..<j} @ nths xs {j..i} = nths xs ({0..<j} \<union> {j..i})"
    by (rule nths_split_union)
  moreover have "{0..<j} \<union> {j..i} = {0..i}"
    by (simp add: ivl_disj_un_two(7) \<open>j \<le> i\<close>)
  ultimately show ?thesis
    using \<open>j \<le> i\<close> by presburger
qed

lemma nths_Cons_atLeastAtMost: "n > m \<Longrightarrow> nths (x # xs) {m..n} = (if m = 0 then x # nths xs {0..n-1} else nths xs {m-1..n-1})"
  apply (auto simp add: nths_Cons)
  using One_nat_def sl1 apply presburger
  using One_nat_def le_eq_less_or_eq sl2 apply presburger
  done

lemma nths_atLeastAtMost_eq_drop_take: "nths xs {m..n} = drop m (take (n+1) xs)"
  by (induct xs rule: rev_induct, simp_all split: nat_diff_split add: nths_append, linarith)

lemma drop_as_map: "drop m xs = map (nth xs) [m..<length xs]"
  by (metis add.commute add.right_neutral drop_map drop_upt map_nth)

lemma take_as_map: "take m xs = map (nth xs) [0..<min m (length xs)]"
  by (metis (no_types, lifting) add_0 map_nth min.cobounded2 min.commute min_def take_all_iff take_map take_upt)

lemma nths_atLeastAtMost_as_map: "nths xs {m..n} = map (\<lambda> i. xs ! i) [m..<min (n+1) (length xs)]"
  by (simp add: nths_atLeastAtMost_eq_drop_take drop_as_map take_as_map)

lemma nths_single: "nths xs {k} = (if k < length xs then [xs ! k] else [])"
  using nths_atLeastAtMost_as_map[of xs k k] by simp

lemma nths_list_update_in_range: "k \<in> {m..n} \<Longrightarrow> nths (list_update xs k x) {m..n} = list_update (nths xs {m..n}) (k - m) x"
proof (induct xs arbitrary: k x m n)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case
  proof (cases k)
    case 0
    then show ?thesis apply (simp)
      by (smt (verit, best) Cons.prems append_Cons list_update_code(2) nths_Cons)
  next
    case (Suc nat)
    with Cons show ?thesis
    proof (cases n m rule: linorder_cases)
      case less
      then show ?thesis
        by force
    next
      case equal
      with Suc show ?thesis
        by (cases k, force)
           (metis (no_types, opaque_lifting) Cons.prems nths_single atLeastAtMost_singleton diff_is_0_eq' length_list_update list_update_code(2) list_update_code(3) list_update_nonempty nle_le nth_list_update_eq singletonD)
    next
      case greater
      with Suc Cons(1)[of nat "m - Suc 0" "n - Suc 0" x] show ?thesis
        by (cases k, auto simp add: nths_Cons_atLeastAtMost nths_atLeastAtMost_0_take take_update_swap)
           (metis Cons.prems Suc_le_mono Suc_pred atLeastAtMost_iff dual_order.strict_trans)
    qed
  qed
qed

lemma length_nths_atLeastAtMost [simp]: "length (nths xs {m..n}) = min (Suc n) (length xs) - m"
  by (simp add: nths_atLeastAtMost_as_map)

lemma hd_nths_atLeastAtMost: "\<lbrakk> m < length xs; m \<le> n \<rbrakk> \<Longrightarrow> hd (nths xs {m..n}) = xs ! m"
  by (simp add: nths_atLeastAtMost_as_map upt_conv_Cons)

lemma tl_nths_atLeastAtMost: "tl (nths xs {m..n}) = nths xs {Suc m..n}"
  by (simp add: nths_atLeastAtMost_as_map, metis map_tl tl_upt)

lemma set_nths_atLeastAtMost: "set (nths xs {m..n}) = {xs!i | i. m \<le> i \<and> i \<le> n \<and> i < length xs}"
  by (auto simp add: nths_atLeastAtMost_as_map)

lemma nths_atLeastAtMost_neq_Nil [simp]: "\<lbrakk> m \<le> n; length xs > m \<rbrakk> \<Longrightarrow> nths xs {m..n} \<noteq> []"
  by (force simp add: nths_atLeastAtMost_as_map)

lemma nths_atLeastAtMost_head: "\<lbrakk> m \<le> n; m < length xs \<rbrakk> \<Longrightarrow> nths xs {m..n} = xs ! m # (nths xs {Suc m..n})"
  by (simp add: nths_atLeastAtMost_as_map upt_conv_Cons)

lemma sorted_hd_le_all: "\<lbrakk> xs \<noteq> []; sorted xs; x \<in> set xs \<rbrakk> \<Longrightarrow> hd xs \<le> x"
  by (metis Orderings.order_eq_iff list.sel(1) list.set_cases sorted_simps(2))

subsection \<open> List power \<close>

overloading
  listpow \<equiv> "compow :: nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
begin

fun listpow :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "listpow 0 xs = []"
| "listpow (Suc n) xs = xs @ listpow n xs"

end

lemma listpow_Nil [simp]: "[] ^^ n = []"
  by (induct n) simp_all

lemma listpow_Suc_right: "xs ^^ Suc n = xs ^^ n @ xs"
  by (induct n) simp_all

lemma listpow_add: "xs ^^ (m + n) = xs ^^ m @ xs ^^ n"
  by (induct m) simp_all

subsection \<open> Alternative List Lexicographic Order \<close>

text \<open> Since we can't instantiate the order class twice for lists, and we want prefix as
  the default order for the UTP we here add syntax for the lexicographic order relation. \<close>

definition list_lex_less :: "'a::linorder list \<Rightarrow> 'a list \<Rightarrow> bool" (infix "<\<^sub>l" 50)
where "xs <\<^sub>l ys \<longleftrightarrow> (xs, ys) \<in> lexord {(u, v). u < v}"

lemma list_lex_less_neq [simp]: "x <\<^sub>l y \<Longrightarrow> x \<noteq> y"
  apply (simp add: list_lex_less_def)
  apply (meson case_prodD less_irrefl lexord_irreflexive mem_Collect_eq)
done

lemma not_less_Nil [simp]: "\<not> x <\<^sub>l []"
  by (simp add: list_lex_less_def)

lemma Nil_less_Cons [simp]: "[] <\<^sub>l a # x"
  by (simp add: list_lex_less_def)

lemma Cons_less_Cons [simp]: "a # x <\<^sub>l b # y \<longleftrightarrow> a < b \<or> a = b \<and> x <\<^sub>l y"
  by (simp add: list_lex_less_def)

subsection \<open> Bounded List Universe \<close>

text \<open> Analogous to @{const List.n_lists}, but includes all lists with a length up to the given number. \<close>

definition b_lists :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
"b_lists n xs = concat (map (\<lambda> n. List.n_lists n xs) [0..<Suc n])"

lemma b_lists_Nil [simp]: "b_lists n [] = [[]]"
  unfolding b_lists_def by (induct n) simp_all

lemma length_b_lists_elem: "ys \<in> set (b_lists n xs) \<Longrightarrow> length ys \<le> n"
  unfolding b_lists_def
  by (auto simp add: length_n_lists_elem)

lemma b_lists_in_lists: "ys \<in> set (b_lists n xs) \<Longrightarrow> ys \<in> lists (set xs)"
  by (auto simp add: b_lists_def in_mono set_n_lists)

lemma in_blistsI: "\<lbrakk> length xs \<le> n; xs \<in> lists (set A) \<rbrakk> \<Longrightarrow> xs \<in> set (b_lists n A)"
  apply (auto simp add: b_lists_def)
  apply (rule_tac x="length xs" in bexI)
   apply (auto simp add: set_n_lists subsetI)
  done

lemma ex_list_nonempty_carrier:
  assumes "A \<noteq> {}"
  obtains xs where "length xs = n" "set xs \<subseteq> A"
proof -
  obtain a where a: "a \<in> A"
    using assms by blast
  hence "set (replicate n a) \<subseteq> A"
    by (simp add: set_replicate_conv_if)
  with that show ?thesis
    by (meson length_replicate)
qed

lemma n_lists_inj:
  assumes "xs \<noteq> []" "List.n_lists m xs = List.n_lists n xs"
  shows "m = n"
proof (rule ccontr)
  assume mn: "m \<noteq> n"
  hence "m < n \<or> m > n"
    by auto
  moreover have "m < n \<longrightarrow> False"
  proof
    assume "m < n"
    then obtain ys where ys: "length ys = n" "set ys \<subseteq> set xs"
      by (metis all_not_in_conv assms(1) ex_list_nonempty_carrier length_0_conv neq0_conv nth_mem)
    hence "ys \<in> set (List.n_lists n xs)"
      by (simp add: set_n_lists)
    moreover have "ys \<notin> set (List.n_lists m xs)"
      using length_n_lists_elem mn ys(1) by blast
    ultimately show False
      by (simp add: assms(2))
  qed
  moreover have "m > n \<longrightarrow> False"
  proof
    assume "n < m"
    then obtain ys where ys: "length ys = m" "set ys \<subseteq> set xs"
      by (metis all_not_in_conv assms(1) ex_list_nonempty_carrier length_0_conv neq0_conv nth_mem)
    hence "ys \<in> set (List.n_lists m xs)"
      by (simp add: set_n_lists)
    moreover have "ys \<notin> set (List.n_lists n xs)"
      using length_n_lists_elem mn ys(1) by blast
    ultimately show False
      by (simp add: assms(2))
  qed
  ultimately show False
    by blast
qed

lemma distinct_b_lists: "distinct xs \<Longrightarrow> distinct (b_lists n xs)"
  apply (cases "xs = []")
  apply (simp)
  apply (auto simp add: b_lists_def)
    apply (rule distinct_concat)
  apply (simp add: distinct_map)
  apply (simp add: inj_onI n_lists_inj)
  using distinct_n_lists apply auto[1]
  apply (auto)
  using length_n_lists_elem apply blast
  apply (simp add: distinct_n_lists)
  using length_n_lists_elem apply blast
  done

definition blists :: "nat \<Rightarrow> 'a set \<Rightarrow> 'a list set" where
  "blists n A = {xs\<in>lists A. length xs \<le> n}"

lemma blists_b_lists [code]: "blists n (set xs) = set (b_lists n xs)"
  apply (auto simp add: blists_def in_blistsI in_listsI)
  apply (meson b_lists_in_lists in_lists_conv_set)
  apply (meson length_b_lists_elem)
  done

subsection \<open> Disjointness and Partitions \<close>

definition list_disjoint :: "'a set list \<Rightarrow> bool" where
"list_disjoint xs = (\<forall> i < length xs. \<forall> j < length xs. i \<noteq> j \<longrightarrow> xs!i \<inter> xs!j = {})"

definition list_partitions :: "'a set list \<Rightarrow> 'a set \<Rightarrow> bool" where
"list_partitions xs T = (list_disjoint xs \<and> \<Union> (set xs) = T)"

lemma list_disjoint_Nil [simp]: "list_disjoint []"
  by (simp add: list_disjoint_def)

lemma list_disjoint_Cons [simp]: "list_disjoint (A # Bs) = ((\<forall> B \<in> set Bs. A \<inter> B = {}) \<and> list_disjoint Bs)"
  apply (simp add: list_disjoint_def disjoint_iff)
  apply (auto)
  apply (metis Suc_less_eq in_set_conv_nth nat.distinct(1) neq0_conv nth_Cons_0 nth_Cons_Suc)
   apply (metis lessI lift_Suc_mono_less_iff nat.inject nth_Cons_Suc)
  apply (rename_tac i j x)
  apply (case_tac i)
  apply (simp_all)
  apply (metis less_Suc_eq_0_disj list.sel(3) nth_Cons' nth_mem nth_tl)
  done

subsection \<open> Code Generation \<close>

lemma set_singleton_iff: "set xs = {x} \<longleftrightarrow> remdups xs = [x]"
  apply (auto)
  apply (metis card_set empty_set insert_not_empty length_0_conv length_Suc_conv list.simps(15) remdups.simps(1) remdups.simps(2) set_remdups the_elem_set)
  apply (metis empty_iff empty_set set_ConsD set_remdups)
  apply (metis list.set_intros(1) set_remdups)
  done

lemma list_singleton_iff: "(\<exists> x. xs = [x]) \<longleftrightarrow> (length xs = 1)"
  by (auto simp add: length_Suc_conv)

end


theory GZF_Model_Base
  imports "../../ModelKit/ModelComponents"
begin

hide_const set ZFC_in_HOL.set

context ModelBase' begin
ML \<open>val set_model = mcomp
 { name = "GZF_Model",
   deps = mcomps [],
   variant = SOME (vari
    { tag_name = "set",
      vcases =
        (@{term \<open>\<emptyset>\<close>},
         @{term "(\<lambda>_ x. \<P> x) :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"},
         @{term "(\<lambda>_ _. \<emptyset>) :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"}),
       alpha_typ = @{term "Set"}
    }),
  excludes_formulas =
    [("not_set_excluded_mset", @{prop \<open>\<not> Excluded set <set, x'>\<close>})]
 }\<close>
end
local_setup \<open>snd o (mk_mcomp_class set_model)\<close>

lemma gzf_model_case_typ :
  assumes j : "j : Ord" and x : "x : Set"
  shows "caseof_ord \<emptyset> (\<P> x) \<emptyset> j : SetOf Set"
  by (rule case_ordE[OF j],
      use emp_set pow_setof[OF x] emp_setof in auto)

context GZF_Model begin

definition mSet :: \<open>'a \<Rightarrow> bool\<close>
  where "mSet \<equiv> M \<triangle> (\<^enum> set)"

definition mMem :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> (infix \<open>m\<close> 50)
where "x m y \<equiv> y : mSet \<and> x \<in> snd y"

definition mSetMem :: \<open>'a \<Rightarrow> bool\<close>
  where "mSetMem b \<equiv> m\<exists>x : mSet. b m x"

definition mSubset :: \<open>['a, 'a] \<Rightarrow> bool\<close>
  where "mSubset x y \<equiv> m\<forall>a. a m x \<longrightarrow> a m y"

definition mSetOf :: \<open>['a \<Rightarrow> bool, 'a] \<Rightarrow> bool\<close>
  where "mSetOf P x \<equiv> x : mSet \<and> (m\<forall>b. b m x \<longrightarrow> b : P)"

definition mReplPred :: \<open>['a, ['a,'a] \<Rightarrow> bool] \<Rightarrow> bool\<close>
  where "mReplPred x P \<equiv> m\<forall>a. a m x \<longrightarrow> (m\<exists>\<^sub>\<le>\<^sub>1 b : mSetMem. P a b)"

definition mUnion' :: \<open>'a \<Rightarrow> 'a\<close>
  where "mUnion' x \<equiv> <set, \<Union> y \<in> snd x. snd y>"

definition mUnion :: \<open>'a \<Rightarrow> 'a\<close> (\<open>m\<Union>\<close>)
  where "m\<Union> x \<equiv> if x : mSetOf mSet then mUnion' x
                                    else GZF_Model_mdefault"

definition mPow' :: \<open>'a \<Rightarrow> 'a\<close>
  where "mPow' x \<equiv> <set, set \<oplus> \<P> (snd x)>"

definition mPow :: \<open>'a \<Rightarrow> 'a\<close> (\<open>m\<P>\<close>)
  where "m\<P> x \<equiv> if x : mSet then mPow' x
                            else GZF_Model_mdefault"

definition mEmp :: \<open>'a\<close> (\<open>m\<emptyset>\<close>)
  where "mEmp = <set, \<emptyset>>"

definition mSucc' :: \<open>'a \<Rightarrow> 'a\<close>
  where "mSucc' x = mUnion' <set, {x, <set, {x}>}>"

definition mSucc :: \<open>'a \<Rightarrow> 'a\<close>
  where "mSucc x \<equiv> if x : mSet then mSucc' x
                      else GZF_Model_mdefault"

definition ord_to_mvnord :: \<open>'a \<Rightarrow> 'a\<close> (\<open>\<Theta>\<close>)
  where \<open>\<Theta> \<equiv> OrdRec (\<lambda>\<mu> f. <set, {f j | j < \<mu>}>) (\<lambda>_ x. mSucc x) m\<emptyset>\<close>

definition mInf :: \<open>'a\<close>
  where \<open>mInf \<equiv> \<Theta> \<omega>\<close>

definition mRepl' :: \<open>['a, ['a,'a] \<Rightarrow> bool] \<Rightarrow> 'a\<close>
  where "mRepl' x P \<equiv> <set, { b | \<exists> a \<in> snd x. P a b \<and> b : mSetMem }>"

definition mRepl :: \<open>['a, ['a,'a] \<Rightarrow> bool] \<Rightarrow> 'a\<close> (\<open>m\<R>\<close>)
  where "m\<R> x P \<equiv> if x : mSet \<and> P : mReplPred x
                    then mRepl' x P else GZF_Model_mdefault"

theorem variants_set :
  shows "Variants set 0 \<emptyset> = \<emptyset>"
    and "j : Ord   \<Longrightarrow> Variants set (succ j) x = \<P> x"
    and "\<mu> : Limit \<Longrightarrow> Variants set \<mu> f = \<emptyset>"
  using v_set_0 v_set_succ v_set_limit by auto

theorem tierI_mset :
  assumes j : "j : Ord" and x' : "x' : Set"
      and x'_sub: "x' \<subseteq> Tier j \<ominus> set"
    shows "<set,x'> \<in> Tier (succ j)"
proof -
  have "x' \<in> \<P> (Tier j \<ominus> set)"
    by (rule powI[OF x' tier_ex_set[OF j] x'_sub])
  hence "x' \<in> Variants set (succ j) (Tier j \<ominus> set)"
    unfolding variants_set(2)[OF j] by assumption
  thus "<set,x'> \<in> Tier (succ j)"
    by (rule tier_succI2[OF set_tag j])
qed

theorem tierD_mset :
  assumes j : "j : Ord"
      and x : "<set,x'> \<in> Tier (succ j)"
    shows "x' \<subseteq> Tier j \<ominus> set"
proof (rule tier_succE_pair[OF j x])
  show "<set,x'> \<in> Tier j \<Longrightarrow> x' \<subseteq> Tier j \<ominus> set"
  proof (induct rule: trans_induct3[OF j])
    case 1 then show ?case
      using tier0D(2) variants_set(1) by auto
  next
    case IH:(2 j)
    show ?case
    proof (rule tier_succE_pair[OF IH(1,3)])
      assume "<set,x'> \<in> Tier j"
      hence "x' \<subseteq> Tier j \<ominus> set" using IH(2) by auto
      thus "x' \<subseteq> Tier (succ j) \<ominus> set"
        using subset_trans[OF _ tier_ex_subset_succ[OF IH(1)]] by auto
    next
      assume "x' \<in> Variants set (succ j) (Tier j \<ominus> set)"
      hence "x' \<subseteq> Tier j \<ominus> set"
        unfolding variants_set(2)[OF IH(1)]
        using powD[OF tier_ex_set[OF IH(1)]] by auto
      thus "x' \<subseteq> Tier (succ j) \<ominus> set"
        using subset_trans[OF _ tier_ex_subset_succ[OF IH(1)]] by auto
    qed
  next
    case IH:(3 \<mu>)
    show ?case
    proof (rule tier_limE_pair[OF \<open>\<mu> : Limit\<close> \<open><set,x'> \<in> Tier \<mu>\<close>])
      fix j assume "j : Ord" "j < \<mu>" "<set,x'> \<in> Tier j"
      hence "x' \<subseteq> Tier j \<ominus> set" using IH(2) by auto
      thus "x' \<subseteq> Tier \<mu> \<ominus> set"
        using subset_trans[OF _ tier_limit_ex_subset[OF \<open>\<mu> : Limit\<close> \<open>j : Ord\<close> \<open>j < \<mu>\<close>]] by auto
    next
      show "x' \<in> Variants set \<mu> (\<lambda>j<\<mu>. Tier j \<ominus> set) \<Longrightarrow> x' \<subseteq> Tier \<mu> \<ominus> set"
        unfolding variants_set(3)[OF \<open>\<mu> : Limit\<close>] by auto
    qed
  qed
next
  assume "x' \<in> Variants set (succ j) (Tier j \<ominus> set)"
  thus "x' \<subseteq> Tier j \<ominus> set"
    unfolding variants_set(2)[OF j]
    using powD[OF tier_ex_set[OF j]] by auto
qed

theorem mI_mset :
  assumes j: "j : Ord" and x':"x' : Set"
      and x'_sub : "x' \<subseteq> Tier j \<ominus> set"
    shows "<set,x'> : M"
  using mI[OF succ_ord[OF j]] tierI_mset[OF j x' x'_sub] by auto

theorem mE_mset :
  assumes x : "<set,x'> : M"
  obtains j where "j : Ord" "x' \<subseteq> Tier j \<ominus> set"
proof (rule m_cases_pair[OF x], use variants_set in auto)
  fix j assume "j : Ord" "x' \<in> \<P> (Tier j \<ominus> set)"
  hence "j : Ord" "x' \<subseteq> Tier j \<ominus> set"
    using powD[OF tier_ex_set] by auto
  thus ?thesis ..
qed

end
end


(*  Title:      ZF/IMP/Denotation.thy
    Author:     Heiko Loetzbeyer and Robert Sandner, TU München
*)

section {* Denotational semantics of expressions and commands *}

theory Denotation imports Com begin

subsection {* Definitions *}

consts
  A     :: "i => i => i"
  B     :: "i => i => i"
  C     :: "i => i"

definition
  Gamma :: "[i,i,i] => i"  ("\<Gamma>") where
  "\<Gamma>(b,cden) ==
    (\<lambda>phi. {io \<in> (phi O cden). B(b,fst(io))=1} \<union>
           {io \<in> id(loc->nat). B(b,fst(io))=0})"

primrec
  "A(N(n), sigma) = n"
  "A(X(x), sigma) = sigma`x"
  "A(Op1(f,a), sigma) = f`A(a,sigma)"
  "A(Op2(f,a0,a1), sigma) = f`<A(a0,sigma),A(a1,sigma)>"

primrec
  "B(true, sigma) = 1"
  "B(false, sigma) = 0"
  "B(ROp(f,a0,a1), sigma) = f`<A(a0,sigma),A(a1,sigma)>"
  "B(noti(b), sigma) = not(B(b,sigma))"
  "B(b0 andi b1, sigma) = B(b0,sigma) and B(b1,sigma)"
  "B(b0 ori b1, sigma) = B(b0,sigma) or B(b1,sigma)"

primrec
  "C(\<SKIP>) = id(loc->nat)"
  "C(x \<ASSN> a) =
    {io \<in> (loc->nat) \<times> (loc->nat). snd(io) = fst(io)(x := A(a,fst(io)))}"
  "C(c0\<SEQ> c1) = C(c1) O C(c0)"
  "C(\<IF> b \<THEN> c0 \<ELSE> c1) =
    {io \<in> C(c0). B(b,fst(io)) = 1} \<union> {io \<in> C(c1). B(b,fst(io)) = 0}"
  "C(\<WHILE> b \<DO> c) = lfp((loc->nat) \<times> (loc->nat), \<Gamma>(b,C(c)))"

subsection {* Misc lemmas *}

lemma A_type [TC]: "[|a \<in> aexp; sigma \<in> loc->nat|] ==> A(a,sigma) \<in> nat"
  by (erule aexp.induct) simp_all

lemma B_type [TC]: "[|b \<in> bexp; sigma \<in> loc->nat|] ==> B(b,sigma) \<in> bool"
by (erule bexp.induct, simp_all)

lemma C_subset: "c \<in> com ==> C(c) \<subseteq> (loc->nat) \<times> (loc->nat)"
  apply (erule com.induct)
      apply simp_all
      apply (blast dest: lfp_subset [THEN subsetD])+
  done

lemma C_type_D [dest]:
    "[| <x,y> \<in> C(c); c \<in> com |] ==> x \<in> loc->nat & y \<in> loc->nat"
  by (blast dest: C_subset [THEN subsetD])

lemma C_type_fst [dest]: "[| x \<in> C(c); c \<in> com |] ==> fst(x) \<in> loc->nat"
  by (auto dest!: C_subset [THEN subsetD])

lemma Gamma_bnd_mono:
  "cden \<subseteq> (loc->nat) \<times> (loc->nat)
    ==> bnd_mono ((loc->nat) \<times> (loc->nat), \<Gamma>(b,cden))"
  by (unfold bnd_mono_def Gamma_def) blast

end


(* Author:     Amine Chaieb, TU Muenchen *)

section {* Examples for Ferrante and Rackoff's quantifier elimination procedure *}

theory Dense_Linear_Order_Ex
imports "../Dense_Linear_Order"
begin

lemma
  "\<exists>(y::'a::{linordered_field_inverse_zero}) <2. x + 3* y < 0 \<and> x - y >0"
  by ferrack

lemma "~ (ALL x (y::'a::{linordered_field_inverse_zero}). x < y --> 10*x < 11*y)"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y. x < y --> (10*(x + 5*y + -1) < 60*y)"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y. x ~= y --> x < y"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y. (x ~= y & 10*x ~= 9*y & 10*x < y) --> x < y"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y. (x ~= y & 5*x <= y) --> 500*x <= 100*y"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}). (EX (y::'a::{linordered_field_inverse_zero}). 4*x + 3*y <= 0 & 4*x + 3*y >= -1)"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) < 0. (EX (y::'a::{linordered_field_inverse_zero}) > 0. 7*x + y > 0 & x - y <= 9)"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}). (0 < x & x < 1) --> (ALL y > 1. x + y ~= 1)"
  by ferrack

lemma "EX x. (ALL (y::'a::{linordered_field_inverse_zero}). y < 2 -->  2*(y - x) \<le> 0 )"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}). x < 10 | x > 20 | (EX y. y>= 0 & y <= 10 & x+y = 20)"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y z. x + y < z --> y >= z --> x < 0"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y z. x + 7*y < 5* z & 5*y >= 7*z & x < 0"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y z. abs (x + y) <= z --> (abs z = z)"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y z. x + 7*y - 5* z < 0 & 5*y + 7*z + 3*x < 0"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y z. (abs (5*x+3*y+z) <= 5*x+3*y+z & abs (5*x+3*y+z) >= - (5*x+3*y+z)) | (abs (5*x+3*y+z) >= 5*x+3*y+z & abs (5*x+3*y+z) <= - (5*x+3*y+z))"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y. x < y --> (EX z>0. x+z = y)"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y. x < y --> (EX z>0. x+z = y)"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y. (EX z>0. abs (x - y) <= z )"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y. (ALL z>=0. abs (3*x+7*y) <= 2*z + 1)"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero})>0. (ALL y. (EX z. 13* abs z \<noteq> abs (12*y - x) & 5*x - 3*(abs y) <= 7*z))"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}). abs (4*x + 17) < 4 & (ALL y . abs (x*34 - 34*y - 9) \<noteq> 0 \<longrightarrow> (EX z. 5*x - 3*abs y <= 7*z))"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}). (EX y > abs (23*x - 9). (ALL z > abs (3*y - 19* abs x). x+z > 2*y))"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}). (EX y< abs (3*x - 1). (ALL z >= (3*abs x - 1). abs (12*x - 13*y + 19*z) > abs (23*x) ))"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}). abs x < 100 & (ALL y > x. (EX z<2*y - x. 5*x - 3*y <= 7*z))"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y z w. 7*x<3*y --> 5*y < 7*z --> z < 2*w --> 7*(2*w-x) > 2*y"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y z w. 5*x + 3*z - 17*w + abs (y - 8*x + z) <= 89"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y z w. 5*x + 3*z - 17*w + 7* (y - 8*x + z) <= max y (7*z - x + w)"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y z. (EX w >= (x+y+z). w <= abs x + abs y + abs z)"
  by ferrack

lemma "~(ALL (x::'a::{linordered_field_inverse_zero}). (EX y z w. 3* x + z*4 = 3*y & x + y < z & x> w & 3*x < w + y))"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y. (EX z w. abs (x-y) = (z-w) & z*1234 < 233*x & w ~= y)"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}). (EX y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w))"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y z. (ALL w >= abs (x+y+z). w >= abs x + abs y + abs z)"
  by ferrack

lemma "EX z. (ALL (x::'a::{linordered_field_inverse_zero}) y. (EX w >= (x+y+z). w <= abs x + abs y + abs z))"
  by ferrack

lemma "EX z. (ALL (x::'a::{linordered_field_inverse_zero}) < abs z. (EX y w. x< y & x < z & x> w & 3*x < w + y))"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}) y. (EX z. (ALL w. abs (x-y) = abs (z-w) --> z < x & w ~= y))"
  by ferrack

lemma "EX y. (ALL (x::'a::{linordered_field_inverse_zero}). (EX z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)))"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) z. (ALL w >= 13*x - 4*z. (EX y. w >= abs x + abs y + z))"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}). (ALL y < x. (EX z > (x+y).
  (ALL w. 5*w + 10*x - z >= y --> w + 7*x + 3*z >= 2*y)))"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}). (ALL y. (EX z > y.
  (ALL w . w < 13 --> w + 10*x - z >= y --> 5*w + 7*x + 13*z >= 2*y)))"
  by ferrack

lemma "EX (x::'a::{linordered_field_inverse_zero}) y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}). (EX y. (ALL z>19. y <= x + z & (EX w. abs (y - x) < w)))"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}). (EX y. (ALL z>19. y <= x + z & (EX w. abs (x + z) < w - y)))"
  by ferrack

lemma "ALL (x::'a::{linordered_field_inverse_zero}). (EX y. abs y ~= abs x & (ALL z> max x y. (EX w. w ~= y & w ~= z & 3*w - z >= x + y)))"
  by ferrack

end


(*  Title:      ZF/Bin.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

   The sign Pls stands for an infinite string of leading 0's.
   The sign Min stands for an infinite string of leading 1's.

A number can have multiple representations, namely leading 0's with sign
Pls and leading 1's with sign Min.  See twos-compl.ML/int_of_binary for
the numerical interpretation.

The representation expects that (m mod 2) is 0 or 1, even if m is negative;
For instance, ~5 div 2 = ~3 and ~5 mod 2 = 1; thus ~5 = (~3)*2 + 1
*)

section{*Arithmetic on Binary Integers*}

theory Bin
imports Int_ZF Datatype_ZF
begin

consts  bin :: i
datatype
  "bin" = Pls
        | Min
        | Bit ("w \<in> bin", "b \<in> bool")     (infixl "BIT" 90)

consts
  integ_of  :: "i=>i"
  NCons     :: "[i,i]=>i"
  bin_succ  :: "i=>i"
  bin_pred  :: "i=>i"
  bin_minus :: "i=>i"
  bin_adder :: "i=>i"
  bin_mult  :: "[i,i]=>i"

primrec
  integ_of_Pls:  "integ_of (Pls)     = $# 0"
  integ_of_Min:  "integ_of (Min)     = $-($#1)"
  integ_of_BIT:  "integ_of (w BIT b) = $#b $+ integ_of(w) $+ integ_of(w)"

    (** recall that cond(1,b,c)=b and cond(0,b,c)=0 **)

primrec (*NCons adds a bit, suppressing leading 0s and 1s*)
  NCons_Pls: "NCons (Pls,b)     = cond(b,Pls BIT b,Pls)"
  NCons_Min: "NCons (Min,b)     = cond(b,Min,Min BIT b)"
  NCons_BIT: "NCons (w BIT c,b) = w BIT c BIT b"

primrec (*successor.  If a BIT, can change a 0 to a 1 without recursion.*)
  bin_succ_Pls:  "bin_succ (Pls)     = Pls BIT 1"
  bin_succ_Min:  "bin_succ (Min)     = Pls"
  bin_succ_BIT:  "bin_succ (w BIT b) = cond(b, bin_succ(w) BIT 0, NCons(w,1))"

primrec (*predecessor*)
  bin_pred_Pls:  "bin_pred (Pls)     = Min"
  bin_pred_Min:  "bin_pred (Min)     = Min BIT 0"
  bin_pred_BIT:  "bin_pred (w BIT b) = cond(b, NCons(w,0), bin_pred(w) BIT 1)"

primrec (*unary negation*)
  bin_minus_Pls:
    "bin_minus (Pls)       = Pls"
  bin_minus_Min:
    "bin_minus (Min)       = Pls BIT 1"
  bin_minus_BIT:
    "bin_minus (w BIT b) = cond(b, bin_pred(NCons(bin_minus(w),0)),
                                bin_minus(w) BIT 0)"

primrec (*sum*)
  bin_adder_Pls:
    "bin_adder (Pls)     = (\<lambda>w\<in>bin. w)"
  bin_adder_Min:
    "bin_adder (Min)     = (\<lambda>w\<in>bin. bin_pred(w))"
  bin_adder_BIT:
    "bin_adder (v BIT x) =
       (\<lambda>w\<in>bin.
         bin_case (v BIT x, bin_pred(v BIT x),
                   %w y. NCons(bin_adder (v) ` cond(x and y, bin_succ(w), w),
                               x xor y),
                   w))"

(*The bin_case above replaces the following mutually recursive function:
primrec
  "adding (v,x,Pls)     = v BIT x"
  "adding (v,x,Min)     = bin_pred(v BIT x)"
  "adding (v,x,w BIT y) = NCons(bin_adder (v, cond(x and y, bin_succ(w), w)),
                                x xor y)"
*)

definition
  bin_add   :: "[i,i]=>i"  where
    "bin_add(v,w) == bin_adder(v)`w"

primrec
  bin_mult_Pls:
    "bin_mult (Pls,w)     = Pls"
  bin_mult_Min:
    "bin_mult (Min,w)     = bin_minus(w)"
  bin_mult_BIT:
    "bin_mult (v BIT b,w) = cond(b, bin_add(NCons(bin_mult(v,w),0),w),
                                 NCons(bin_mult(v,w),0))"

syntax
  "_Int0" :: i  ("#()0")
  "_Int1" :: i  ("#()1")
  "_Int2" :: i  ("#()2")
  "_Neg_Int1" :: i  ("#-()1")
  "_Neg_Int2" :: i  ("#-()2")
translations
  "#0" \<rightleftharpoons> "CONST integ_of(CONST Pls)"
  "#1" \<rightleftharpoons> "CONST integ_of(CONST Pls BIT 1)"
  "#2" \<rightleftharpoons> "CONST integ_of(CONST Pls BIT 1 BIT 0)"
  "#-1" \<rightleftharpoons> "CONST integ_of(CONST Min)"
  "#-2" \<rightleftharpoons> "CONST integ_of(CONST Min BIT 0)"

syntax
  "_Int" :: "num_token => i"  ("#_" 1000)
  "_Neg_Int" :: "num_token => i"  ("#-_" 1000)

ML_file "Tools/numeral_syntax.ML"

declare bin.intros [simp,TC]

lemma NCons_Pls_0: "NCons(Pls,0) = Pls"
by simp

lemma NCons_Pls_1: "NCons(Pls,1) = Pls BIT 1"
by simp

lemma NCons_Min_0: "NCons(Min,0) = Min BIT 0"
by simp

lemma NCons_Min_1: "NCons(Min,1) = Min"
by simp

lemma NCons_BIT: "NCons(w BIT x,b) = w BIT x BIT b"
by (simp add: bin.case_eqns)

lemmas NCons_simps [simp] =
    NCons_Pls_0 NCons_Pls_1 NCons_Min_0 NCons_Min_1 NCons_BIT

(** Type checking **)

lemma integ_of_type [TC]: "w \<in> bin ==> integ_of(w) \<in> int"
apply (induct_tac "w")
apply (simp_all add: bool_into_nat)
done

lemma NCons_type [TC]: "[| w \<in> bin; b \<in> bool |] ==> NCons(w,b) \<in> bin"
by (induct_tac "w", auto)

lemma bin_succ_type [TC]: "w \<in> bin ==> bin_succ(w) \<in> bin"
by (induct_tac "w", auto)

lemma bin_pred_type [TC]: "w \<in> bin ==> bin_pred(w) \<in> bin"
by (induct_tac "w", auto)

lemma bin_minus_type [TC]: "w \<in> bin ==> bin_minus(w) \<in> bin"
by (induct_tac "w", auto)

(*This proof is complicated by the mutual recursion*)
lemma bin_add_type [rule_format,TC]:
     "v \<in> bin ==> \<forall>w\<in>bin. bin_add(v,w) \<in> bin"
apply (unfold bin_add_def)
apply (induct_tac "v")
apply (rule_tac [3] ballI)
apply (rename_tac [3] "w'")
apply (induct_tac [3] "w'")
apply (simp_all add: NCons_type)
done

lemma bin_mult_type [TC]: "[| v \<in> bin; w \<in> bin |] ==> bin_mult(v,w) \<in> bin"
by (induct_tac "v", auto)

subsubsection{*The Carry and Borrow Functions,
            @{term bin_succ} and @{term bin_pred}*}

(*NCons preserves the integer value of its argument*)
lemma integ_of_NCons [simp]:
     "[| w \<in> bin; b \<in> bool |] ==> integ_of(NCons(w,b)) = integ_of(w BIT b)"
apply (erule bin.cases)
apply (auto elim!: boolE)
done

lemma integ_of_succ [simp]:
     "w \<in> bin ==> integ_of(bin_succ(w)) = $#1 $+ integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac elim!: boolE)
done

lemma integ_of_pred [simp]:
     "w \<in> bin ==> integ_of(bin_pred(w)) = $- ($#1) $+ integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac elim!: boolE)
done

subsubsection{*@{term bin_minus}: Unary Negation of Binary Integers*}

lemma integ_of_minus: "w \<in> bin ==> integ_of(bin_minus(w)) = $- integ_of(w)"
apply (erule bin.induct)
apply (auto simp add: zadd_ac zminus_zadd_distrib  elim!: boolE)
done

subsubsection{*@{term bin_add}: Binary Addition*}

lemma bin_add_Pls [simp]: "w \<in> bin ==> bin_add(Pls,w) = w"
by (unfold bin_add_def, simp)

lemma bin_add_Pls_right: "w \<in> bin ==> bin_add(w,Pls) = w"
apply (unfold bin_add_def)
apply (erule bin.induct, auto)
done

lemma bin_add_Min [simp]: "w \<in> bin ==> bin_add(Min,w) = bin_pred(w)"
by (unfold bin_add_def, simp)

lemma bin_add_Min_right: "w \<in> bin ==> bin_add(w,Min) = bin_pred(w)"
apply (unfold bin_add_def)
apply (erule bin.induct, auto)
done

lemma bin_add_BIT_Pls [simp]: "bin_add(v BIT x,Pls) = v BIT x"
by (unfold bin_add_def, simp)

lemma bin_add_BIT_Min [simp]: "bin_add(v BIT x,Min) = bin_pred(v BIT x)"
by (unfold bin_add_def, simp)

lemma bin_add_BIT_BIT [simp]:
     "[| w \<in> bin;  y \<in> bool |]
      ==> bin_add(v BIT x, w BIT y) =
          NCons(bin_add(v, cond(x and y, bin_succ(w), w)), x xor y)"
by (unfold bin_add_def, simp)

lemma integ_of_add [rule_format]:
     "v \<in> bin ==>
          \<forall>w\<in>bin. integ_of(bin_add(v,w)) = integ_of(v) $+ integ_of(w)"
apply (erule bin.induct, simp, simp)
apply (rule ballI)
apply (induct_tac "wa")
apply (auto simp add: zadd_ac elim!: boolE)
done

(*Subtraction*)
lemma diff_integ_of_eq:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $- integ_of(w) = integ_of(bin_add (v, bin_minus(w)))"
apply (unfold zdiff_def)
apply (simp add: integ_of_add integ_of_minus)
done

subsubsection{*@{term bin_mult}: Binary Multiplication*}

lemma integ_of_mult:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(bin_mult(v,w)) = integ_of(v) $* integ_of(w)"
apply (induct_tac "v", simp)
apply (simp add: integ_of_minus)
apply (auto simp add: zadd_ac integ_of_add zadd_zmult_distrib  elim!: boolE)
done

subsection{*Computations*}

(** extra rules for bin_succ, bin_pred **)

lemma bin_succ_1: "bin_succ(w BIT 1) = bin_succ(w) BIT 0"
by simp

lemma bin_succ_0: "bin_succ(w BIT 0) = NCons(w,1)"
by simp

lemma bin_pred_1: "bin_pred(w BIT 1) = NCons(w,0)"
by simp

lemma bin_pred_0: "bin_pred(w BIT 0) = bin_pred(w) BIT 1"
by simp

(** extra rules for bin_minus **)

lemma bin_minus_1: "bin_minus(w BIT 1) = bin_pred(NCons(bin_minus(w), 0))"
by simp

lemma bin_minus_0: "bin_minus(w BIT 0) = bin_minus(w) BIT 0"
by simp

(** extra rules for bin_add **)

lemma bin_add_BIT_11: "w \<in> bin ==> bin_add(v BIT 1, w BIT 1) =
                     NCons(bin_add(v, bin_succ(w)), 0)"
by simp

lemma bin_add_BIT_10: "w \<in> bin ==> bin_add(v BIT 1, w BIT 0) =
                     NCons(bin_add(v,w), 1)"
by simp

lemma bin_add_BIT_0: "[| w \<in> bin;  y \<in> bool |]
      ==> bin_add(v BIT 0, w BIT y) = NCons(bin_add(v,w), y)"
by simp

(** extra rules for bin_mult **)

lemma bin_mult_1: "bin_mult(v BIT 1, w) = bin_add(NCons(bin_mult(v,w),0), w)"
by simp

lemma bin_mult_0: "bin_mult(v BIT 0, w) = NCons(bin_mult(v,w),0)"
by simp

(** Simplification rules with integer constants **)

lemma int_of_0: "$#0 = #0"
by simp

lemma int_of_succ: "$# succ(n) = #1 $+ $#n"
by (simp add: int_of_add [symmetric] natify_succ)

lemma zminus_0 [simp]: "$- #0 = #0"
by simp

lemma zadd_0_intify [simp]: "#0 $+ z = intify(z)"
by simp

lemma zadd_0_right_intify [simp]: "z $+ #0 = intify(z)"
by simp

lemma zmult_1_intify [simp]: "#1 $* z = intify(z)"
by simp

lemma zmult_1_right_intify [simp]: "z $* #1 = intify(z)"
by (subst zmult_commute, simp)

lemma zmult_0 [simp]: "#0 $* z = #0"
by simp

lemma zmult_0_right [simp]: "z $* #0 = #0"
by (subst zmult_commute, simp)

lemma zmult_minus1 [simp]: "#-1 $* z = $-z"
by (simp add: zcompare_rls)

lemma zmult_minus1_right [simp]: "z $* #-1 = $-z"
apply (subst zmult_commute)
apply (rule zmult_minus1)
done

subsection{*Simplification Rules for Comparison of Binary Numbers*}
text{*Thanks to Norbert Voelker*}

(** Equals (=) **)

lemma eq_integ_of_eq:
     "[| v \<in> bin;  w \<in> bin |]
      ==> ((integ_of(v)) = integ_of(w)) \<longleftrightarrow>
          iszero (integ_of (bin_add (v, bin_minus(w))))"
apply (unfold iszero_def)
apply (simp add: zcompare_rls integ_of_add integ_of_minus)
done

lemma iszero_integ_of_Pls: "iszero (integ_of(Pls))"
by (unfold iszero_def, simp)

lemma nonzero_integ_of_Min: "~ iszero (integ_of(Min))"
apply (unfold iszero_def)
apply (simp add: zminus_equation)
done

lemma iszero_integ_of_BIT:
     "[| w \<in> bin; x \<in> bool |]
      ==> iszero (integ_of (w BIT x)) \<longleftrightarrow> (x=0 & iszero (integ_of(w)))"
apply (unfold iszero_def, simp)
apply (subgoal_tac "integ_of (w) \<in> int")
apply typecheck
apply (drule int_cases)
apply (safe elim!: boolE)
apply (simp_all (asm_lr) add: zcompare_rls zminus_zadd_distrib [symmetric]
                     int_of_add [symmetric])
done

lemma iszero_integ_of_0:
     "w \<in> bin ==> iszero (integ_of (w BIT 0)) \<longleftrightarrow> iszero (integ_of(w))"
by (simp only: iszero_integ_of_BIT, blast)

lemma iszero_integ_of_1: "w \<in> bin ==> ~ iszero (integ_of (w BIT 1))"
by (simp only: iszero_integ_of_BIT, blast)

(** Less-than (<) **)

lemma less_integ_of_eq_neg:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $< integ_of(w)
          \<longleftrightarrow> znegative (integ_of (bin_add (v, bin_minus(w))))"
apply (unfold zless_def zdiff_def)
apply (simp add: integ_of_minus integ_of_add)
done

lemma not_neg_integ_of_Pls: "~ znegative (integ_of(Pls))"
by simp

lemma neg_integ_of_Min: "znegative (integ_of(Min))"
by simp

lemma neg_integ_of_BIT:
     "[| w \<in> bin; x \<in> bool |]
      ==> znegative (integ_of (w BIT x)) \<longleftrightarrow> znegative (integ_of(w))"
apply simp
apply (subgoal_tac "integ_of (w) \<in> int")
apply typecheck
apply (drule int_cases)
apply (auto elim!: boolE simp add: int_of_add [symmetric]  zcompare_rls)
apply (simp_all add: zminus_zadd_distrib [symmetric] zdiff_def
                     int_of_add [symmetric])
apply (subgoal_tac "$#1 $- $# succ (succ (n #+ n)) = $- $# succ (n #+ n) ")
 apply (simp add: zdiff_def)
apply (simp add: equation_zminus int_of_diff [symmetric])
done

(** Less-than-or-equals (<=) **)

lemma le_integ_of_eq_not_less:
     "(integ_of(x) $<= (integ_of(w))) \<longleftrightarrow> ~ (integ_of(w) $< (integ_of(x)))"
by (simp add: not_zless_iff_zle [THEN iff_sym])

(*Delete the original rewrites, with their clumsy conditional expressions*)
declare bin_succ_BIT [simp del]
        bin_pred_BIT [simp del]
        bin_minus_BIT [simp del]
        NCons_Pls [simp del]
        NCons_Min [simp del]
        bin_adder_BIT [simp del]
        bin_mult_BIT [simp del]

(*Hide the binary representation of integer constants*)
declare integ_of_Pls [simp del] integ_of_Min [simp del] integ_of_BIT [simp del]

lemmas bin_arith_extra_simps =
     integ_of_add [symmetric]
     integ_of_minus [symmetric]
     integ_of_mult [symmetric]
     bin_succ_1 bin_succ_0
     bin_pred_1 bin_pred_0
     bin_minus_1 bin_minus_0
     bin_add_Pls_right bin_add_Min_right
     bin_add_BIT_0 bin_add_BIT_10 bin_add_BIT_11
     diff_integ_of_eq
     bin_mult_1 bin_mult_0 NCons_simps

(*For making a minimal simpset, one must include these default simprules
  of thy.  Also include simp_thms, or at least (~False)=True*)
lemmas bin_arith_simps =
     bin_pred_Pls bin_pred_Min
     bin_succ_Pls bin_succ_Min
     bin_add_Pls bin_add_Min
     bin_minus_Pls bin_minus_Min
     bin_mult_Pls bin_mult_Min
     bin_arith_extra_simps

(*Simplification of relational operations*)
lemmas bin_rel_simps =
     eq_integ_of_eq iszero_integ_of_Pls nonzero_integ_of_Min
     iszero_integ_of_0 iszero_integ_of_1
     less_integ_of_eq_neg
     not_neg_integ_of_Pls neg_integ_of_Min neg_integ_of_BIT
     le_integ_of_eq_not_less

declare bin_arith_simps [simp]
declare bin_rel_simps [simp]

(** Simplification of arithmetic when nested to the right **)

lemma add_integ_of_left [simp]:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $+ (integ_of(w) $+ z) = (integ_of(bin_add(v,w)) $+ z)"
by (simp add: zadd_assoc [symmetric])

lemma mult_integ_of_left [simp]:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $* (integ_of(w) $* z) = (integ_of(bin_mult(v,w)) $* z)"
by (simp add: zmult_assoc [symmetric])

lemma add_integ_of_diff1 [simp]:
    "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $+ (integ_of(w) $- c) = integ_of(bin_add(v,w)) $- (c)"
apply (unfold zdiff_def)
apply (rule add_integ_of_left, auto)
done

lemma add_integ_of_diff2 [simp]:
     "[| v \<in> bin;  w \<in> bin |]
      ==> integ_of(v) $+ (c $- integ_of(w)) =
          integ_of (bin_add (v, bin_minus(w))) $+ (c)"
apply (subst diff_integ_of_eq [symmetric])
apply (simp_all add: zdiff_def zadd_ac)
done

(** More for integer constants **)

declare int_of_0 [simp] int_of_succ [simp]

lemma zdiff0 [simp]: "#0 $- x = $-x"
by (simp add: zdiff_def)

lemma zdiff0_right [simp]: "x $- #0 = intify(x)"
by (simp add: zdiff_def)

lemma zdiff_self [simp]: "x $- x = #0"
by (simp add: zdiff_def)

lemma znegative_iff_zless_0: "k \<in> int ==> znegative(k) \<longleftrightarrow> k $< #0"
by (simp add: zless_def)

lemma zero_zless_imp_znegative_zminus: "[|#0 $< k; k \<in> int|] ==> znegative($-k)"
by (simp add: zless_def)

lemma zero_zle_int_of [simp]: "#0 $<= $# n"
by (simp add: not_zless_iff_zle [THEN iff_sym] znegative_iff_zless_0 [THEN iff_sym])

lemma nat_of_0 [simp]: "nat_of(#0) = 0"
by (simp only: natify_0 int_of_0 [symmetric] nat_of_int_of)

lemma nat_le_int0_lemma: "[| z $<= $#0; z \<in> int |] ==> nat_of(z) = 0"
by (auto simp add: znegative_iff_zless_0 [THEN iff_sym] zle_def zneg_nat_of)

lemma nat_le_int0: "z $<= $#0 ==> nat_of(z) = 0"
apply (subgoal_tac "nat_of (intify (z)) = 0")
apply (rule_tac [2] nat_le_int0_lemma, auto)
done

lemma int_of_eq_0_imp_natify_eq_0: "$# n = #0 ==> natify(n) = 0"
by (rule not_znegative_imp_zero, auto)

lemma nat_of_zminus_int_of: "nat_of($- $# n) = 0"
by (simp add: nat_of_def int_of_def raw_nat_of zminus image_intrel_int)

lemma int_of_nat_of: "#0 $<= z ==> $# nat_of(z) = intify(z)"
apply (rule not_zneg_nat_of_intify)
apply (simp add: znegative_iff_zless_0 not_zless_iff_zle)
done

declare int_of_nat_of [simp] nat_of_zminus_int_of [simp]

lemma int_of_nat_of_if: "$# nat_of(z) = (if #0 $<= z then intify(z) else #0)"
by (simp add: int_of_nat_of znegative_iff_zless_0 not_zle_iff_zless)

lemma zless_nat_iff_int_zless: "[| m \<in> nat; z \<in> int |] ==> (m < nat_of(z)) \<longleftrightarrow> ($#m $< z)"
apply (case_tac "znegative (z) ")
apply (erule_tac [2] not_zneg_nat_of [THEN subst])
apply (auto dest: zless_trans dest!: zero_zle_int_of [THEN zle_zless_trans]
            simp add: znegative_iff_zless_0)
done

(** nat_of and zless **)

(*An alternative condition is  @{term"$#0 \<subseteq> w"}  *)
lemma zless_nat_conj_lemma: "$#0 $< z ==> (nat_of(w) < nat_of(z)) \<longleftrightarrow> (w $< z)"
apply (rule iff_trans)
apply (rule zless_int_of [THEN iff_sym])
apply (auto simp add: int_of_nat_of_if simp del: zless_int_of)
apply (auto elim: zless_asym simp add: not_zle_iff_zless)
apply (blast intro: zless_zle_trans)
done

lemma zless_nat_conj: "(nat_of(w) < nat_of(z)) \<longleftrightarrow> ($#0 $< z & w $< z)"
apply (case_tac "$#0 $< z")
apply (auto simp add: zless_nat_conj_lemma nat_le_int0 not_zless_iff_zle)
done

(*This simprule cannot be added unless we can find a way to make eq_integ_of_eq
  unconditional!
  [The condition "True" is a hack to prevent looping.
    Conditional rewrite rules are tried after unconditional ones, so a rule
    like eq_nat_number_of will be tried first to eliminate #mm=#nn.]
  lemma integ_of_reorient [simp]:
       "True ==> (integ_of(w) = x) \<longleftrightarrow> (x = integ_of(w))"
  by auto
*)

lemma integ_of_minus_reorient [simp]:
     "(integ_of(w) = $- x) \<longleftrightarrow> ($- x = integ_of(w))"
by auto

lemma integ_of_add_reorient [simp]:
     "(integ_of(w) = x $+ y) \<longleftrightarrow> (x $+ y = integ_of(w))"
by auto

lemma integ_of_diff_reorient [simp]:
     "(integ_of(w) = x $- y) \<longleftrightarrow> (x $- y = integ_of(w))"
by auto

lemma integ_of_mult_reorient [simp]:
     "(integ_of(w) = x $* y) \<longleftrightarrow> (x $* y = integ_of(w))"
by auto

(** To simplify inequalities involving integer negation and literals,
    such as -x = #3
**)

lemmas [simp] =
  zminus_equation [where y = "integ_of(w)"]
  equation_zminus [where x = "integ_of(w)"]
  for w

lemmas [iff] =
  zminus_zless [where y = "integ_of(w)"]
  zless_zminus [where x = "integ_of(w)"]
  for w

lemmas [iff] =
  zminus_zle [where y = "integ_of(w)"]
  zle_zminus [where x = "integ_of(w)"]
  for w

lemmas [simp] =
  Let_def [where s = "integ_of(w)"] for w

(*** Simprocs for numeric literals ***)

(** Combining of literal coefficients in sums of products **)

lemma zless_iff_zdiff_zless_0: "(x $< y) \<longleftrightarrow> (x$-y $< #0)"
  by (simp add: zcompare_rls)

lemma eq_iff_zdiff_eq_0: "[| x \<in> int; y \<in> int |] ==> (x = y) \<longleftrightarrow> (x$-y = #0)"
  by (simp add: zcompare_rls)

lemma zle_iff_zdiff_zle_0: "(x $<= y) \<longleftrightarrow> (x$-y $<= #0)"
  by (simp add: zcompare_rls)

(** For combine_numerals **)

lemma left_zadd_zmult_distrib: "i$*u $+ (j$*u $+ k) = (i$+j)$*u $+ k"
  by (simp add: zadd_zmult_distrib zadd_ac)

(** For cancel_numerals **)

lemmas rel_iff_rel_0_rls =
  zless_iff_zdiff_zless_0 [where y = "u $+ v"]
  eq_iff_zdiff_eq_0 [where y = "u $+ v"]
  zle_iff_zdiff_zle_0 [where y = "u $+ v"]
  zless_iff_zdiff_zless_0 [where y = n]
  eq_iff_zdiff_eq_0 [where y = n]
  zle_iff_zdiff_zle_0 [where y = n]
  for u v (* FIXME n (!?) *)

lemma eq_add_iff1: "(i$*u $+ m = j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m = intify(n))"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

lemma eq_add_iff2: "(i$*u $+ m = j$*u $+ n) \<longleftrightarrow> (intify(m) = (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

lemma less_add_iff1: "(i$*u $+ m $< j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m $< n)"
  apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls)
  done

lemma less_add_iff2: "(i$*u $+ m $< j$*u $+ n) \<longleftrightarrow> (m $< (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib zadd_ac rel_iff_rel_0_rls)
  done

lemma le_add_iff1: "(i$*u $+ m $<= j$*u $+ n) \<longleftrightarrow> ((i$-j)$*u $+ m $<= n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

lemma le_add_iff2: "(i$*u $+ m $<= j$*u $+ n) \<longleftrightarrow> (m $<= (j$-i)$*u $+ n)"
  apply (simp add: zdiff_def zadd_zmult_distrib)
  apply (simp add: zcompare_rls)
  apply (simp add: zadd_ac)
  done

ML_file "int_arith.ML"

end