(*  Title:      HOL/HOLCF/Completion.thy
    Author:     Brian Huffman
*)

section \<open>Defining algebraic domains by ideal completion\<close>

theory Completion
imports Plain_HOLCF
begin

subsection \<open>Ideals over a preorder\<close>

locale preorder =
  fixes r :: "'a::type \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<preceq>" 50)
  assumes r_refl: "x \<preceq> x"
  assumes r_trans: "\<lbrakk>x \<preceq> y; y \<preceq> z\<rbrakk> \<Longrightarrow> x \<preceq> z"
begin

definition
  ideal :: "'a set \<Rightarrow> bool" where
  "ideal A = ((\<exists>x. x \<in> A) \<and> (\<forall>x\<in>A. \<forall>y\<in>A. \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z) \<and>
    (\<forall>x y. x \<preceq> y \<longrightarrow> y \<in> A \<longrightarrow> x \<in> A))"

lemma idealI:
  assumes "\<exists>x. x \<in> A"
  assumes "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
  assumes "\<And>x y. \<lbrakk>x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
  shows "ideal A"
unfolding ideal_def using assms by fast

lemma idealD1:
  "ideal A \<Longrightarrow> \<exists>x. x \<in> A"
unfolding ideal_def by fast

lemma idealD2:
  "\<lbrakk>ideal A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> \<exists>z\<in>A. x \<preceq> z \<and> y \<preceq> z"
unfolding ideal_def by fast

lemma idealD3:
  "\<lbrakk>ideal A; x \<preceq> y; y \<in> A\<rbrakk> \<Longrightarrow> x \<in> A"
unfolding ideal_def by fast

lemma ideal_principal: "ideal {x. x \<preceq> z}"
apply (rule idealI)
apply (rule_tac x=z in exI)
apply (fast intro: r_refl)
apply (rule_tac x=z in bexI, fast)
apply (fast intro: r_refl)
apply (fast intro: r_trans)
done

lemma ex_ideal: "\<exists>A. A \<in> {A. ideal A}"
by (fast intro: ideal_principal)

text \<open>The set of ideals is a cpo\<close>

lemma ideal_UN:
  fixes A :: "nat \<Rightarrow> 'a set"
  assumes ideal_A: "\<And>i. ideal (A i)"
  assumes chain_A: "\<And>i j. i \<le> j \<Longrightarrow> A i \<subseteq> A j"
  shows "ideal (\<Union>i. A i)"
 apply (rule idealI)
   apply (cut_tac idealD1 [OF ideal_A], fast)
  apply (clarify, rename_tac i j)
  apply (drule subsetD [OF chain_A [OF max.cobounded1]])
  apply (drule subsetD [OF chain_A [OF max.cobounded2]])
  apply (drule (1) idealD2 [OF ideal_A])
  apply blast
 apply clarify
 apply (drule (1) idealD3 [OF ideal_A])
 apply fast
done

lemma typedef_ideal_po:
  fixes Abs :: "'a set \<Rightarrow> 'b::below"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  shows "OFCLASS('b, po_class)"
 apply (intro_classes, unfold below)
   apply (rule subset_refl)
  apply (erule (1) subset_trans)
 apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
 apply (erule (1) subset_antisym)
done

lemma
  fixes Abs :: "'a set \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  assumes S: "chain S"
  shows typedef_ideal_lub: "range S <<| Abs (\<Union>i. Rep (S i))"
    and typedef_ideal_rep_lub: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
proof -
  have 1: "ideal (\<Union>i. Rep (S i))"
    apply (rule ideal_UN)
     apply (rule type_definition.Rep [OF type, unfolded mem_Collect_eq])
    apply (subst below [symmetric])
    apply (erule chain_mono [OF S])
    done
  hence 2: "Rep (Abs (\<Union>i. Rep (S i))) = (\<Union>i. Rep (S i))"
    by (simp add: type_definition.Abs_inverse [OF type])
  show 3: "range S <<| Abs (\<Union>i. Rep (S i))"
    apply (rule is_lubI)
     apply (rule is_ubI)
     apply (simp add: below 2, fast)
    apply (simp add: below 2 is_ub_def, fast)
    done
  hence 4: "(\<Squnion>i. S i) = Abs (\<Union>i. Rep (S i))"
    by (rule lub_eqI)
  show 5: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
    by (simp add: 4 2)
qed

lemma typedef_ideal_cpo:
  fixes Abs :: "'a set \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  shows "OFCLASS('b, cpo_class)"
  by standard (rule exI, erule typedef_ideal_lub [OF type below])

end

interpretation below: preorder "below :: 'a::po \<Rightarrow> 'a \<Rightarrow> bool"
apply unfold_locales
apply (rule below_refl)
apply (erule (1) below_trans)
done

subsection \<open>Lemmas about least upper bounds\<close>

lemma is_ub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> lub S"
apply (erule exE, drule is_lub_lub)
apply (drule is_lubD1)
apply (erule (1) is_ubD)
done

lemma is_lub_thelub_ex: "\<lbrakk>\<exists>u. S <<| u; S <| x\<rbrakk> \<Longrightarrow> lub S \<sqsubseteq> x"
by (erule exE, drule is_lub_lub, erule is_lubD2)

subsection \<open>Locale for ideal completion\<close>

locale ideal_completion = preorder +
  fixes principal :: "'a::type \<Rightarrow> 'b::cpo"
  fixes rep :: "'b::cpo \<Rightarrow> 'a::type set"
  assumes ideal_rep: "\<And>x. ideal (rep x)"
  assumes rep_lub: "\<And>Y. chain Y \<Longrightarrow> rep (\<Squnion>i. Y i) = (\<Union>i. rep (Y i))"
  assumes rep_principal: "\<And>a. rep (principal a) = {b. b \<preceq> a}"
  assumes belowI: "\<And>x y. rep x \<subseteq> rep y \<Longrightarrow> x \<sqsubseteq> y"
  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
begin

lemma rep_mono: "x \<sqsubseteq> y \<Longrightarrow> rep x \<subseteq> rep y"
apply (frule bin_chain)
apply (drule rep_lub)
apply (simp only: lub_eqI [OF is_lub_bin_chain])
apply (rule subsetI, rule UN_I [where a=0], simp_all)
done

lemma below_def: "x \<sqsubseteq> y \<longleftrightarrow> rep x \<subseteq> rep y"
by (rule iffI [OF rep_mono belowI])

lemma principal_below_iff_mem_rep: "principal a \<sqsubseteq> x \<longleftrightarrow> a \<in> rep x"
unfolding below_def rep_principal
by (auto intro: r_refl elim: idealD3 [OF ideal_rep])

lemma principal_below_iff [simp]: "principal a \<sqsubseteq> principal b \<longleftrightarrow> a \<preceq> b"
by (simp add: principal_below_iff_mem_rep rep_principal)

lemma principal_eq_iff: "principal a = principal b \<longleftrightarrow> a \<preceq> b \<and> b \<preceq> a"
unfolding po_eq_conv [where 'a='b] principal_below_iff ..

lemma eq_iff: "x = y \<longleftrightarrow> rep x = rep y"
unfolding po_eq_conv below_def by auto

lemma principal_mono: "a \<preceq> b \<Longrightarrow> principal a \<sqsubseteq> principal b"
by (simp only: principal_below_iff)

lemma ch2ch_principal [simp]:
  "\<forall>i. Y i \<preceq> Y (Suc i) \<Longrightarrow> chain (\<lambda>i. principal (Y i))"
by (simp add: chainI principal_mono)

subsubsection \<open>Principal ideals approximate all elements\<close>

lemma compact_principal [simp]: "compact (principal a)"
by (rule compactI2, simp add: principal_below_iff_mem_rep rep_lub)

text \<open>Construct a chain whose lub is the same as a given ideal\<close>

lemma obtain_principal_chain:
  obtains Y where "\<forall>i. Y i \<preceq> Y (Suc i)" and "x = (\<Squnion>i. principal (Y i))"
proof -
  obtain count :: "'a \<Rightarrow> nat" where inj: "inj count"
    using countable ..
  define enum where "enum i = (THE a. count a = i)" for i
  have enum_count [simp]: "\<And>x. enum (count x) = x"
    unfolding enum_def by (simp add: inj_eq [OF inj])
  define a where "a = (LEAST i. enum i \<in> rep x)"
  define b where "b i = (LEAST j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i)" for i
  define c where "c i j = (LEAST k. enum k \<in> rep x \<and> enum i \<preceq> enum k \<and> enum j \<preceq> enum k)" for i j
  define P where "P i \<longleftrightarrow> (\<exists>j. enum j \<in> rep x \<and> \<not> enum j \<preceq> enum i)" for i
  define X where "X = rec_nat a (\<lambda>n i. if P i then c i (b i) else i)"
  have X_0: "X 0 = a" unfolding X_def by simp
  have X_Suc: "\<And>n. X (Suc n) = (if P (X n) then c (X n) (b (X n)) else X n)"
    unfolding X_def by simp
  have a_mem: "enum a \<in> rep x"
    unfolding a_def
    apply (rule LeastI_ex)
    apply (cut_tac ideal_rep [of x])
    apply (drule idealD1)
    apply (clarify, rename_tac a)
    apply (rule_tac x="count a" in exI, simp)
    done
  have b: "\<And>i. P i \<Longrightarrow> enum i \<in> rep x
    \<Longrightarrow> enum (b i) \<in> rep x \<and> \<not> enum (b i) \<preceq> enum i"
    unfolding P_def b_def by (erule LeastI2_ex, simp)
  have c: "\<And>i j. enum i \<in> rep x \<Longrightarrow> enum j \<in> rep x
    \<Longrightarrow> enum (c i j) \<in> rep x \<and> enum i \<preceq> enum (c i j) \<and> enum j \<preceq> enum (c i j)"
    unfolding c_def
    apply (drule (1) idealD2 [OF ideal_rep], clarify)
    apply (rule_tac a="count z" in LeastI2, simp, simp)
    done
  have X_mem: "\<And>n. enum (X n) \<in> rep x"
    apply (induct_tac n)
    apply (simp add: X_0 a_mem)
    apply (clarsimp simp add: X_Suc, rename_tac n)
    apply (simp add: b c)
    done
  have X_chain: "\<And>n. enum (X n) \<preceq> enum (X (Suc n))"
    apply (clarsimp simp add: X_Suc r_refl)
    apply (simp add: b c X_mem)
    done
  have less_b: "\<And>n i. n < b i \<Longrightarrow> enum n \<in> rep x \<Longrightarrow> enum n \<preceq> enum i"
    unfolding b_def by (drule not_less_Least, simp)
  have X_covers: "\<And>n. \<forall>k\<le>n. enum k \<in> rep x \<longrightarrow> enum k \<preceq> enum (X n)"
    apply (induct_tac n)
    apply (clarsimp simp add: X_0 a_def)
    apply (drule_tac k=0 in Least_le, simp add: r_refl)
    apply (clarsimp, rename_tac n k)
    apply (erule le_SucE)
    apply (rule r_trans [OF _ X_chain], simp)
    apply (case_tac "P (X n)", simp add: X_Suc)
    apply (rule_tac x="b (X n)" and y="Suc n" in linorder_cases)
    apply (simp only: less_Suc_eq_le)
    apply (drule spec, drule (1) mp, simp add: b X_mem)
    apply (simp add: c X_mem)
    apply (drule (1) less_b)
    apply (erule r_trans)
    apply (simp add: b c X_mem)
    apply (simp add: X_Suc)
    apply (simp add: P_def)
    done
  have 1: "\<forall>i. enum (X i) \<preceq> enum (X (Suc i))"
    by (simp add: X_chain)
  have 2: "x = (\<Squnion>n. principal (enum (X n)))"
    apply (simp add: eq_iff rep_lub 1 rep_principal)
    apply (auto, rename_tac a)
    apply (subgoal_tac "\<exists>i. a = enum i", erule exE)
    apply (rule_tac x=i in exI, simp add: X_covers)
    apply (rule_tac x="count a" in exI, simp)
    apply (erule idealD3 [OF ideal_rep])
    apply (rule X_mem)
    done
  from 1 2 show ?thesis ..
qed

lemma principal_induct:
  assumes adm: "adm P"
  assumes P: "\<And>a. P (principal a)"
  shows "P x"
apply (rule obtain_principal_chain [of x])
apply (simp add: admD [OF adm] P)
done

lemma compact_imp_principal: "compact x \<Longrightarrow> \<exists>a. x = principal a"
apply (rule obtain_principal_chain [of x])
apply (drule adm_compact_neq [OF _ cont_id])
apply (subgoal_tac "chain (\<lambda>i. principal (Y i))")
apply (drule (2) admD2, fast, simp)
done

subsection \<open>Defining functions in terms of basis elements\<close>

definition
  extension :: "('a::type \<Rightarrow> 'c::cpo) \<Rightarrow> 'b \<rightarrow> 'c" where
  "extension = (\<lambda>f. (\<Lambda> x. lub (f ` rep x)))"

lemma extension_lemma:
  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  shows "\<exists>u. f ` rep x <<| u"
proof -
  obtain Y where Y: "\<forall>i. Y i \<preceq> Y (Suc i)"
  and x: "x = (\<Squnion>i. principal (Y i))"
    by (rule obtain_principal_chain [of x])
  have chain: "chain (\<lambda>i. f (Y i))"
    by (rule chainI, simp add: f_mono Y)
  have rep_x: "rep x = (\<Union>n. {a. a \<preceq> Y n})"
    by (simp add: x rep_lub Y rep_principal)
  have "f ` rep x <<| (\<Squnion>n. f (Y n))"
    apply (rule is_lubI)
    apply (rule ub_imageI, rename_tac a)
    apply (clarsimp simp add: rep_x)
    apply (drule f_mono)
    apply (erule below_lub [OF chain])
    apply (rule lub_below [OF chain])
    apply (drule_tac x="Y n" in ub_imageD)
    apply (simp add: rep_x, fast intro: r_refl)
    apply assumption
    done
  thus ?thesis ..
qed

lemma extension_beta:
  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  shows "extension f\<cdot>x = lub (f ` rep x)"
unfolding extension_def
proof (rule beta_cfun)
  have lub: "\<And>x. \<exists>u. f ` rep x <<| u"
    using f_mono by (rule extension_lemma)
  show cont: "cont (\<lambda>x. lub (f ` rep x))"
    apply (rule contI2)
     apply (rule monofunI)
     apply (rule is_lub_thelub_ex [OF lub ub_imageI])
     apply (rule is_ub_thelub_ex [OF lub imageI])
     apply (erule (1) subsetD [OF rep_mono])
    apply (rule is_lub_thelub_ex [OF lub ub_imageI])
    apply (simp add: rep_lub, clarify)
    apply (erule rev_below_trans [OF is_ub_thelub])
    apply (erule is_ub_thelub_ex [OF lub imageI])
    done
qed

lemma extension_principal:
  fixes f :: "'a::type \<Rightarrow> 'c::cpo"
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  shows "extension f\<cdot>(principal a) = f a"
apply (subst extension_beta, erule f_mono)
apply (subst rep_principal)
apply (rule lub_eqI)
apply (rule is_lub_maximal)
apply (rule ub_imageI)
apply (simp add: f_mono)
apply (rule imageI)
apply (simp add: r_refl)
done

lemma extension_mono:
  assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
  assumes g_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> g a \<sqsubseteq> g b"
  assumes below: "\<And>a. f a \<sqsubseteq> g a"
  shows "extension f \<sqsubseteq> extension g"
 apply (rule cfun_belowI)
 apply (simp only: extension_beta f_mono g_mono)
 apply (rule is_lub_thelub_ex)
  apply (rule extension_lemma, erule f_mono)
 apply (rule ub_imageI, rename_tac a)
 apply (rule below_trans [OF below])
 apply (rule is_ub_thelub_ex)
  apply (rule extension_lemma, erule g_mono)
 apply (erule imageI)
done

lemma cont_extension:
  assumes f_mono: "\<And>a b x. a \<preceq> b \<Longrightarrow> f x a \<sqsubseteq> f x b"
  assumes f_cont: "\<And>a. cont (\<lambda>x. f x a)"
  shows "cont (\<lambda>x. extension (\<lambda>a. f x a))"
 apply (rule contI2)
  apply (rule monofunI)
  apply (rule extension_mono, erule f_mono, erule f_mono)
  apply (erule cont2monofunE [OF f_cont])
 apply (rule cfun_belowI)
 apply (rule principal_induct, simp)
 apply (simp only: contlub_cfun_fun)
 apply (simp only: extension_principal f_mono)
 apply (simp add: cont2contlubE [OF f_cont])
done

end

lemma (in preorder) typedef_ideal_completion:
  fixes Abs :: "'a set \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs {S. ideal S}"
  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
  assumes principal: "\<And>a. principal a = Abs {b. b \<preceq> a}"
  assumes countable: "\<exists>f::'a \<Rightarrow> nat. inj f"
  shows "ideal_completion r principal Rep"
proof
  interpret type_definition Rep Abs "{S. ideal S}" by fact
  fix a b :: 'a and x y :: 'b and Y :: "nat \<Rightarrow> 'b"
  show "ideal (Rep x)"
    using Rep [of x] by simp
  show "chain Y \<Longrightarrow> Rep (\<Squnion>i. Y i) = (\<Union>i. Rep (Y i))"
    using type below by (rule typedef_ideal_rep_lub)
  show "Rep (principal a) = {b. b \<preceq> a}"
    by (simp add: principal Abs_inverse ideal_principal)
  show "Rep x \<subseteq> Rep y \<Longrightarrow> x \<sqsubseteq> y"
    by (simp only: below)
  show "\<exists>f::'a \<Rightarrow> nat. inj f"
    by (rule countable)
qed

end


(*    Title:              SATSolverVerification/MoreList.thy
      Author:             Filip Maric
      Maintainer:         Filip Maric <filip at matf.bg.ac.yu>
*)

section\<open>MoreList\<close>

theory MoreList
imports Main "HOL-Library.Multiset"
begin

text\<open>Theory contains some additional lemmas and functions for the
@{term List} datatype. Warning: some of these notions are obsolete
because they already exist in {\em List.thy} in similiar form.\<close>

(*********************************************************)
(*               last and butlast                        *)
(*********************************************************)
subsection\<open>@{term "last"} and @{term "butlast"} - last element of list and elements before it\<close>
lemma listEqualsButlastAppendLast:
  assumes "list \<noteq> []"
  shows "list = (butlast list) @ [last list]"
using assms
by (induct list) auto

lemma lastListInList [simp]:
  assumes "list \<noteq> []"
  shows "last list \<in> set list"
using assms
by (induct list) auto

lemma butlastIsSubset:
  shows "set (butlast list) \<subseteq> set list"
by (induct list) (auto split: if_split_asm)

lemma setListIsSetButlastAndLast:
  shows "set list \<subseteq> set (butlast list) \<union> {last list}"
by (induct list) auto

lemma butlastAppend:
  shows "butlast (list1 @ list2) = (if list2 = [] then butlast list1 else (list1 @ butlast list2))"
by (induct list1) auto

(*********************************************************)
(*                   removeAll                           *)
(*********************************************************)
subsection\<open>@{term removeAll} - element removal\<close>

lemma removeAll_multiset:
  assumes "distinct a" "x \<in> set a"
  shows "mset a = {#x#} + mset (removeAll x a)"
using assms
proof (induct a)
  case (Cons y a')
  thus ?case
  proof (cases "x = y")
    case True
    with \<open>distinct (y # a')\<close> \<open>x \<in> set (y # a')\<close>
    have "\<not>  x \<in> set a'"
      by auto
    hence "removeAll x a' = a'"
      by (rule removeAll_id)
    with \<open>x = y\<close> show ?thesis
      by (simp add: union_commute)
  next
    case False
    with \<open>x \<in> set (y # a')\<close>
    have "x \<in> set a'"
      by simp
    with \<open>distinct (y # a')\<close>
    have "x \<noteq> y" "distinct a'"
      by auto
    hence "mset a' = {#x#} + mset (removeAll x a')"
      using \<open>x \<in> set a'\<close>
      using Cons(1)
      by simp
    thus ?thesis
      using \<open>x \<noteq> y\<close>
      by (simp add: union_assoc)
  qed
qed simp

lemma removeAll_map:
  assumes "\<forall> x y. x \<noteq> y \<longrightarrow> f x \<noteq> f y"
  shows "removeAll (f x) (map f a) = map f (removeAll x a)"
using assms
by (induct a arbitrary: x) auto

(*********************************************************)
(*                   uniq                                *)
(*********************************************************)
subsection\<open>@{term uniq} - no duplicate elements.\<close>
text\<open>@{term "(uniq list)"} holds iff there are no repeated elements
in a list.  Obsolete: same as @{term "distinct"} in {\em List.thy}.\<close>

primrec uniq :: "'a list => bool"
where
"uniq [] = True" |
"uniq (h#t) = (h \<notin> set t \<and> uniq t)"

lemma uniqDistinct:
"uniq l = distinct l"
by (induct l) auto

lemma uniqAppend:
  assumes "uniq (l1 @ l2)"
  shows "uniq l1" "uniq l2"
using assms
by (induct l1) auto

lemma uniqAppendIff:
  "uniq (l1 @ l2) = (uniq l1 \<and> uniq l2 \<and> set l1 \<inter> set l2 = {})" (is "?lhs = ?rhs")
by (induct l1) auto

lemma uniqAppendElement:
  assumes "uniq l"
  shows "e \<notin> set l = uniq (l @ [e])"
using assms
by (induct l) (auto split: if_split_asm)

lemma uniqImpliesNotLastMemButlast:
  assumes "uniq l"
  shows "last l \<notin> set (butlast l)"
proof (cases "l = []")
  case True
  thus ?thesis
    using assms
    by simp
next
  case False
  hence "l = butlast l @ [last l]"
    by (rule listEqualsButlastAppendLast)
  moreover
  with \<open>uniq l\<close>
  have "uniq (butlast l)"
    using uniqAppend[of "butlast l" "[last l]"]
    by simp
  ultimately
  show ?thesis
    using assms
    using uniqAppendElement[of "butlast l" "last l"]
    by simp
qed

lemma uniqButlastNotUniqListImpliesLastMemButlast:
  assumes "uniq (butlast l)" "\<not> uniq l"
  shows "last l \<in> set (butlast l)"
proof (cases "l = []")
  case True
  thus ?thesis
    using assms
    by auto
next
  case False
  hence "l = butlast l @ [(last l)]"
    by (rule listEqualsButlastAppendLast)
  thus ?thesis
    using assms
    using uniqAppendElement[of "butlast l" "last l"]
    by auto
qed

lemma uniqRemdups:
  shows "uniq (remdups x)"
by (induct x) auto

lemma uniqHeadTailSet:
  assumes "uniq l"
  shows "set (tl l) = (set l) - {hd l}"
using assms
by (induct l) auto

lemma uniqLengthEqCardSet:
assumes "uniq l"
shows "length l = card (set l)"
using assms
by (induct l) auto

lemma lengthGtOneTwoDistinctElements:
assumes
  "uniq l" "length l > 1" "l \<noteq> []"
shows
  "\<exists> a1 a2. a1 \<in> set l \<and> a2 \<in> set l \<and> a1 \<noteq> a2"
proof-
  let ?a1 = "l ! 0"
  let ?a2 = "l ! 1"
  have "?a1 \<in> set l"
    using nth_mem[of "0" "l"]
    using assms
    by simp
  moreover
  have "?a2 \<in> set l"
    using nth_mem[of "1" "l"]
    using assms
    by simp
  moreover
  have "?a1 \<noteq> ?a2"
    using nth_eq_iff_index_eq[of "l" "0" "1"]
    using assms
    by (auto simp add: uniqDistinct)
  ultimately
  show ?thesis
    by auto
qed

(*********************************************************)
(*                   firstPos                            *)
(*********************************************************)
subsection \<open>@{term firstPos} - first position of an element\<close>
text\<open>@{term "firstPos"} returns the zero-based index of the first
  occurrence of an element int a list, or the length of the list if the
  element does not occur.\<close>

primrec firstPos :: "'a => 'a list => nat"
where
"firstPos a [] = 0" |
"firstPos a (h # t) = (if a = h then 0 else 1 + (firstPos a t))"

lemma firstPosEqualZero:
  shows "(firstPos a (m # M') = 0) = (a = m)"
by (induct M') auto

lemma firstPosLeLength:
  assumes "a \<in> set l"
  shows "firstPos a l < length l"
using assms
by (induct l) auto

lemma firstPosAppend:
  assumes "a \<in> set l"
  shows "firstPos a l = firstPos a (l @ l')"
using assms
by (induct l) auto

lemma firstPosAppendNonMemberFirstMemberSecond:
  assumes "a \<notin> set l1" and  "a \<in> set l2"
  shows "firstPos a (l1 @ l2) = length l1 + firstPos a l2"
using assms
by (induct l1) auto

lemma firstPosDomainForElements:
  shows "(0 \<le> firstPos a l \<and> firstPos a l < length l) = (a \<in> set l)" (is "?lhs = ?rhs")
  by (induct l) auto

lemma firstPosEqual:
  assumes "a \<in> set l" and "b \<in> set l"
  shows "(firstPos a l = firstPos b l) = (a = b)" (is "?lhs = ?rhs")
proof-
  {
    assume "?lhs"
    hence "?rhs"
      using assms
    proof (induct l)
      case (Cons m l')
      {
        assume "a = m"
        have "b = m"
        proof-
          from \<open>a = m\<close>
          have "firstPos a (m # l') = 0"
            by simp
          with Cons
          have "firstPos b (m # l') = 0"
            by simp
          with \<open>b \<in> set (m # l')\<close>
          have "firstPos b (m # l') = 0"
            by simp
          thus ?thesis
            using firstPosEqualZero[of "b" "m" "l'"]
            by simp
        qed
        with \<open>a = m\<close>
        have ?case
          by simp
      }
      note * = this
      moreover
      {
        assume "b = m"
        have "a = m"
        proof-
          from \<open>b = m\<close>
          have "firstPos b (m # l') = 0"
            by simp
          with Cons
          have "firstPos a (m # l') = 0"
            by simp
          with \<open>a \<in> set (m # l')\<close>
          have "firstPos a (m # l') = 0"
            by simp
          thus ?thesis
            using firstPosEqualZero[of "a" "m" "l'"]
            by simp
        qed
        with \<open>b = m\<close>
        have ?case
          by simp
      }
      note ** = this
      moreover
      {
        assume Q: "a \<noteq> m" "b \<noteq> m"
        from Q \<open>a \<in> set (m # l')\<close>
        have "a \<in> set l'"
          by simp
        from Q \<open>b \<in> set (m # l')\<close>
        have "b \<in> set l'"
          by simp
        from \<open>a \<in> set l'\<close> \<open>b \<in> set l'\<close> Cons
        have "firstPos a l' = firstPos b l'"
          by (simp split: if_split_asm)
        with Cons
        have ?case
          by (simp split: if_split_asm)
      }
      note *** = this
      moreover
      {
        have "a = m \<or> b = m \<or> a \<noteq> m \<and> b \<noteq> m"
          by auto
      }
      ultimately
      show ?thesis
      proof (cases "a = m")
        case True
        thus ?thesis
          by (rule *)
      next
        case False
        thus ?thesis
        proof (cases "b = m")
          case True
          thus ?thesis
            by (rule **)
        next
          case False
          with \<open>a \<noteq> m\<close> show ?thesis
            by (rule ***)
        qed
      qed
    qed simp
  } thus ?thesis
    by auto
qed

lemma firstPosLast:
  assumes "l \<noteq> []" "uniq l"
  shows "(firstPos x l = length l - 1) = (x = last l)"
using assms
by (induct l) auto

(*********************************************************)
(*                   precedes                            *)
(*********************************************************)
subsection\<open>@{term precedes} - ordering relation induced by @{term firstPos}\<close>
definition precedes :: "'a => 'a => 'a list => bool"
where
"precedes a b l == (a \<in> set l \<and> b \<in> set l \<and>  firstPos a l <= firstPos b l)"

lemma noElementsPrecedesFirstElement:
  assumes "a \<noteq> b"
  shows "\<not> precedes a b (b # list)"
proof-
  {
    assume "precedes a b (b # list)"
    hence "a \<in> set (b # list)" "firstPos a (b # list) <= 0"
      unfolding precedes_def
      by (auto split: if_split_asm)
    hence  "firstPos a (b # list) = 0"
      by auto
    with \<open>a \<noteq> b\<close>
    have False
      using firstPosEqualZero[of "a" "b" "list"]
      by simp
  }
  thus ?thesis
    by auto
qed

lemma lastPrecedesNoElement:
assumes "uniq l"
shows "\<not>(\<exists> a. a \<noteq> last l \<and> precedes (last l) a l)"
proof-
  {
    assume "\<not> ?thesis"
    then obtain "a"
      where "precedes (last l) a l" "a \<noteq> last l"
      by auto
    hence "a \<in> set l" "last l \<in> set l" "firstPos (last l) l \<le> firstPos a l"
      unfolding precedes_def
      by auto
    hence "length l - 1 \<le> firstPos a l"
      using firstPosLast[of "l" "last l"]
      using \<open>uniq l\<close>
      by force
    hence "firstPos a l = length l - 1"
      using firstPosDomainForElements[of "a" "l"]
      using \<open>a \<in> set l\<close>
      by auto
    hence "a = last l"
      using firstPosLast[of "l" "last l"]
      using \<open>a \<in> set l\<close> \<open>last l \<in> set l\<close>
      using \<open>uniq l\<close>
      using firstPosEqual[of "a" "l" "last l"]
      by force
    with \<open>a \<noteq> last l\<close>
    have False
      by simp
  }
  thus ?thesis
    by auto
qed

lemma precedesAppend:
  assumes "precedes a b l"
  shows "precedes a b (l @ l')"
proof-
  from \<open>precedes a b l\<close>
  have "a \<in> set l" "b \<in> set l" "firstPos a l \<le> firstPos b l"
    unfolding precedes_def
    by (auto split: if_split_asm)
  thus ?thesis
    using firstPosAppend[of "a" "l" "l'"]
    using firstPosAppend[of "b" "l" "l'"]
    unfolding precedes_def
    by simp
qed

lemma precedesMemberHeadMemberTail:
  assumes "a \<in> set l1" and "b \<notin> set l1" and "b \<in> set l2"
  shows "precedes a b (l1 @ l2)"
proof-
  from \<open>a \<in> set l1\<close>
  have "firstPos a l1 < length l1"
    using firstPosLeLength [of "a" "l1"]
    by simp
  moreover
  from \<open>a \<in> set l1\<close>
  have "firstPos a (l1 @ l2) = firstPos a l1"
    using firstPosAppend[of "a" "l1" "l2"]
    by simp
  moreover
  from \<open>b \<notin> set l1\<close> \<open>b \<in> set l2\<close>
  have "firstPos b (l1 @ l2) = length l1 + firstPos b l2"
    by (rule firstPosAppendNonMemberFirstMemberSecond)
  moreover
  have "firstPos b l2 \<ge> 0"
    by auto
  ultimately
  show ?thesis
    unfolding precedes_def
    using \<open>a \<in> set l1\<close> \<open>b \<in> set l2\<close>
    by simp
qed

lemma precedesReflexivity:
  assumes "a \<in> set l"
  shows "precedes a a l"
using assms
unfolding precedes_def
by simp

lemma precedesTransitivity:
  assumes
  "precedes a b l" and "precedes b c l"
  shows
  "precedes a c l"
using assms
unfolding precedes_def
by auto

lemma precedesAntisymmetry:
  assumes
  "a \<in> set l" and "b \<in> set l" and
  "precedes a b l" and "precedes b a l"
  shows
  "a = b"
proof-
  from assms
  have "firstPos a l = firstPos b l"
    unfolding precedes_def
    by auto
  thus ?thesis
    using firstPosEqual[of "a" "l" "b"]
    using assms
    by simp
qed

lemma precedesTotalOrder:
  assumes "a \<in> set l" and "b \<in> set l"
  shows "a=b \<or> precedes a b l \<or> precedes b a l"
using assms
unfolding precedes_def
by auto

lemma precedesMap:
  assumes "precedes a b list" and "\<forall> x y. x \<noteq> y \<longrightarrow> f x \<noteq> f y"
  shows "precedes (f a) (f b) (map f list)"
using assms
proof (induct list)
  case (Cons l list')
    {
      assume "a = l"
      have ?case
      proof-
        from \<open>a = l\<close>
        have "firstPos (f a) (map f (l # list')) = 0"
          using firstPosEqualZero[of "f a" "f l" "map f list'"]
          by simp
        moreover
        from \<open>precedes a b (l # list')\<close>
        have "b \<in> set (l # list')"
          unfolding precedes_def
          by simp
        hence "f b \<in> set (map f (l # list'))"
          by auto
        moreover
        hence "firstPos (f b) (map f (l # list')) \<ge>  0"
          by auto
        ultimately
        show ?thesis
          using \<open>a = l\<close> \<open>f b \<in> set (map f (l # list'))\<close>
          unfolding precedes_def
          by simp
      qed
    }
    moreover
    {
      assume "b = l"
      with \<open>precedes a b (l # list')\<close>
      have "a = l"
        using noElementsPrecedesFirstElement[of "a" "l" "list'"]
        by auto
      from \<open>a = l\<close> \<open>b = l\<close>
      have ?case
        unfolding precedes_def
        by simp
    }
    moreover
    {
      assume "a \<noteq> l" "b \<noteq> l"
      with \<open>\<forall> x y. x \<noteq> y \<longrightarrow> f x \<noteq> f y\<close>
      have "f a \<noteq> f l" "f b \<noteq> f l"
        by auto
      from \<open>precedes a b (l # list')\<close>
      have "b \<in> set(l # list')" "a \<in> set(l # list')" "firstPos a (l # list') \<le> firstPos b (l # list')"
        unfolding precedes_def
        by auto
      with \<open>a \<noteq> l\<close> \<open>b \<noteq> l\<close>
      have "a \<in> set list'" "b \<in> set list'" "firstPos a list' \<le> firstPos b list'"
        by auto
      hence "precedes a b list'"
        unfolding precedes_def
        by simp
      with Cons
      have "precedes (f a) (f b) (map f list')"
        by simp
      with \<open>f a \<noteq> f l\<close> \<open>f b \<noteq> f l\<close>
      have ?case
        unfolding precedes_def
        by auto
    }
    ultimately
    show ?case
      by auto
next
  case Nil
  thus ?case
    unfolding precedes_def
    by simp
qed

lemma precedesFilter:
  assumes "precedes a b list" and "f a" and "f b"
  shows "precedes a b (filter f list)"
using assms
proof(induct list)
  case (Cons l list')
  show ?case
  proof-
    from \<open>precedes a b (l # list')\<close>
    have "a \<in> set(l # list')" "b \<in> set(l # list')" "firstPos a (l # list') \<le> firstPos b (l # list')"
      unfolding precedes_def
      by auto
    from \<open>f a\<close> \<open>a \<in> set(l # list')\<close>
    have "a \<in> set(filter f (l # list'))"
      by auto
    moreover
    from \<open>f b\<close> \<open>b \<in> set(l # list')\<close>
    have "b \<in> set(filter f (l # list'))"
      by auto
    moreover
    have "firstPos a (filter f (l # list')) \<le> firstPos b (filter f (l # list'))"
    proof-
      {
        assume "a = l"
        with \<open>f a\<close>
        have "firstPos a (filter f (l # list')) = 0"
          by auto
        with \<open>b \<in> set (filter f (l # list'))\<close>
        have ?thesis
          by auto
      }
      moreover
      {
        assume "b = l"
        with \<open>precedes a b (l # list')\<close>
        have "a = b"
          using noElementsPrecedesFirstElement[of "a" "b" "list'"]
          by auto
        hence ?thesis
          by (simp add: precedesReflexivity)
      }
      moreover
      {
        assume "a \<noteq> l" "b \<noteq> l"
        with \<open>precedes a b (l # list')\<close>
        have "firstPos a list' \<le> firstPos b list'"
          unfolding precedes_def
          by auto
        moreover
        from \<open>a \<noteq> l\<close> \<open>a \<in> set (l # list')\<close>
        have "a \<in> set list'"
          by simp
        moreover
        from \<open>b \<noteq> l\<close> \<open>b \<in> set (l # list')\<close>
        have "b \<in> set list'"
          by simp
        ultimately
        have "precedes a b list'"
          unfolding precedes_def
          by simp
        with \<open>f a\<close> \<open>f b\<close> Cons(1)
        have "precedes a b (filter f list')"
          by simp
        with \<open>a \<noteq> l\<close> \<open>b \<noteq> l\<close>
        have ?thesis
          unfolding precedes_def
          by auto
      }
      ultimately
      show ?thesis
        by blast
    qed
    ultimately
    show ?thesis
      unfolding precedes_def
      by simp
  qed
qed simp

definition
"precedesOrder list == {(a, b). precedes a b list \<and> a \<noteq> b}"

lemma transPrecedesOrder:
  "trans (precedesOrder list)"
proof-
  {
    fix x y z
    assume "precedes x y list" "x \<noteq> y" "precedes y z list" "y \<noteq> z"
    hence "precedes x z list" "x \<noteq> z"
      using precedesTransitivity[of "x" "y" "list" "z"]
      using firstPosEqual[of "y" "list" "z"]
      unfolding precedes_def
      by auto
  }
  thus ?thesis
    unfolding trans_def
    unfolding precedesOrder_def
    by blast
qed

lemma wellFoundedPrecedesOrder:
  shows "wf (precedesOrder list)"
unfolding wf_eq_minimal
proof-
  show "\<forall>Q a. a:Q \<longrightarrow> (\<exists> aMin \<in> Q. \<forall> a'. (a', aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q)"
  proof-
    {
      fix a :: "'a" and Q::"'a set"
      assume "a \<in> Q"
      let ?listQ = "filter (\<lambda> x. x \<in> Q) list"
      have "\<exists> aMin \<in> Q. \<forall> a'. (a', aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q"
      proof (cases "?listQ = []")
        case True
        let ?aMin = a
        have "\<forall> a'. (a', ?aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q"
        proof-
          {
            fix a'
            assume "(a', ?aMin) \<in> precedesOrder list"
            hence "a \<in> set list"
              unfolding precedesOrder_def
              unfolding precedes_def
              by simp
            with \<open>a \<in> Q\<close>
            have "a \<in> set ?listQ"
              by (induct list) auto
            with \<open>?listQ = []\<close>
            have "False"
              by simp
            hence "a' \<notin> Q"
              by simp
          }
          thus ?thesis
            by simp
        qed
        with \<open>a \<in> Q\<close> obtain aMin where "aMin \<in> Q" "\<forall> a'. (a', aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q"
          by auto
        thus ?thesis
          by auto
      next
        case False
        let ?aMin = "hd ?listQ"
        from False
        have "?aMin \<in> Q"
          by (induct list) auto
        have "\<forall> a'. (a', ?aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q"
        proof
          fix a'
          {
            assume "(a', ?aMin) \<in> precedesOrder list"
            hence "a' \<in> set list" "precedes a' ?aMin list" "a' \<noteq> ?aMin"
              unfolding precedesOrder_def
              unfolding precedes_def
              by auto
            have "a' \<notin> Q"
            proof-
              {
                assume "a' \<in> Q"
                with \<open>?aMin \<in> Q\<close> \<open>precedes a' ?aMin list\<close>
                have "precedes a' ?aMin ?listQ"
                    using precedesFilter[of "a'" "?aMin" "list" "\<lambda> x. x \<in> Q"]
                    by blast
                from \<open>a' \<noteq> ?aMin\<close>
                have "\<not> precedes a' (hd ?listQ) (hd ?listQ # tl ?listQ)"
                  by (rule noElementsPrecedesFirstElement)
                with False \<open>precedes a' ?aMin ?listQ\<close>
                have "False"
                  by auto
              }
              thus ?thesis
                by auto
            qed
          } thus "(a', ?aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q"
            by simp
        qed
        with \<open>?aMin \<in> Q\<close>
        show ?thesis
          ..
      qed
    }
    thus ?thesis
      by simp
  qed
qed

(*********************************************************)
(*                   prefix                              *)
(*********************************************************)
subsection\<open>@{term isPrefix} - prefixes of list.\<close>
text\<open>Check if a list is a prefix of another list. Obsolete: similiar
notion is defined in {\em List\_prefixes.thy}.\<close>

definition
  isPrefix :: "'a list => 'a list => bool"
  where "isPrefix p t = (\<exists> s. p @ s = t)"

lemma prefixIsSubset:
  assumes "isPrefix p l"
  shows "set p \<subseteq> set l"
using assms
unfolding isPrefix_def
by auto

lemma uniqListImpliesUniqPrefix:
assumes "isPrefix p l" and "uniq l"
shows "uniq p"
proof-
  from \<open>isPrefix p l\<close> obtain s
    where "p @ s = l"
    unfolding isPrefix_def
    by auto
  with \<open>uniq l\<close>
  show ?thesis
    using uniqAppend[of "p" "s"]
    by simp
qed

lemma firstPosPrefixElement:
  assumes "isPrefix p l" and "a \<in> set p"
  shows "firstPos a p = firstPos a l"
proof-
  from \<open>isPrefix p l\<close> obtain s
    where "p @ s = l"
    unfolding isPrefix_def
    by auto
  with \<open>a \<in> set p\<close>
  show ?thesis
    using firstPosAppend[of "a" "p" "s"]
    by simp
qed

lemma laterInPrefixRetainsPrecedes:
  assumes
  "isPrefix p l" and "precedes a b l" and "b \<in> set p"
  shows
  "precedes a b p"
proof-
  from \<open>isPrefix p l\<close> obtain s
    where "p @ s = l"
    unfolding isPrefix_def
    by auto
  from \<open>precedes a b l\<close>
  have "a \<in> set l" "b \<in> set l" "firstPos a l \<le> firstPos b l"
    unfolding precedes_def
    by (auto split: if_split_asm)

  from \<open>p @ s = l\<close> \<open>b \<in> set p\<close>
  have "firstPos b l = firstPos b p"
    using firstPosAppend [of "b" "p" "s"]
    by simp

  show ?thesis
  proof (cases "a \<in> set p")
    case True
    from \<open>p @ s = l\<close> \<open>a \<in> set p\<close>
    have "firstPos a l = firstPos a p"
      using firstPosAppend [of "a" "p" "s"]
      by simp

    from \<open>firstPos a l = firstPos a p\<close> \<open>firstPos b l = firstPos b p\<close> \<open>firstPos a l \<le> firstPos b l\<close>
    \<open>a \<in> set p\<close> \<open>b \<in> set p\<close>
    show ?thesis
      unfolding precedes_def
      by simp
  next
    case False
    from \<open>a \<notin> set p\<close> \<open>a \<in> set l\<close> \<open>p @ s = l\<close>
    have "a \<in> set s"
      by auto
    with \<open>a \<notin> set p\<close> \<open>p @ s = l\<close>
    have "firstPos a l = length p + firstPos a s"
      using firstPosAppendNonMemberFirstMemberSecond[of "a" "p" "s"]
      by simp
    moreover
    from \<open>b \<in> set p\<close>
    have "firstPos b p < length p"
      by (rule firstPosLeLength)
    ultimately
    show ?thesis
      using \<open>firstPos b l = firstPos b p\<close> \<open>firstPos a l \<le> firstPos b l\<close>
      by simp
  qed
qed

(*********************************************************)
(*                       List diff                       *)
(*********************************************************)
subsection\<open>@{term "list_diff"} - the set difference operation on two lists.\<close>

primrec list_diff :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
"list_diff x [] = x" |
"list_diff x (y#ys) = list_diff (removeAll y x) ys"

lemma [simp]:
  shows "list_diff (x # xs) y = (if x \<in> set y then list_diff xs y else x # list_diff xs y)"
proof (induct y arbitrary: xs)
  case (Cons y ys)
  thus ?case
  proof (cases "x = y")
    case True
    thus ?thesis
      by simp
  next
    case False
    thus ?thesis
    proof (cases "x \<in> set ys")
      case True
      thus ?thesis
        using Cons
        by simp
    next
      case False
      thus ?thesis
        using Cons
        by simp
    qed
  qed
qed simp

lemma listDiffIff:
  shows "(x \<in> set a \<and> x \<notin> set b) = (x \<in> set (list_diff a b))"
by (induct a) auto

lemma listDiffDoubleRemoveAll:
  assumes "x \<in> set a"
  shows "list_diff b a = list_diff b (x # a)"
using assms
by (induct b) auto

lemma removeAllListDiff[simp]:
  shows "removeAll x (list_diff a b) = list_diff (removeAll x a) b"
by (induct a) auto

lemma listDiffRemoveAllNonMember:
  assumes "x \<notin> set a"
  shows "list_diff a b = list_diff a (removeAll x b)"
using assms
proof (induct b arbitrary: a)
  case (Cons y b')
  from \<open>x \<notin> set a\<close>
  have "x \<notin> set (removeAll y a)"
    by auto
  thus ?case
  proof (cases "x = y")
    case False
    thus ?thesis
      using Cons(2)
      using Cons(1)[of "removeAll y a"]
      using \<open>x \<notin> set (removeAll y a)\<close>
      by auto
  next
    case True
    thus ?thesis
      using Cons(1)[of "removeAll y a"]
      using \<open>x \<notin> set a\<close>
      using \<open>x \<notin> set (removeAll y a)\<close>
      by auto
  qed
qed simp

lemma listDiffMap:
  assumes "\<forall> x y. x \<noteq> y \<longrightarrow> f x \<noteq> f y"
  shows "map f (list_diff a b) = list_diff (map f a) (map f b)"
using assms
by (induct b arbitrary: a) (auto simp add: removeAll_map)

(*********************************************************)
(*                       Remdups                         *)
(*********************************************************)
subsection\<open>@{term remdups} - removing duplicates\<close>
lemma remdupsRemoveAllCommute[simp]:
  shows "remdups (removeAll a list) = removeAll a (remdups list)"
by (induct list) auto

lemma remdupsAppend:
  shows "remdups (a @ b) = remdups (list_diff a b) @ remdups b"
proof (induct a)
  case (Cons x a')
  thus ?case
    using listDiffIff[of "x" "a'" "b"]
    by auto
qed simp

lemma remdupsAppendSet:
  shows "set (remdups (a @ b)) = set (remdups a @ remdups (list_diff b a))"
proof (induct a)
  case Nil
  thus ?case
    by auto
next
  case (Cons x a')
  thus ?case
  proof (cases "x \<in> set a'")
    case True
    thus ?thesis
      using Cons
      using listDiffDoubleRemoveAll[of "x" "a'" "b"]
      by simp
  next
    case False
    thus ?thesis
    proof (cases "x \<in> set b")
      case True
      show ?thesis
      proof-
        have "set (remdups (x # a') @ remdups (list_diff b (x # a'))) =
          set (x # remdups a' @ remdups (list_diff b (x # a')))"
          using \<open>x \<notin> set a'\<close>
          by auto
        also have "\<dots> = set (x # remdups a' @ remdups (list_diff (removeAll x b) a'))"
          by auto
        also have "\<dots> = set (x # remdups a' @ remdups (removeAll x (list_diff b a')))"
          by simp
        also have "\<dots> = set (remdups a' @ x # remdups (removeAll x (list_diff b a')))"
          by simp
        also have "\<dots> = set (remdups a' @ x # removeAll x (remdups (list_diff b a')))"
          by (simp only: remdupsRemoveAllCommute)
        also have "\<dots> = set (remdups a') \<union> set (x # removeAll x (remdups (list_diff b a')))"
          by simp
        also have "\<dots> = set (remdups a') \<union> {x} \<union> set (removeAll x (remdups (list_diff b a')))"
          by auto
        also have "\<dots> = set (remdups a') \<union> set (remdups (list_diff b a'))"
        proof-
          from \<open>x \<notin> set a'\<close> \<open>x \<in> set b\<close>
          have "x \<in> set (list_diff b a')"
            using listDiffIff[of "x" "b" "a'"]
            by simp
          hence "x \<in> set (remdups (list_diff b a'))"
            by auto
          thus ?thesis
            by auto
        qed
        also have "\<dots> = set (remdups (a' @ b))"
          using Cons(1)
          by simp
        also have "\<dots> = set (remdups ((x # a') @ b))"
          using \<open>x \<in> set b\<close>
          by simp
        finally show ?thesis
          by simp
      qed
    next
      case False
      thus ?thesis
      proof-
        have "set (remdups (x # a') @ remdups (list_diff b (x # a'))) =
          set (x # (remdups a') @ remdups (list_diff b (x # a')))"
          using \<open>x \<notin> set a'\<close>
          by auto
        also have "\<dots> = set (x # remdups a' @ remdups (list_diff (removeAll x b) a'))"
          by auto
        also have "\<dots> = set (x # remdups a' @ remdups (list_diff b a'))"
          using \<open>x \<notin> set b\<close>
          by auto
        also have "\<dots> = {x} \<union> set (remdups (a' @ b))"
          using Cons(1)
          by simp
        also have "\<dots> = set (remdups ((x # a') @ b))"
          by auto
        finally show ?thesis
          by simp
      qed
    qed
  qed
qed

lemma remdupsAppendMultiSet:
  shows "mset (remdups (a @ b)) = mset (remdups a @ remdups (list_diff b a))"
proof (induct a)
  case Nil
  thus ?case
    by auto
next
  case (Cons x a')
  thus ?case
  proof (cases "x \<in> set a'")
    case True
    thus ?thesis
      using Cons
      using listDiffDoubleRemoveAll[of "x" "a'" "b"]
      by simp
    next
    case False
    thus ?thesis
    proof (cases "x \<in> set b")
      case True
      show ?thesis
      proof-
        have "mset (remdups (x # a') @ remdups (list_diff b (x # a'))) =
          mset (x # remdups a' @ remdups (list_diff b (x # a')))"
        proof-
          have "remdups (x # a') = x # remdups a'"
            using \<open>x \<notin> set a'\<close>
            by auto
          thus ?thesis
            by simp
        qed
        also have "\<dots> = mset (x # remdups a' @ remdups (list_diff (removeAll x b) a'))"
          by auto
        also have "\<dots> = mset (x # remdups a' @ remdups (removeAll x (list_diff b a')))"
          by simp
        also have "\<dots> = mset (remdups a' @ x # remdups (removeAll x (list_diff b a')))"
          by (simp add: union_assoc)
        also have "\<dots> = mset (remdups a' @ x # removeAll x (remdups (list_diff b a')))"
          by (simp only: remdupsRemoveAllCommute)
        also have "\<dots> = mset (remdups a') + mset (x # removeAll x (remdups (list_diff b a')))"
          by simp
        also have "\<dots> = mset (remdups a') + {#x#} + mset (removeAll x (remdups (list_diff b a')))"
          by simp
        also have "\<dots> = mset (remdups a') + mset (remdups (list_diff b a'))"
        proof-
          from \<open>x \<notin> set a'\<close> \<open>x \<in> set b\<close>
          have "x \<in> set (list_diff b a')"
            using listDiffIff[of "x" "b" "a'"]
            by simp
          hence "x \<in> set (remdups (list_diff b a'))"
            by auto
          thus ?thesis
            using removeAll_multiset[of "remdups (list_diff b a')" "x"]
            by (simp add: union_assoc)
        qed
        also have "\<dots> = mset (remdups (a' @ b))"
          using Cons(1)
          by simp
        also have "\<dots> = mset (remdups ((x # a') @ b))"
          using \<open>x \<in> set b\<close>
          by simp
        finally show ?thesis
          by simp
      qed
    next
      case False
      thus ?thesis
      proof-
        have "mset (remdups (x # a') @ remdups (list_diff b (x # a'))) =
          mset (x # remdups a' @ remdups (list_diff b (x # a')))"
        proof-
          have "remdups (x # a') = x # remdups a'"
            using \<open>x \<notin> set a'\<close>
            by auto
          thus ?thesis
            by simp
        qed
        also have "\<dots> = mset (x # remdups a' @ remdups (list_diff (removeAll x b) a'))"
          by auto
        also have "\<dots> = mset (x # remdups a' @ remdups (list_diff b a'))"
          using \<open>x \<notin> set b\<close>
          using removeAll_id[of "x" "b"]
          by simp
        also have "\<dots> = {#x#} + mset (remdups (a' @ b))"
          using Cons(1)
          by (simp add: union_commute)
        also have "\<dots> = mset (remdups ((x # a') @ b))"
          using \<open>x \<notin> set a'\<close> \<open>x \<notin> set b\<close>
          by (auto simp add: union_commute)
        finally show ?thesis
          by simp
      qed
    qed
  qed
qed

lemma remdupsListDiff:
"remdups (list_diff a b) = list_diff (remdups a) (remdups b)"
proof(induct a)
  case Nil
  thus ?case
    by simp
next
  case (Cons x a')
  thus ?case
    using listDiffIff[of "x" "a'" "b"]
    by auto
qed

(*********************************************************)
(*                       Multiset                        *)
(*********************************************************)

(* Repetition of lemmas from Multiset.thy -
   neccessary for r which I do not know how to represent as order instance. *)

definition
"multiset_le a b r == a = b \<or> (a, b) \<in> mult r"

lemma multisetEmptyLeI:
  "multiset_le {#} a r"
unfolding multiset_le_def
using one_step_implies_mult[of "a" "{#}" r "{#}"]
by auto

lemma multisetUnionLessMono2:
shows
  "trans r \<Longrightarrow> (b1, b2) \<in> mult r \<Longrightarrow> (a + b1, a + b2) \<in> mult r"
unfolding mult_def
apply (erule trancl_induct)
apply (blast intro: mult1_union transI)
apply (blast intro: mult1_union transI trancl_trans)
done

lemma multisetUnionLessMono1:
shows
  "trans r \<Longrightarrow> (a1, a2) \<in> mult r \<Longrightarrow> (a1 + b, a2 + b) \<in> mult r"
  by (metis multisetUnionLessMono2 union_commute)

lemma multisetUnionLeMono2:
assumes
  "trans r"
  "multiset_le b1 b2 r"
shows
  "multiset_le (a + b1) (a + b2) r"
using assms
unfolding multiset_le_def
using multisetUnionLessMono2[of "r" "b1" "b2" "a"]
by auto

lemma multisetUnionLeMono1:
assumes
  "trans r"
  "multiset_le a1 a2 r"
shows
  "multiset_le (a1 + b) (a2 + b) r"
using assms
unfolding multiset_le_def
using multisetUnionLessMono1[of "r" "a1" "a2" "b"]
by auto

lemma multisetLeTrans:
assumes
  "trans r"
  "multiset_le x y r"
  "multiset_le y z r"
shows
  "multiset_le x z r"
using assms
unfolding multiset_le_def
unfolding mult_def
by (blast intro: trancl_trans)

lemma multisetUnionLeMono:
assumes
  "trans r"
  "multiset_le a1 a2 r"
  "multiset_le b1 b2 r"
shows
  "multiset_le (a1 + b1) (a2 + b2) r"
using assms
using multisetUnionLeMono1[of "r" "a1" "a2" "b1"]
using multisetUnionLeMono2[of "r" "b1" "b2" "a2"]
using multisetLeTrans[of "r" "a1 + b1" "a2 + b1" "a2 + b2"]
by simp

lemma multisetLeListDiff:
assumes
  "trans r"
shows
  "multiset_le (mset (list_diff a b)) (mset a) r"
proof (induct a)
  case Nil
  thus ?case
    unfolding multiset_le_def
    by simp
next
  case (Cons x a')
  thus ?case
    using assms
    using multisetEmptyLeI[of "{#x#}" "r"]
    using multisetUnionLeMono[of "r" "mset (list_diff a' b)" "mset a'" "{#}" "{#x#}"]
    using multisetUnionLeMono1[of "r" "mset (list_diff a' b)" "mset a'" "{#x#}"]
    by auto
qed

(*********************************************************)
(*                       Levi                            *)
(*********************************************************)
subsection\<open>Levi's lemma\<close>

text\<open>Obsolete: these two lemmas are already proved as @{term
append_eq_append_conv2} and @{term append_eq_Cons_conv}.\<close>

lemma FullLevi:
  shows "(x @ y = z @ w) =
                (x = z \<and> y = w \<or>
                (\<exists> t. z @ t = x \<and> t @ y = w) \<or>
                (\<exists> t. x @ t = z \<and> t @ w = y))" (is "?lhs = ?rhs")
proof
  assume "?rhs"
  thus "?lhs"
    by auto
next
  assume "?lhs"
  thus "?rhs"
  proof (induct x arbitrary: z)
    case (Cons a x')
    show ?case
    proof (cases "z = []")
      case True
      with \<open>(a # x') @ y = z @ w\<close>
      obtain t where "z @ t = a # x'" "t @ y = w"
        by auto
      thus ?thesis
        by auto
    next
      case False
      then obtain b and z' where "z = b # z'"
        by (auto simp add: neq_Nil_conv)
      with \<open>(a # x') @ y = z @ w\<close>
      have "x' @ y = z' @ w" "a = b"
        by auto
      with Cons(1)[of "z'"]
      have "x' = z' \<and> y = w \<or> (\<exists>t. z' @ t = x' \<and> t @ y = w) \<or> (\<exists>t. x' @ t = z' \<and> t @ w = y)"
        by simp
      with \<open>a = b\<close> \<open>z = b # z'\<close>
      show ?thesis
        by auto
    qed
  qed simp
qed

lemma SimpleLevi:
  shows "(p @ s = a # list) =
             ( p = [] \<and> s = a # list \<or>
              (\<exists> t. p = a # t \<and> t @ s = list))"
by (induct p) auto

subsection\<open>Single element lists\<close>
lemma lengthOneCharacterisation:
  shows "(length l = 1) = (l = [hd l])"
by (induct l) auto

lemma lengthOneImpliesOnlyElement:
  assumes "length l = 1" and "a : set l"
  shows "\<forall> a'. a' : set l \<longrightarrow> a' = a"
proof (cases l)
  case (Cons literal' clause')
  with assms
  show ?thesis
    by auto
qed simp

end


theory T181
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. undr(x, join(y, z)) = join(undr(x, y), undr(x, 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. 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(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


theory Ex031
  imports Main
begin

lemma "(A \<longrightarrow> B) \<or> A \<longleftrightarrow> (B \<longrightarrow> A) \<or> B "
proof -
  {
    assume a:"(A \<longrightarrow> B) \<or> A"
    {
      assume b:"\<not>((B \<longrightarrow> A) \<or> B)"
      {
        assume c:A
        {
          assume B
          have A by (rule c)
        }
        hence "B \<longrightarrow> A" by (rule impI)
        hence "(B \<longrightarrow> A) \<or> B" by (rule disjI1)
        with b have False by contradiction
        hence "(B \<longrightarrow> A) \<or> B" by (rule FalseE)
      }
      note d=this
      {
        assume "A \<longrightarrow> B"
        {
          assume e:B
          {
            assume "\<not>A"
            from e have "(B \<longrightarrow> A) \<or> B" by (rule disjI2)
            with b have False by contradiction
          }
          hence "\<not>\<not>A" by (rule notI)
          hence A by (rule notnotD)
        }
        hence "B \<longrightarrow> A" by (rule impI)
        hence "(B \<longrightarrow> A) \<or> B" by (rule disjI1)
      }
      from a and this and d have "(B \<longrightarrow> A) \<or> B" by (rule disjE)
      with b have False by contradiction
    }
    hence "\<not>\<not>((B \<longrightarrow> A) \<or> B)" by (rule notI)
    hence "(B \<longrightarrow> A) \<or> B" by (rule notnotD)
  }
  moreover
  {
    assume f:"(B \<longrightarrow> A) \<or> B"
    {
      assume g:"\<not>((A \<longrightarrow> B) \<or> A)"
      {
        assume h:B
        {
          assume A
          have B by (rule h)
        }
        hence "A \<longrightarrow> B" by (rule impI)
        hence "(A \<longrightarrow> B) \<or> A" by (rule disjI1)
      }
      note i=this
      {
        assume "B \<longrightarrow> A"
        {
          assume j:A
          {
            assume "\<not>B"
            from j have "(A \<longrightarrow> B) \<or> A" by (rule disjI2)
            with g have False by contradiction
          }
          hence "\<not>\<not>B" by (rule notI)
          hence B by (rule notnotD)
        }
        hence "A \<longrightarrow> B" by (rule impI)
        hence "(A \<longrightarrow> B) \<or> A" by (rule disjI1)
      }
      from f and this and i have "(A \<longrightarrow> B) \<or> A" by (rule disjE)
      with g have False by contradiction
    }
    hence "\<not>\<not>((A \<longrightarrow> B) \<or> A)" by (rule notI)
    hence "(A \<longrightarrow> B) \<or> A" by (rule notnotD)
  }
  ultimately show ?thesis by (rule iffI)
qed


(* 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_nat_le_reflexive
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

theorem property0 :
  "le x x"
  oops

end


theory WiseMen
  imports Epistemic_S5
begin

(* Wise Men Puzzle *)

type_synonym \<alpha> = "i \<Rightarrow> i \<Rightarrow> bool" (* denoting people *)
consts a::\<alpha> b::\<alpha> c::\<alpha> (* Three people *)
consts fool::\<alpha> (* All people *)
consts white::"\<alpha>\<Rightarrow>\<sigma>"

context
  assumes
A0a: "a \<noteq> b \<and> b \<noteq> c \<and> c \<noteq> a" and (* no two people are the same*)
A0b: "fool \<noteq> a \<and> fool \<noteq> b \<and> fool \<noteq> c" and (* no person is the fool *)
A1: "valid( \<^bold>\<box>fool (white a \<^bold>\<or> white b \<^bold>\<or> white c))" and (*fool knows it's one of a, b or c*)

(*if white is on X then Y and Z both know*)
A2_ab: "valid ( \<^bold>\<box>fool (white a \<^bold>\<rightarrow> \<^bold>\<box>b (white a)))" and
A2_ac: "valid ( \<^bold>\<box>fool (white a \<^bold>\<rightarrow> \<^bold>\<box>c (white a)))" and
A2_bc: "valid ( \<^bold>\<box>fool (white b \<^bold>\<rightarrow> \<^bold>\<box>c (white b)))" and
A2_ba: "valid ( \<^bold>\<box>fool (white b \<^bold>\<rightarrow> \<^bold>\<box>a (white b)))" and
A2_ca: "valid ( \<^bold>\<box>fool (white c \<^bold>\<rightarrow> \<^bold>\<box>a (white c)))" and
A2_cb: "valid ( \<^bold>\<box>fool (white c \<^bold>\<rightarrow> \<^bold>\<box>b (white c)))" and

(* if black is on X then Y and Z both know *)
A3_ab: "valid ( \<^bold>\<box>fool (\<^bold>\<not>(white a) \<^bold>\<rightarrow> \<^bold>\<box>b \<^bold>\<not>(white a)))" and
A3_ac: "valid ( \<^bold>\<box>fool (\<^bold>\<not>(white a) \<^bold>\<rightarrow> \<^bold>\<box>c \<^bold>\<not>(white a)))" and
A3_bc: "valid ( \<^bold>\<box>fool (\<^bold>\<not>(white b) \<^bold>\<rightarrow> \<^bold>\<box>c \<^bold>\<not>(white b)))" and
A3_ba: "valid ( \<^bold>\<box>fool (\<^bold>\<not>(white b) \<^bold>\<rightarrow> \<^bold>\<box>a \<^bold>\<not>(white b)))" and
A3_ca: "valid ( \<^bold>\<box>fool (\<^bold>\<not>(white c) \<^bold>\<rightarrow> \<^bold>\<box>a \<^bold>\<not>(white c)))" and
A3_cb: "valid ( \<^bold>\<box>fool (\<^bold>\<not>(white c) \<^bold>\<rightarrow> \<^bold>\<box>b \<^bold>\<not>(white c)))" and

(* Fool knows  X does't know about it's white spot*)
A4_a: "valid (\<^bold>\<box>fool \<^bold>\<not>(\<^bold>\<box>a (white a)))" and
A4_b: "valid (\<^bold>\<box>fool \<^bold>\<not>(\<^bold>\<box>b (white b)))" and

(* If fool knows somethings, then it's true *)
A5: "valid ((\<^bold>\<box>fool \<phi>) \<^bold>\<rightarrow> \<phi>)"

begin

theorem

(* Proving C knows it has white spot*)
C : "valid (\<^bold>\<box>c (white c))"
  sledgehammer
  by (metis A1 A3_ab A3_ca A3_cb A4_a A4_b A5)

end


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

section \<open>Base\<close>

theory Base

imports Stone_Relation_Algebras.Semirings

begin

nitpick_params [timeout = 600]

class while =
  fixes while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 59)

class n =
  fixes n :: "'a \<Rightarrow> 'a"

class diamond =
  fixes diamond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("| _ > _" [50,90] 95)

class box =
  fixes box :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("| _ ] _" [50,90] 95)

context ord
begin

definition ascending_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where "ascending_chain f \<equiv> \<forall>n . f n \<le> f (Suc n)"

definition descending_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where "descending_chain f \<equiv> \<forall>n . f (Suc n) \<le> f n"

definition directed :: "'a set \<Rightarrow> bool"
  where "directed X \<equiv> X \<noteq> {} \<and> (\<forall>x\<in>X . \<forall>y\<in>X . \<exists>z\<in>X . x \<le> z \<and> y \<le> z)"

definition co_directed :: "'a set \<Rightarrow> bool"
  where "co_directed X \<equiv> X \<noteq> {} \<and> (\<forall>x\<in>X . \<forall>y\<in>X . \<exists>z\<in>X . z \<le> x \<and> z \<le> y)"

definition chain :: "'a set \<Rightarrow> bool"
  where "chain X \<equiv> \<forall>x\<in>X . \<forall>y\<in>X . x \<le> y \<or> y \<le> x"

end

context order
begin

lemma ascending_chain_k:
  "ascending_chain f \<Longrightarrow> f m \<le> f (m + k)"
  apply (induct k)
  apply simp
  using le_add1 lift_Suc_mono_le ord.ascending_chain_def by blast

lemma ascending_chain_isotone:
  "ascending_chain f \<Longrightarrow> m \<le> k \<Longrightarrow> f m \<le> f k"
  using lift_Suc_mono_le ord.ascending_chain_def by blast

lemma ascending_chain_comparable:
  "ascending_chain f \<Longrightarrow> f k \<le> f m \<or> f m \<le> f k"
  by (meson ascending_chain_isotone linear)

lemma ascending_chain_chain:
  "ascending_chain f \<Longrightarrow> chain (range f)"
  by (simp add: ascending_chain_comparable chain_def)

lemma chain_directed:
  "X \<noteq> {} \<Longrightarrow> chain X \<Longrightarrow> directed X"
  by (metis chain_def directed_def)

lemma ascending_chain_directed:
  "ascending_chain f \<Longrightarrow> directed (range f)"
  by (simp add: ascending_chain_chain chain_directed)

lemma descending_chain_k:
  "descending_chain f \<Longrightarrow> f (m + k) \<le> f m"
  apply (induct k)
  apply simp
  using le_add1 lift_Suc_antimono_le ord.descending_chain_def by blast

lemma descending_chain_antitone:
  "descending_chain f \<Longrightarrow> m \<le> k \<Longrightarrow> f k \<le> f m"
  using descending_chain_def lift_Suc_antimono_le by blast

lemma descending_chain_comparable:
  "descending_chain f \<Longrightarrow> f k \<le> f m \<or> f m \<le> f k"
  by (meson descending_chain_antitone nat_le_linear)

lemma descending_chain_chain:
  "descending_chain f \<Longrightarrow> chain (range f)"
  by (simp add: descending_chain_comparable chain_def)

lemma chain_co_directed:
  "X \<noteq> {} \<Longrightarrow> chain X \<Longrightarrow> co_directed X"
  by (metis chain_def co_directed_def)

lemma descending_chain_codirected:
  "descending_chain f \<Longrightarrow> co_directed (range f)"
  by (simp add: chain_co_directed descending_chain_chain)

end

context semilattice_sup
begin

lemma ascending_chain_left_sup:
  "ascending_chain f \<Longrightarrow> ascending_chain (\<lambda>n . x \<squnion> f n)"
  using ascending_chain_def sup_right_isotone by blast

lemma ascending_chain_right_sup:
  "ascending_chain f \<Longrightarrow> ascending_chain (\<lambda>n . f n \<squnion> x)"
  using ascending_chain_def sup_left_isotone by auto

lemma descending_chain_left_add:
  "descending_chain f \<Longrightarrow> descending_chain (\<lambda>n . x \<squnion> f n)"
  using descending_chain_def sup_right_isotone by blast

lemma descending_chain_right_add:
  "descending_chain f \<Longrightarrow> descending_chain (\<lambda>n . f n \<squnion> x)"
  using descending_chain_def sup_left_isotone by auto

primrec pSum0 :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a"
  where "pSum0 f 0 = f 0"
      | "pSum0 f (Suc m) = pSum0 f m \<squnion> f m"

lemma pSum0_below:
 "\<forall>i . f i \<le> x \<Longrightarrow> pSum0 f m \<le> x"
  apply (induct m)
  by auto

end

context non_associative_left_semiring
begin

lemma ascending_chain_left_mult:
  "ascending_chain f \<Longrightarrow> ascending_chain (\<lambda>n . x * f n)"
  by (simp add: mult_right_isotone ord.ascending_chain_def)

lemma ascending_chain_right_mult:
  "ascending_chain f \<Longrightarrow> ascending_chain (\<lambda>n . f n * x)"
  by (simp add: mult_left_isotone ord.ascending_chain_def)

lemma descending_chain_left_mult:
  "descending_chain f \<Longrightarrow> descending_chain (\<lambda>n . x * f n)"
  by (simp add: descending_chain_def mult_right_isotone)

lemma descending_chain_right_mult:
  "descending_chain f \<Longrightarrow> descending_chain (\<lambda>n . f n * x)"
  by (simp add: descending_chain_def mult_left_isotone)

end

context complete_lattice
begin

lemma sup_Sup:
  "A \<noteq> {} \<Longrightarrow> sup x (Sup A) = Sup ((sup x) ` A)"
  apply (rule order.antisym)
  apply (meson ex_in_conv imageI SUP_upper2 Sup_mono sup.boundedI sup_left_divisibility sup_right_divisibility)
  by (meson SUP_least Sup_upper sup_right_isotone)

lemma sup_SUP:
  "Y \<noteq> {} \<Longrightarrow> sup x (SUP y\<in>Y . f y) = (SUP y\<in>Y. sup x (f y))"
  apply (subst sup_Sup)
  by (simp_all add: image_image)

lemma inf_Inf:
  "A \<noteq> {} \<Longrightarrow> inf x (Inf A) = Inf ((inf x) ` A)"
  apply (rule order.antisym)
  apply (meson INF_greatest Inf_lower inf.sup_right_isotone)
  by (simp add: INF_inf_const1)

lemma inf_INF:
  "Y \<noteq> {} \<Longrightarrow> inf x (INF y\<in>Y . f y) = (INF y\<in>Y. inf x (f y))"
  apply (subst inf_Inf)
  by (simp_all add: image_image)

lemma SUP_image_id[simp]:
  "(SUP x\<in>f`A . x) = (SUP x\<in>A . f x)"
  by simp

lemma INF_image_id[simp]:
  "(INF x\<in>f`A . x) = (INF x\<in>A . f x)"
  by simp

end

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

text \<open>The following instantiation and four lemmas are from Jose Divason Mallagaray.\<close>

instantiation "fun" :: (type, type) power
begin

definition one_fun :: "'a \<Rightarrow> 'a"
  where one_fun_def: "one_fun \<equiv> id"

definition times_fun :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
  where times_fun_def: "times_fun \<equiv> comp"

instance
  by intro_classes

end

lemma id_power:
  "id^m = id"
  apply (induct m)
  apply (simp add: one_fun_def)
  by (simp add: times_fun_def)

lemma power_zero_id:
  "f^0 = id"
  by (simp add: one_fun_def)

lemma power_succ_unfold:
  "f^Suc m = f \<circ> f^m"
  by (simp add: times_fun_def)

lemma power_succ_unfold_ext:
  "(f^Suc m) x = f ((f^m) x)"
  by (simp add: times_fun_def)

end