section {* UTP Theories *}

theory utp_theory
imports "../../Isabelle-UTP-Extended/AlgebraicLaws/Algebraic_Laws"

begin

text {* Closure laws for theories *}

named_theorems closure

subsection {* Complete lattice of predicates *}

definition upred_lattice :: "('\<alpha> upred) gorder" ("\<P>") where
"upred_lattice = \<lparr> carrier = UNIV, eq = (op =), le = op \<sqsubseteq> \<rparr>"

text {* @{term "\<P>"} is the complete lattice of alphabetised predicates. All other theories will
  be defined relative to it. *}

interpretation upred_lattice: complete_lattice \<P>
proof (unfold_locales, simp_all add: upred_lattice_def)
  fix A :: "'\<alpha> upred set"
  show "\<exists>s. is_lub \<lparr>carrier = UNIV, eq = op =, le = op \<sqsubseteq>\<rparr> s A"
    apply (rule_tac x="\<Squnion> A" in exI)
    apply (rule least_UpperI)
    apply (auto intro: Inf_greatest simp add: Inf_lower Upper_def)
  done
  show "\<exists>i. is_glb \<lparr>carrier = UNIV, eq = op =, le = op \<sqsubseteq>\<rparr> i A"
    apply (rule_tac x="\<Sqinter> A" in exI)
    apply (rule greatest_LowerI)
    apply (auto intro: Sup_least simp add: Sup_upper Lower_def)
  done
qed

lemma upred_weak_complete_lattice [simp]: "weak_complete_lattice \<P>"
  by (simp add: upred_lattice.weak.weak_complete_lattice_axioms)

lemma upred_lattice_eq [simp]:
  "op .=\<^bsub>\<P>\<^esub> = op ="
  by (simp add: upred_lattice_def)

lemma upred_lattice_le [simp]:
  "le \<P> P Q = (P \<sqsubseteq> Q)"
  by (simp add: upred_lattice_def)

lemma upred_lattice_carrier [simp]:
  "carrier \<P> = UNIV"
  by (simp add: upred_lattice_def)

subsection {* Healthiness conditions *}

type_synonym '\<alpha> health = "'\<alpha> upred \<Rightarrow> '\<alpha> upred"

definition
  Healthy::"'\<alpha> upred \<Rightarrow> '\<alpha> health \<Rightarrow> bool" (infix "is" 30)
where "P is H \<equiv> (H P = P)"

lemma Healthy_def': "P is H \<longleftrightarrow> (H P = P)"
  unfolding Healthy_def by auto

lemma Healthy_if: "P is H \<Longrightarrow> (H P = P)"
  unfolding Healthy_def by auto

declare Healthy_def' [upred_defs]

abbreviation Healthy_carrier :: "'\<alpha> health \<Rightarrow> '\<alpha> upred set" ("\<lbrakk>_\<rbrakk>\<^sub>H")
where "\<lbrakk>H\<rbrakk>\<^sub>H \<equiv> {P. P is H}"

lemma Healthy_carrier_image:
  "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H \<Longrightarrow> \<H> ` A = A"
    by (auto simp add: image_def, (metis Healthy_if mem_Collect_eq subsetCE)+)

lemma Healthy_carrier_Collect: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> A = {H(P) | P. P \<in> A}"
  by (simp add: Healthy_carrier_image Setcompr_eq_image)

lemma Healthy_func:
  "\<lbrakk> F \<in> \<lbrakk>\<H>\<^sub>1\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<H>\<^sub>2\<rbrakk>\<^sub>H; P is \<H>\<^sub>1 \<rbrakk> \<Longrightarrow> \<H>\<^sub>2(F(P)) = F(P)"
  using Healthy_if by blast

lemma Healthy_apply_closed:
  assumes "F \<in> \<lbrakk>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H" "P is H"
  shows "F(P) is H"
  using assms(1) assms(2) by auto

lemma Healthy_set_image_member:
  "\<lbrakk> P \<in> F ` A; \<And> x. F x is H \<rbrakk> \<Longrightarrow> P is H"
  by blast

lemma Healthy_SUPREMUM:
  "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> SUPREMUM A H = \<Sqinter> A"
  by (drule Healthy_carrier_image, presburger)

lemma Healthy_INFIMUM:
  "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> INFIMUM A H = \<Squnion> A"
  by (drule Healthy_carrier_image, presburger)

lemma Healthy_nu [closure]:
  assumes "mono F" "F \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
  shows "\<nu> F is H"
  by (metis (mono_tags) Healthy_def Healthy_func assms eq_id_iff lfp_unfold)

lemma Healthy_mu [closure]:
  assumes "mono F" "F \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
  shows "\<mu> F is H"
  by (metis (mono_tags) Healthy_def Healthy_func assms eq_id_iff gfp_unfold)

lemma Healthy_subset_member: "\<lbrakk> A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H; P \<in> A \<rbrakk> \<Longrightarrow> H(P) = P"
  by (meson Ball_Collect Healthy_if)

lemma is_Healthy_subset_member: "\<lbrakk> A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H; P \<in> A \<rbrakk> \<Longrightarrow> P is H"
  by blast

subsection {* Properties of healthiness conditions *}

definition Idempotent :: "'\<alpha> health \<Rightarrow> bool" where
  "Idempotent(H) \<longleftrightarrow> (\<forall> P. H(H(P)) = H(P))"

abbreviation Monotonic :: "'\<alpha> health \<Rightarrow> bool" where
  "Monotonic(H) \<equiv> mono H"

definition IMH :: "'\<alpha> health \<Rightarrow> bool" where
  "IMH(H) \<longleftrightarrow> Idempotent(H) \<and> Monotonic(H)"

definition Antitone :: "'\<alpha> health \<Rightarrow> bool" where
  "Antitone(H) \<longleftrightarrow> (\<forall> P Q. Q \<sqsubseteq> P \<longrightarrow> (H(P) \<sqsubseteq> H(Q)))"

definition Conjunctive :: "'\<alpha> health \<Rightarrow> bool" where
  "Conjunctive(H) \<longleftrightarrow> (\<exists> Q. \<forall> P. H(P) = (P \<and> Q))"

definition FunctionalConjunctive :: "'\<alpha> health \<Rightarrow> bool" where
  "FunctionalConjunctive(H) \<longleftrightarrow> (\<exists> F. \<forall> P. H(P) = (P \<and> F(P)) \<and> Monotonic(F))"

definition WeakConjunctive :: "'\<alpha> health \<Rightarrow> bool" where
  "WeakConjunctive(H) \<longleftrightarrow> (\<forall> P. \<exists> Q. H(P) = (P \<and> Q))"

definition Disjunctuous :: "'\<alpha> health \<Rightarrow> bool" where
  [upred_defs]: "Disjunctuous H = (\<forall> P Q. H(P \<sqinter> Q) = (H(P) \<sqinter> H(Q)))"

definition Continuous :: "'\<alpha> health \<Rightarrow> bool" where
  [upred_defs]: "Continuous H = (\<forall> A. A \<noteq> {} \<longrightarrow> H (\<Sqinter> A) = \<Sqinter> (H ` A))"

lemma Healthy_Idempotent [closure]:
  "Idempotent H \<Longrightarrow> H(P) is H"
  by (simp add: Healthy_def Idempotent_def)

lemma Healthy_range: "Idempotent H \<Longrightarrow> range H = \<lbrakk>H\<rbrakk>\<^sub>H"
  by (auto simp add: image_def Healthy_if Healthy_Idempotent, metis Healthy_if)

lemma Idempotent_id [simp]: "Idempotent id"
  by (simp add: Idempotent_def)

lemma Idempotent_comp [intro]:
  "\<lbrakk> Idempotent f; Idempotent g; f \<circ> g = g \<circ> f \<rbrakk> \<Longrightarrow> Idempotent (f \<circ> g)"
  by (auto simp add: Idempotent_def comp_def, metis)

lemma Idempotent_image: "Idempotent f \<Longrightarrow> f ` f ` A = f ` A"
  by (metis (mono_tags, lifting) Idempotent_def image_cong image_image)

lemma Monotonic_id [simp]: "Monotonic id"
  by (simp add: monoI)

lemma Monotonic_id' [closure]:
  "mono (\<lambda> X. X)"
  by (simp add: monoI)

lemma Monotonic_const [closure]:
  "Monotonic (\<lambda> x. c)"
  by (simp add: mono_def)

lemma Monotonic_comp [intro]:
  "\<lbrakk> Monotonic f; Monotonic g \<rbrakk> \<Longrightarrow> Monotonic (f \<circ> g)"
  by (simp add: mono_def)

lemma Monotonic_seqr_tail [closure]:
  assumes "Monotonic F"
  shows "Monotonic (\<lambda> X. P ;; F(X))"
  by (simp add: assms monoD monoI seqr_mono)

lemma Monotonic_cond [closure]:
  assumes "Monotonic P" "Monotonic Q"
  shows "Monotonic (\<lambda> X. P(X) \<triangleleft> b \<triangleright> Q(X))"
  by (simp add: assms cond_monotonic)

lemma Conjuctive_Idempotent:
  "Conjunctive(H) \<Longrightarrow> Idempotent(H)"
  by (auto simp add: Conjunctive_def Idempotent_def)

lemma Conjunctive_Monotonic:
  "Conjunctive(H) \<Longrightarrow> Monotonic(H)"
  unfolding Conjunctive_def mono_def
  using dual_order.trans by fastforce

lemma Conjunctive_conj:
  assumes "Conjunctive(HC)"
  shows "HC(P \<and> Q) = (HC(P) \<and> Q)"
  using assms unfolding Conjunctive_def
  by (metis utp_pred_laws.inf.assoc utp_pred_laws.inf.commute)

lemma Conjunctive_distr_conj:
  assumes "Conjunctive(HC)"
  shows "HC(P \<and> Q) = (HC(P) \<and> HC(Q))"
  using assms unfolding Conjunctive_def
  by (metis Conjunctive_conj assms utp_pred_laws.inf.assoc utp_pred_laws.inf_right_idem)

lemma Conjunctive_distr_disj:
  assumes "Conjunctive(HC)"
  shows "HC(P \<or> Q) = (HC(P) \<or> HC(Q))"
  using assms unfolding Conjunctive_def
  using utp_pred_laws.inf_sup_distrib2 by fastforce

lemma Conjunctive_distr_cond:
  assumes "Conjunctive(HC)"
  shows "HC(P \<triangleleft> b \<triangleright> Q) = (HC(P) \<triangleleft> b \<triangleright> HC(Q))"
  using assms unfolding Conjunctive_def
  by (metis cond_conj_distr utp_pred_laws.inf_commute)

lemma FunctionalConjunctive_Monotonic:
  "FunctionalConjunctive(H) \<Longrightarrow> Monotonic(H)"
  unfolding FunctionalConjunctive_def by (metis mono_def utp_pred_laws.inf_mono)

lemma WeakConjunctive_Refinement:
  assumes "WeakConjunctive(HC)"
  shows "P \<sqsubseteq> HC(P)"
  using assms unfolding WeakConjunctive_def by (metis utp_pred_laws.inf.cobounded1)

lemma WeakCojunctive_Healthy_Refinement:
  assumes "WeakConjunctive(HC)" and "P is HC"
  shows "HC(P) \<sqsubseteq> P"
  using assms unfolding WeakConjunctive_def Healthy_def by simp

lemma WeakConjunctive_implies_WeakConjunctive:
  "Conjunctive(H) \<Longrightarrow> WeakConjunctive(H)"
  unfolding WeakConjunctive_def Conjunctive_def by pred_auto

declare Conjunctive_def [upred_defs]
declare mono_def [upred_defs]

lemma Disjunctuous_Monotonic: "Disjunctuous H \<Longrightarrow> Monotonic H"
  by (metis Disjunctuous_def mono_def semilattice_sup_class.le_iff_sup)

lemma ContinuousD [dest]: "\<lbrakk> Continuous H; A \<noteq> {} \<rbrakk> \<Longrightarrow> H (\<Sqinter> A) = (\<Sqinter> P\<in>A. H(P))"
  by (simp add: Continuous_def)

lemma Continuous_Disjunctous: "Continuous H \<Longrightarrow> Disjunctuous H"
  apply (auto simp add: Continuous_def Disjunctuous_def)
  apply (rename_tac P Q)
  apply (drule_tac x="{P,Q}" in spec)
  apply (simp)
done

lemma Continuous_Monotonic [closure]: "Continuous H \<Longrightarrow> Monotonic H"
  by (simp add: Continuous_Disjunctous Disjunctuous_Monotonic)

lemma Continuous_comp [intro]:
  "\<lbrakk> Continuous f; Continuous g \<rbrakk> \<Longrightarrow> Continuous (f \<circ> g)"
  by (simp add: Continuous_def)

text {* Closure laws derived from continuity *}

lemma Sup_Continuous_closed [closure]:
  "\<lbrakk> Continuous H; \<And> i. i \<in> A \<Longrightarrow> P(i) is H; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter> i\<in>A. P(i)) is H"
  by (drule ContinuousD[of H "P ` A"], simp add: UINF_mem_UNIV[THEN sym] UINF_as_Sup[THEN sym])
     (metis (no_types, lifting) Healthy_def' SUP_cong image_image)

lemma UINF_mem_Continuous_closed [closure]:
  "\<lbrakk> Continuous H; \<And> i. i \<in> A \<Longrightarrow> P(i) is H; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter> i\<in>A \<bullet> P(i)) is H"
  by (simp add: Sup_Continuous_closed UINF_as_Sup_collect)

lemma UINF_mem_Continuous_closed_pair [closure]:
  assumes "Continuous H" "\<And> i j. (i, j) \<in> A \<Longrightarrow> P i j is H" "A \<noteq> {}"
  shows "(\<Sqinter> (i,j)\<in>A \<bullet> P i j) is H"
proof -
  have "(\<Sqinter> (i,j)\<in>A \<bullet> P i j) = (\<Sqinter> x\<in>A \<bullet> P (fst x) (snd x))"
    by (rel_auto)
  also have "... is H"
    by (metis (mono_tags) UINF_mem_Continuous_closed assms(1) assms(2) assms(3) prod.collapse)
  finally show ?thesis .
qed

lemma UINF_mem_Continuous_closed_triple [closure]:
  assumes "Continuous H" "\<And> i j k. (i, j, k) \<in> A \<Longrightarrow> P i j k is H" "A \<noteq> {}"
  shows "(\<Sqinter> (i,j,k)\<in>A \<bullet> P i j k) is H"
proof -
  have "(\<Sqinter> (i,j,k)\<in>A \<bullet> P i j k) = (\<Sqinter> x\<in>A \<bullet> P (fst x) (fst (snd x)) (snd (snd x)))"
    by (rel_auto)
  also have "... is H"
    by (metis (mono_tags) UINF_mem_Continuous_closed assms(1) assms(2) assms(3) prod.collapse)
  finally show ?thesis .
qed

lemma UINF_Continuous_closed [closure]:
  "\<lbrakk> Continuous H; \<And> i. P(i) is H \<rbrakk> \<Longrightarrow> (\<Sqinter> i \<bullet> P(i)) is H"
  using UINF_mem_Continuous_closed[of H UNIV P]
  by (simp add: UINF_mem_UNIV)

text {* All continuous functions are also Scott-continuous *}

lemma sup_continuous_Continuous [closure]: "Continuous F \<Longrightarrow> sup_continuous F"
  by (simp add: Continuous_def sup_continuous_def)

lemma USUP_healthy: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> (\<Squnion> P\<in>A \<bullet> F(P)) = (\<Squnion> P\<in>A \<bullet> F(H(P)))"
  by (rule USUP_cong, simp add: Healthy_subset_member)

lemma UINF_healthy: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> (\<Sqinter> P\<in>A \<bullet> F(P)) = (\<Sqinter> P\<in>A \<bullet> F(H(P)))"
  by (rule UINF_cong, simp add: Healthy_subset_member)

lemma upred_lattice_Idempotent [simp]: "Idem\<^bsub>\<P>\<^esub> H = Idempotent H"
  using upred_lattice.weak_partial_order_axioms by (auto simp add: idempotent_def Idempotent_def)

lemma upred_lattice_Monotonic [simp]: "Mono\<^bsub>\<P>\<^esub> H = Monotonic H"
  using upred_lattice.weak_partial_order_axioms by (auto simp add: isotone_def mono_def)

subsection {* UTP theories hierarchy *}

typedef ('\<T>, '\<alpha>) uthy = "UNIV :: unit set"
  by auto

text {* We create a unitary parametric type to represent UTP theories. These are merely tags
  and contain no data other than to help the type-system resolve polymorphic definitions. The
  two parameters denote the name of the UTP theory -- as a unique type -- and the minimal
  alphabet that the UTP theory requires. We will then use Isabelle's ad-hoc overloading
  mechanism to associate theory constructs, like healthiness conditions and units, with
  each of these types. This will allow the type system to retrieve definitions based
  on a particular theory context. *}

definition uthy :: "('a, 'b) uthy" where
"uthy = Abs_uthy ()"

lemma uthy_eq [intro]:
  fixes x y :: "('a, 'b) uthy"
  shows "x = y"
  by (cases x, cases y, simp)

syntax
  "_UTHY" :: "type \<Rightarrow> type \<Rightarrow> logic" ("UTHY'(_, _')")

translations
  "UTHY('T, '\<alpha>)" == "CONST uthy :: ('T, '\<alpha>) uthy"

text {* We set up polymorphic constants to denote the healthiness conditions associated with
  a UTP theory. Unfortunately we can currently only characterise UTP theories of homogeneous
  relations; this is due to restrictions in the instantiation of Isabelle's polymorphic constants
  which apparently cannot specialise types in this way. *}

consts
  utp_hcond :: "('\<T>, '\<alpha>) uthy \<Rightarrow> ('\<alpha> \<times> '\<alpha>) health" ("\<H>\<index>")

definition utp_order :: "('\<alpha> \<times> '\<alpha>) health \<Rightarrow> '\<alpha> hrel gorder" where
"utp_order H = \<lparr> carrier = {P. P is H}, eq = (op =), le = op \<sqsubseteq> \<rparr>"

abbreviation "uthy_order T \<equiv> utp_order \<H>\<^bsub>T\<^esub>"

text {* Constant @{term utp_order} obtains the order structure associated with a UTP theory.
  Its carrier is the set of healthy predicates, equality is HOL equality, and the order is
  refinement. *}

lemma utp_order_carrier [simp]:
  "carrier (utp_order H) = \<lbrakk>H\<rbrakk>\<^sub>H"
  by (simp add: utp_order_def)

lemma utp_order_eq [simp]:
  "eq (utp_order T) = op ="
  by (simp add: utp_order_def)

lemma utp_order_le [simp]:
  "le (utp_order T) = op \<sqsubseteq>"
  by (simp add: utp_order_def)

lemma utp_partial_order: "partial_order (utp_order T)"
  by (unfold_locales, simp_all add: utp_order_def)

lemma utp_weak_partial_order: "weak_partial_order (utp_order T)"
  by (unfold_locales, simp_all add: utp_order_def)

lemma mono_Monotone_utp_order:
  "mono f \<Longrightarrow> Monotone (utp_order T) f"
  apply (auto simp add: isotone_def)
  apply (metis partial_order_def utp_partial_order)
  apply (metis monoD)
done

lemma isotone_utp_orderI: "Monotonic H \<Longrightarrow> isotone (utp_order X) (utp_order Y) H"
  by (auto simp add: mono_def isotone_def utp_weak_partial_order)

lemma Mono_utp_orderI:
  "\<lbrakk> \<And> P Q. \<lbrakk> P \<sqsubseteq> Q; P is H; Q is H \<rbrakk> \<Longrightarrow> F(P) \<sqsubseteq> F(Q) \<rbrakk> \<Longrightarrow> Mono\<^bsub>utp_order H\<^esub> F"
  by (auto simp add: isotone_def utp_weak_partial_order)

text {* The UTP order can equivalently be characterised as the fixed point lattice, @{const fpl}. *}

lemma utp_order_fpl: "utp_order H = fpl \<P> H"
  by (auto simp add: utp_order_def upred_lattice_def fps_def Healthy_def)

definition uth_eq :: "('T\<^sub>1, '\<alpha>) uthy \<Rightarrow> ('T\<^sub>2, '\<alpha>) uthy \<Rightarrow> bool" (infix "\<approx>\<^sub>T" 50) where
"T\<^sub>1 \<approx>\<^sub>T T\<^sub>2 \<longleftrightarrow> \<lbrakk>\<H>\<^bsub>T\<^sub>1\<^esub>\<rbrakk>\<^sub>H = \<lbrakk>\<H>\<^bsub>T\<^sub>2\<^esub>\<rbrakk>\<^sub>H"

lemma uth_eq_refl: "T \<approx>\<^sub>T T"
  by (simp add: uth_eq_def)

lemma uth_eq_sym: "T\<^sub>1 \<approx>\<^sub>T T\<^sub>2 \<longleftrightarrow> T\<^sub>2 \<approx>\<^sub>T T\<^sub>1"
  by (auto simp add: uth_eq_def)

lemma uth_eq_trans: "\<lbrakk> T\<^sub>1 \<approx>\<^sub>T T\<^sub>2; T\<^sub>2 \<approx>\<^sub>T T\<^sub>3 \<rbrakk> \<Longrightarrow> T\<^sub>1 \<approx>\<^sub>T T\<^sub>3"
  by (auto simp add: uth_eq_def)

definition uthy_plus :: "('T\<^sub>1, '\<alpha>) uthy \<Rightarrow> ('T\<^sub>2, '\<alpha>) uthy \<Rightarrow> ('T\<^sub>1 \<times> 'T\<^sub>2, '\<alpha>) uthy" (infixl "+\<^sub>T" 65) where
"uthy_plus T\<^sub>1 T\<^sub>2 = uthy"

overloading
  prod_hcond == "utp_hcond :: ('T\<^sub>1 \<times> 'T\<^sub>2, '\<alpha>) uthy \<Rightarrow> ('\<alpha> \<times> '\<alpha>) health"
begin

  text {* The healthiness condition of a relation is simply identity, since every alphabetised
    relation is healthy. *}

  definition prod_hcond :: "('T\<^sub>1 \<times> 'T\<^sub>2, '\<alpha>) uthy \<Rightarrow> ('\<alpha> \<times> '\<alpha>) upred \<Rightarrow> ('\<alpha> \<times> '\<alpha>) upred" where
  "prod_hcond T = \<H>\<^bsub>UTHY('T\<^sub>1, '\<alpha>)\<^esub> \<circ> \<H>\<^bsub>UTHY('T\<^sub>2, '\<alpha>)\<^esub>"

end

subsection {* UTP theory hierarchy *}

text {* We next define a hierarchy of locales that characterise different classes of UTP theory.
  Minimally we require that a UTP theory's healthiness condition is idempotent. *}

locale utp_theory =
  fixes \<T> :: "('\<T>, '\<alpha>) uthy" (structure)
  assumes HCond_Idem: "\<H>(\<H>(P)) = \<H>(P)"
begin

  lemma uthy_simp:
    "uthy = \<T>"
    by blast

  text {* A UTP theory fixes @{term "\<T>"}, the structural element denoting the UTP theory. All
    constants associated with UTP theories can then be resolved by the type system. *}

  lemma HCond_Idempotent [closure,intro]: "Idempotent \<H>"
    by (simp add: Idempotent_def HCond_Idem)

  sublocale partial_order "uthy_order \<T>"
    by (unfold_locales, simp_all add: utp_order_def)
end

text {* Theory summation is commutative provided the healthiness conditions commute. *}

lemma uthy_plus_comm:
  assumes "\<H>\<^bsub>T\<^sub>1\<^esub> \<circ> \<H>\<^bsub>T\<^sub>2\<^esub> = \<H>\<^bsub>T\<^sub>2\<^esub> \<circ> \<H>\<^bsub>T\<^sub>1\<^esub>"
  shows "T\<^sub>1 +\<^sub>T T\<^sub>2 \<approx>\<^sub>T T\<^sub>2 +\<^sub>T T\<^sub>1"
proof -
  have "T\<^sub>1 = uthy" "T\<^sub>2 = uthy"
    by blast+
  thus ?thesis
    using assms by (simp add: uth_eq_def prod_hcond_def)
qed

lemma uthy_plus_assoc: "T\<^sub>1 +\<^sub>T (T\<^sub>2 +\<^sub>T T\<^sub>3) \<approx>\<^sub>T (T\<^sub>1 +\<^sub>T T\<^sub>2) +\<^sub>T T\<^sub>3"
  by (simp add: uth_eq_def prod_hcond_def comp_def)

lemma uthy_plus_idem: "utp_theory T \<Longrightarrow> T +\<^sub>T T \<approx>\<^sub>T T"
  by (simp add: uth_eq_def prod_hcond_def Healthy_def utp_theory.HCond_Idem utp_theory.uthy_simp)

locale utp_theory_lattice = utp_theory \<T> + complete_lattice "uthy_order \<T>" for \<T> :: "('\<T>, '\<alpha>) uthy" (structure)

text {* The healthiness conditions of a UTP theory lattice form a complete lattice, and allows us to make
  use of complete lattice results from HOL-Algebra, such as the Knaster-Tarski theorem. We can also
  retrieve lattice operators as below. *}

abbreviation utp_top ("\<^bold>\<top>\<index>")
where "utp_top \<T> \<equiv> top (uthy_order \<T>)"

abbreviation utp_bottom ("\<^bold>\<bottom>\<index>")
where "utp_bottom \<T> \<equiv> bottom (uthy_order \<T>)"

abbreviation utp_join (infixl "\<^bold>\<squnion>\<index>" 65) where
"utp_join \<T> \<equiv> join (uthy_order \<T>)"

abbreviation utp_meet (infixl "\<^bold>\<sqinter>\<index>" 70) where
"utp_meet \<T> \<equiv> meet (uthy_order \<T>)"

abbreviation utp_sup ("\<^bold>\<Squnion>\<index>_" [90] 90) where
"utp_sup \<T> \<equiv> Lattice.sup (uthy_order \<T>)"

abbreviation utp_inf ("\<^bold>\<Sqinter>\<index>_" [90] 90) where
"utp_inf \<T> \<equiv> Lattice.inf (uthy_order \<T>)"

abbreviation utp_gfp ("\<^bold>\<nu>\<index>") where
"utp_gfp \<T> \<equiv> GFP (uthy_order \<T>)"

abbreviation utp_lfp ("\<^bold>\<mu>\<index>") where
"utp_lfp \<T> \<equiv> LFP (uthy_order \<T>)"

syntax
  "_tmu" :: "logic \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<mu>\<index> _ \<bullet> _" [0, 10] 10)
  "_tnu" :: "logic \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<nu>\<index> _ \<bullet> _" [0, 10] 10)

notation gfp ("\<mu>")
notation lfp ("\<nu>")

translations
  "\<^bold>\<nu>\<^bsub>T\<^esub> X \<bullet> P" == "CONST utp_lfp T (\<lambda> X. P)"
  "\<^bold>\<mu>\<^bsub>T\<^esub> X \<bullet> P" == "CONST utp_gfp T (\<lambda> X. P)"

lemma upred_lattice_inf:
  "Lattice.inf \<P> A = \<Sqinter> A"
  by (metis Sup_least Sup_upper UNIV_I antisym_conv subsetI upred_lattice.weak.inf_greatest upred_lattice.weak.inf_lower upred_lattice_carrier upred_lattice_le)

text {* We can then derive a number of properties about these operators, as below. *}

context utp_theory_lattice
begin

  lemma LFP_healthy_comp: "\<^bold>\<mu> F = \<^bold>\<mu> (F \<circ> \<H>)"
  proof -
    have "{P. (P is \<H>) \<and> F P \<sqsubseteq> P} = {P. (P is \<H>) \<and> F (\<H> P) \<sqsubseteq> P}"
      by (auto simp add: Healthy_def)
    thus ?thesis
      by (simp add: LFP_def)
  qed

  lemma GFP_healthy_comp: "\<^bold>\<nu> F = \<^bold>\<nu> (F \<circ> \<H>)"
  proof -
    have "{P. (P is \<H>) \<and> P \<sqsubseteq> F P} = {P. (P is \<H>) \<and> P \<sqsubseteq> F (\<H> P)}"
      by (auto simp add: Healthy_def)
    thus ?thesis
      by (simp add: GFP_def)
  qed

  lemma top_healthy [closure]: "\<^bold>\<top> is \<H>"
    using weak.top_closed by auto

  lemma bottom_healthy [closure]: "\<^bold>\<bottom> is \<H>"
    using weak.bottom_closed by auto

  lemma utp_top: "P is \<H> \<Longrightarrow> P \<sqsubseteq> \<^bold>\<top>"
    using weak.top_higher by auto

  lemma utp_bottom: "P is \<H> \<Longrightarrow> \<^bold>\<bottom> \<sqsubseteq> P"
    using weak.bottom_lower by auto

end

lemma upred_top: "\<top>\<^bsub>\<P>\<^esub> = false"
  using ball_UNIV greatest_def by fastforce

lemma upred_bottom: "\<bottom>\<^bsub>\<P>\<^esub> = true"
  by fastforce

text {* One way of obtaining a complete lattice is showing that the healthiness conditions
  are monotone, which the below locale characterises. *}

locale utp_theory_mono = utp_theory +
  assumes HCond_Mono [closure,intro]: "Monotonic \<H>"

sublocale utp_theory_mono \<subseteq> utp_theory_lattice
proof -
  text {* We can then use the Knaster-Tarski theorem to obtain a complete lattice, and thus
    provide all the usual properties. *}

  interpret weak_complete_lattice "fpl \<P> \<H>"
    by (rule Knaster_Tarski, auto simp add: upred_lattice.weak.weak_complete_lattice_axioms)

  have "complete_lattice (fpl \<P> \<H>)"
    by (unfold_locales, simp add: fps_def sup_exists, (blast intro: sup_exists inf_exists)+)

  hence "complete_lattice (uthy_order \<T>)"
    by (simp add: utp_order_def, simp add: upred_lattice_def)

  thus "utp_theory_lattice \<T>"
    by (simp add: utp_theory_axioms utp_theory_lattice_def)
qed

context utp_theory_mono
begin

text {* In a monotone theory, the top and bottom can always be obtained by applying the healthiness
  condition to the predicate top and bottom, respectively. *}

lemma healthy_top: "\<^bold>\<top> = \<H>(false)"
proof -
  have "\<^bold>\<top> = \<top>\<^bsub>fpl \<P> \<H>\<^esub>"
    by (simp add: utp_order_fpl)
  also have "... = \<H> \<top>\<^bsub>\<P>\<^esub>"
    using Knaster_Tarski_idem_extremes(1)[of \<P> \<H>]
    by (simp add: HCond_Idempotent HCond_Mono)
  also have "... = \<H> false"
    by (simp add: upred_top)
  finally show ?thesis .
qed

lemma healthy_bottom: "\<^bold>\<bottom> = \<H>(true)"
proof -
  have "\<^bold>\<bottom> = \<bottom>\<^bsub>fpl \<P> \<H>\<^esub>"
    by (simp add: utp_order_fpl)
  also have "... = \<H> \<bottom>\<^bsub>\<P>\<^esub>"
    using Knaster_Tarski_idem_extremes(2)[of \<P> \<H>]
    by (simp add: HCond_Idempotent HCond_Mono)
  also have "... = \<H> true"
    by (simp add: upred_bottom)
   finally show ?thesis .
qed

lemma healthy_inf:
  assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
  shows "\<^bold>\<Sqinter> A = \<H> (\<Sqinter> A)"
proof -
  have 1: "weak_complete_lattice (uthy_order \<T>)"
    by (simp add: weak.weak_complete_lattice_axioms)
  have 2: "Mono\<^bsub>uthy_order \<T>\<^esub> \<H>"
    by (simp add: HCond_Mono isotone_utp_orderI)
  have 3: "Idem\<^bsub>uthy_order \<T>\<^esub> \<H>"
    by (simp add: HCond_Idem idempotent_def)
  show ?thesis
    using Knaster_Tarski_idem_inf_eq[OF upred_weak_complete_lattice, of "\<H>"]
    by (simp, metis HCond_Idempotent HCond_Mono assms partial_object.simps(3) upred_lattice_def upred_lattice_inf utp_order_def)
qed

end

locale utp_theory_continuous = utp_theory +
  assumes HCond_Cont [closure,intro]: "Continuous \<H>"

sublocale utp_theory_continuous \<subseteq> utp_theory_mono
proof
  show "Monotonic \<H>"
    by (simp add: Continuous_Monotonic HCond_Cont)
qed

context utp_theory_continuous
begin

  lemma healthy_inf_cont:
    assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "\<^bold>\<Sqinter> A = \<Sqinter> A"
  proof -
    have "\<^bold>\<Sqinter> A = \<Sqinter> (\<H>`A)"
      using Continuous_def HCond_Cont assms(1) assms(2) healthy_inf by auto
    also have "... = \<Sqinter> A"
      by (unfold Healthy_carrier_image[OF assms(1)], simp)
    finally show ?thesis .
  qed

  lemma healthy_inf_def:
    assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
    shows "\<^bold>\<Sqinter> A = (if (A = {}) then \<^bold>\<top> else (\<Sqinter> A))"
    using assms healthy_inf_cont weak.weak_inf_empty by auto

  lemma healthy_meet_cont:
    assumes "P is \<H>" "Q is \<H>"
    shows "P \<^bold>\<sqinter> Q = P \<sqinter> Q"
    using healthy_inf_cont[of "{P, Q}"] assms
    by (simp add: Healthy_if meet_def)

  lemma meet_is_healthy [closure]:
    assumes "P is \<H>" "Q is \<H>"
    shows "P \<sqinter> Q is \<H>"
    by (metis Continuous_Disjunctous Disjunctuous_def HCond_Cont Healthy_def' assms(1) assms(2))

  lemma meet_bottom [simp]:
    assumes "P is \<H>"
    shows "P \<sqinter> \<^bold>\<bottom> = \<^bold>\<bottom>"
      by (simp add: assms semilattice_sup_class.sup_absorb2 utp_bottom)

  lemma meet_top [simp]:
    assumes "P is \<H>"
    shows "P \<sqinter> \<^bold>\<top> = P"
      by (simp add: assms semilattice_sup_class.sup_absorb1 utp_top)

  text {* The UTP theory lfp operator can be rewritten to the alphabetised predicate lfp when
    in a continuous context. *}

  theorem utp_lfp_def:
    assumes "Monotonic F" "F \<in> \<lbrakk>\<H>\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
    shows "\<^bold>\<mu> F = (\<mu> X \<bullet> F(\<H>(X)))"
  proof (rule antisym)
    have ne: "{P. (P is \<H>) \<and> F P \<sqsubseteq> P} \<noteq> {}"
    proof -
      have "F \<^bold>\<top> \<sqsubseteq> \<^bold>\<top>"
        using assms(2) utp_top weak.top_closed by force
      thus ?thesis
        by (auto, rule_tac x="\<^bold>\<top>" in exI, auto simp add: top_healthy)
    qed
    show "\<^bold>\<mu> F \<sqsubseteq> (\<mu> X \<bullet> F (\<H> X))"
    proof -
      have "\<Sqinter>{P. (P is \<H>) \<and> F(P) \<sqsubseteq> P} \<sqsubseteq> \<Sqinter>{P. F(\<H>(P)) \<sqsubseteq> P}"
      proof -
        have 1: "\<And> P. F(\<H>(P)) = \<H>(F(\<H>(P)))"
          by (metis HCond_Idem Healthy_def assms(2) funcset_mem mem_Collect_eq)
        show ?thesis
        proof (rule Sup_least, auto)
          fix P
          assume a: "F (\<H> P) \<sqsubseteq> P"
          hence F: "(F (\<H> P)) \<sqsubseteq> (\<H> P)"
            by (metis 1 HCond_Mono mono_def)
          show "\<Sqinter>{P. (P is \<H>) \<and> F P \<sqsubseteq> P} \<sqsubseteq> P"
          proof (rule Sup_upper2[of "F (\<H> P)"])
            show "F (\<H> P) \<in> {P. (P is \<H>) \<and> F P \<sqsubseteq> P}"
            proof (auto)
              show "F (\<H> P) is \<H>"
                by (metis 1 Healthy_def)
              show "F (F (\<H> P)) \<sqsubseteq> F (\<H> P)"
                using F mono_def assms(1) by blast
            qed
            show "F (\<H> P) \<sqsubseteq> P"
              by (simp add: a)
          qed
        qed
      qed

      with ne show ?thesis
        by (simp add: LFP_def gfp_def, subst healthy_inf_cont, auto simp add: lfp_def)
    qed
    from ne show "(\<mu> X \<bullet> F (\<H> X)) \<sqsubseteq> \<^bold>\<mu> F"
      apply (simp add: LFP_def gfp_def, subst healthy_inf_cont, auto simp add: lfp_def)
      apply (rule Sup_least)
      apply (auto simp add: Healthy_def Sup_upper)
    done
  qed

end

text {* In another direction, we can also characterise UTP theories that are relational. Minimally
  this requires that the healthiness condition is closed under sequential composition. *}

locale utp_theory_rel =
  utp_theory +
  assumes Healthy_Sequence [closure]: "\<lbrakk> P is \<H>; Q is \<H> \<rbrakk> \<Longrightarrow> (P ;; Q) is \<H>"

locale utp_theory_cont_rel = utp_theory_continuous + utp_theory_rel
begin

  lemma seq_cont_Sup_distl:
    assumes "P is \<H>" "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "P ;; (\<^bold>\<Sqinter> A) = \<^bold>\<Sqinter> {P ;; Q | Q. Q \<in> A }"
  proof -
    have "{P ;; Q | Q. Q \<in> A } \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
      using Healthy_Sequence assms(1) assms(2) by (auto)
    thus ?thesis
      by (simp add: healthy_inf_cont seq_Sup_distl setcompr_eq_image assms)
  qed

  lemma seq_cont_Sup_distr:
    assumes "Q is \<H>" "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "(\<^bold>\<Sqinter> A) ;; Q = \<^bold>\<Sqinter> {P ;; Q | P. P \<in> A }"
  proof -
    have "{P ;; Q | P. P \<in> A } \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
      using Healthy_Sequence assms(1) assms(2) by (auto)
    thus ?thesis
      by (simp add: healthy_inf_cont seq_Sup_distr setcompr_eq_image assms)
  qed

end

text {* There also exist UTP theories with units, and the following operator is a theory specific
  operator for them. *}

consts
  utp_unit  :: "('\<T>, '\<alpha>) uthy \<Rightarrow> '\<alpha> hrel" ("\<I>\<I>\<index>")

text {* Not all theories have both a left and a right unit (e.g. H1-H2 designs) and so we split
  up the locale into two cases. *}

locale utp_theory_left_unital =
  utp_theory_rel +
  assumes Healthy_Left_Unit [closure]: "\<I>\<I> is \<H>"
  and Left_Unit: "P is \<H> \<Longrightarrow> (\<I>\<I> ;; P) = P"

locale utp_theory_right_unital =
  utp_theory_rel +
  assumes Healthy_Right_Unit [closure]: "\<I>\<I> is \<H>"
  and Right_Unit: "P is \<H> \<Longrightarrow> (P ;; \<I>\<I>) = P"

locale utp_theory_unital =
  utp_theory_rel +
  assumes Healthy_Unit [closure]: "\<I>\<I> is \<H>"
  and Unit_Left: "P is \<H> \<Longrightarrow> (\<I>\<I> ;; P) = P"
  and Unit_Right: "P is \<H> \<Longrightarrow> (P ;; \<I>\<I>) = P"

locale utp_theory_mono_unital = utp_theory_mono + utp_theory_unital

definition utp_star ("_\<^bold>\<star>\<index>" [999] 999) where
"utp_star \<T> P = (\<^bold>\<nu>\<^bsub>\<T>\<^esub> (\<lambda> X. (P ;; X) \<^bold>\<sqinter>\<^bsub>\<T>\<^esub> \<I>\<I>\<^bsub>\<T>\<^esub>))"

definition utp_omega ("_\<^bold>\<omega>\<index>" [999] 999) where
"utp_omega \<T> P = (\<^bold>\<mu>\<^bsub>\<T>\<^esub> (\<lambda> X. (P ;; X)))"

locale utp_pre_left_quantale = utp_theory_continuous + utp_theory_left_unital
begin

  lemma star_healthy [closure]: "P\<^bold>\<star> is \<H>"
    by (metis mem_Collect_eq utp_order_carrier utp_star_def weak.GFP_closed)

  lemma star_unfold: "P is \<H> \<Longrightarrow> P\<^bold>\<star> = (P;;P\<^bold>\<star>) \<sqinter> \<I>\<I>"
    apply (simp add: utp_star_def healthy_meet_cont)
    apply (subst GFP_unfold)
    apply (rule Mono_utp_orderI)
    apply (simp add: healthy_meet_cont closure semilattice_sup_class.le_supI1 seqr_mono)
    apply (auto intro: funcsetI)
    apply (simp add: Healthy_Left_Unit Healthy_Sequence healthy_meet_cont meet_is_healthy)
    using Healthy_Left_Unit Healthy_Sequence healthy_meet_cont weak.GFP_closed apply auto
  done

end

sublocale utp_theory_unital \<subseteq> utp_theory_left_unital
  by (simp add: Healthy_Unit Unit_Left Healthy_Sequence utp_theory_rel_def utp_theory_axioms utp_theory_rel_axioms_def utp_theory_left_unital_axioms_def utp_theory_left_unital_def)

sublocale utp_theory_unital \<subseteq> utp_theory_right_unital
  by (simp add: Healthy_Unit Unit_Right Healthy_Sequence utp_theory_rel_def utp_theory_axioms utp_theory_rel_axioms_def utp_theory_right_unital_axioms_def utp_theory_right_unital_def)

subsection {* Theory of relations *}

text {* We can exemplify the creation of a UTP theory with the theory of relations, a trivial theory. *}

typedecl REL
abbreviation "REL \<equiv> UTHY(REL, '\<alpha>)"

text {* We declare the type @{type REL} to be the tag for this theory. We need know nothing about
  this type (other than it's non-empty), since it is merely a name. We also create the corresponding
  constant to refer to the theory. Then we can use it to instantiate the relevant polymorphic
  constants. *}

overloading
  rel_hcond == "utp_hcond :: (REL, '\<alpha>) uthy \<Rightarrow> ('\<alpha> \<times> '\<alpha>) health"
  rel_unit == "utp_unit :: (REL, '\<alpha>) uthy \<Rightarrow> '\<alpha> hrel"
begin

  text {* The healthiness condition of a relation is simply identity, since every alphabetised
    relation is healthy. *}

  definition rel_hcond :: "(REL, '\<alpha>) uthy \<Rightarrow> ('\<alpha> \<times> '\<alpha>) upred \<Rightarrow> ('\<alpha> \<times> '\<alpha>) upred" where
  "rel_hcond T = id"

  text {* The unit of the theory is simply the relational unit. *}

  definition rel_unit :: "(REL, '\<alpha>) uthy \<Rightarrow> '\<alpha> hrel" where
  "rel_unit T = II"
end

text {* Finally we can show that relations are a monotone and unital theory using a locale interpretation,
  which requires that we prove all the relevant properties. It's convenient to rewrite some
  of the theorems so that the provisos are more UTP like; e.g. that the carrier is the
  set of healthy predicates. *}

interpretation rel_theory: utp_theory_mono_unital REL
  rewrites "carrier (uthy_order REL) = \<lbrakk>id\<rbrakk>\<^sub>H"
  by (unfold_locales, simp_all add: rel_hcond_def rel_unit_def Healthy_def)

text {* We can then, for instance, determine what the top and bottom of our new theory is. *}

lemma REL_top: "\<^bold>\<top>\<^bsub>REL\<^esub> = false"
  by (simp add: rel_theory.healthy_top, simp add: rel_hcond_def)

lemma REL_bottom: "\<^bold>\<bottom>\<^bsub>REL\<^esub> = true"
  by (simp add: rel_theory.healthy_bottom, simp add: rel_hcond_def)

text {* A number of theorems have been exported, such at the fixed point unfolding laws. *}

thm rel_theory.GFP_unfold

subsection {* Theory links *}

text {* We can also describe links between theories, such a Galois connections and retractions,
  using the following notation. *}

definition mk_conn ("_ \<Leftarrow>\<langle>_,_\<rangle>\<Rightarrow> _" [90,0,0,91] 91) where
"H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2 \<equiv> \<lparr> orderA = utp_order H1, orderB = utp_order H2, lower = \<H>\<^sub>2, upper = \<H>\<^sub>1 \<rparr>"

abbreviation mk_conn' ("_ \<leftarrow>\<langle>_,_\<rangle>\<rightarrow> _" [90,0,0,91] 91) where
"T1 \<leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<rightarrow> T2 \<equiv> \<H>\<^bsub>T1\<^esub> \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> \<H>\<^bsub>T2\<^esub>"

lemma mk_conn_orderA [simp]: "\<X>\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = utp_order H1"
  by (simp add:mk_conn_def)

lemma mk_conn_orderB [simp]: "\<Y>\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = utp_order H2"
  by (simp add:mk_conn_def)

lemma mk_conn_lower [simp]:  "\<pi>\<^sub>*\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = \<H>\<^sub>1"
  by (simp add: mk_conn_def)

lemma mk_conn_upper [simp]:  "\<pi>\<^sup>*\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = \<H>\<^sub>2"
  by (simp add: mk_conn_def)

lemma galois_comp: "(H\<^sub>2 \<Leftarrow>\<langle>\<H>\<^sub>3,\<H>\<^sub>4\<rangle>\<Rightarrow> H\<^sub>3) \<circ>\<^sub>g (H\<^sub>1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H\<^sub>2) = H\<^sub>1 \<Leftarrow>\<langle>\<H>\<^sub>1\<circ>\<H>\<^sub>3,\<H>\<^sub>4\<circ>\<H>\<^sub>2\<rangle>\<Rightarrow> H\<^sub>3"
  by (simp add: comp_galcon_def mk_conn_def)

text {* Example Galois connection / retract: Existential quantification *}

lemma Idempotent_ex: "mwb_lens x \<Longrightarrow> Idempotent (ex x)"
  by (simp add: Idempotent_def exists_twice)

lemma Monotonic_ex: "mwb_lens x \<Longrightarrow> Monotonic (ex x)"
  by (simp add: mono_def ex_mono)

lemma ex_closed_unrest:
  "vwb_lens x \<Longrightarrow> \<lbrakk>ex x\<rbrakk>\<^sub>H = {P. x \<sharp> P}"
  by (simp add: Healthy_def unrest_as_exists)

text {* Any theory can be composed with an existential quantification to produce a Galois connection *}

theorem ex_retract:
  assumes "vwb_lens x" "Idempotent H" "ex x \<circ> H = H \<circ> ex x"
  shows "retract ((ex x \<circ> H) \<Leftarrow>\<langle>ex x, H\<rangle>\<Rightarrow> H)"
proof (unfold_locales, simp_all)
  show "H \<in> \<lbrakk>ex x \<circ> H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
    using Healthy_Idempotent assms by blast
  from assms(1) assms(3)[THEN sym] show "ex x \<in> \<lbrakk>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>ex x \<circ> H\<rbrakk>\<^sub>H"
    by (simp add: Pi_iff Healthy_def fun_eq_iff exists_twice)
  fix P Q
  assume "P is (ex x \<circ> H)" "Q is H"
  thus "(H P \<sqsubseteq> Q) = (P \<sqsubseteq> (\<exists> x \<bullet> Q))"
    by (metis (no_types, lifting) Healthy_Idempotent Healthy_if assms comp_apply dual_order.trans ex_weakens utp_pred_laws.ex_mono vwb_lens_wb)
next
  fix P
  assume "P is (ex x \<circ> H)"
  thus "(\<exists> x \<bullet> H P) \<sqsubseteq> P"
    by (simp add: Healthy_def)
qed

corollary ex_retract_id:
  assumes "vwb_lens x"
  shows "retract (ex x \<Leftarrow>\<langle>ex x, id\<rangle>\<Rightarrow> id)"
  using assms ex_retract[where H="id"] by (auto)

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM

To generate a regular expression, the alphabet must be finite.
regexp needs to be supplied with an 'a list for a unique order

add_Atom d i j r a = (if d a i = j then Union r (Atom a) else r)
atoms d i j as = foldl (add_Atom d i j) Empty as

regexp as d i j 0 = (if i=j then Union (Star Empty) (atoms d i j as)
                        else atoms d i j as
*)

section "From deterministic automata to regular sets"

theory RegSet_of_nat_DA
imports "Regular-Sets.Regular_Set" DA
begin

type_synonym 'a nat_next = "'a \<Rightarrow> nat \<Rightarrow> nat"

abbreviation
  deltas :: "'a nat_next \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> nat" where
  "deltas \<equiv> foldl2"

primrec trace :: "'a nat_next \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> nat list"  where
"trace d i [] = []" |
"trace d i (x#xs) = d x i # trace d (d x i) xs"

(* conversion a la Warshall *)

primrec regset :: "'a nat_next \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list set" where
"regset d i j 0 = (if i=j then insert [] {[a] | a. d a i = j}
                          else {[a] | a. d a i = j})" |
"regset d i j (Suc k) =
  regset d i j k \<union>
  (regset d i k k) @@ (star(regset d k k k)) @@ (regset d k j k)"

definition
 regset_of_DA :: "('a,nat)da \<Rightarrow> nat \<Rightarrow> 'a list set" where
"regset_of_DA A k = (\<Union>j\<in>{j. j<k \<and> fin A j}. regset (next A) (start A) j k)"

definition
 bounded :: "'a nat_next \<Rightarrow> nat \<Rightarrow> bool" where
"bounded d k = (\<forall>n. n < k \<longrightarrow> (\<forall>x. d x n < k))"

declare
  in_set_butlast_appendI[simp,intro] less_SucI[simp] image_eqI[simp]

(* Lists *)

lemma butlast_empty[iff]:
  "(butlast xs = []) = (case xs of [] \<Rightarrow> True | y#ys \<Rightarrow> ys=[])"
by (cases xs) simp_all

lemma in_set_butlast_concatI:
 "x:set(butlast xs) \<Longrightarrow> xs:set xss \<Longrightarrow> x:set(butlast(concat xss))"
apply (induct "xss")
 apply simp
apply (simp add: butlast_append del: ball_simps)
apply (rule conjI)
 apply (clarify)
 apply (erule disjE)
  apply (blast)
 apply (subgoal_tac "xs=[]")
  apply simp
 apply (blast)
apply (blast dest: in_set_butlastD)
done

(* Regular sets *)

(* The main lemma:
   how to decompose a trace into a prefix, a list of loops and a suffix.
*)
lemma decompose[rule_format]:
 "\<forall>i. k \<in> set(trace d i xs) \<longrightarrow> (\<exists>pref mids suf.
  xs = pref @ concat mids @ suf \<and>
  deltas d pref i = k \<and> (\<forall>n\<in>set(butlast(trace d i pref)). n \<noteq> k) \<and>
  (\<forall>mid\<in>set mids. (deltas d mid k = k) \<and>
                  (\<forall>n\<in>set(butlast(trace d k mid)). n \<noteq> k)) \<and>
  (\<forall>n\<in>set(butlast(trace d k suf)). n \<noteq> k))"
apply (induct "xs")
 apply (simp)
apply (rename_tac a as)
apply (intro strip)
apply (case_tac "d a i = k")
 apply (rule_tac x = "[a]" in exI)
 apply simp
 apply (case_tac "k : set(trace d (d a i) as)")
  apply (erule allE)
  apply (erule impE)
   apply (assumption)
  apply (erule exE)+
  apply (rule_tac x = "pref#mids" in exI)
  apply (rule_tac x = "suf" in exI)
  apply simp
 apply (rule_tac x = "[]" in exI)
 apply (rule_tac x = "as" in exI)
 apply simp
 apply (blast dest: in_set_butlastD)
apply simp
apply (erule allE)
apply (erule impE)
 apply (assumption)
apply (erule exE)+
apply (rule_tac x = "a#pref" in exI)
apply (rule_tac x = "mids" in exI)
apply (rule_tac x = "suf" in exI)
apply simp
done

lemma length_trace[simp]: "\<And>i. length(trace d i xs) = length xs"
by (induct "xs") simp_all

lemma deltas_append[simp]:
  "\<And>i. deltas d (xs@ys) i = deltas d ys (deltas d xs i)"
by (induct "xs") simp_all

lemma trace_append[simp]:
  "\<And>i. trace d i (xs@ys) = trace d i xs @ trace d (deltas d xs i) ys"
by (induct "xs") simp_all

lemma trace_concat[simp]:
 "(\<forall>xs \<in> set xss. deltas d xs i = i) \<Longrightarrow>
  trace d i (concat xss) = concat (map (trace d i) xss)"
by (induct "xss") simp_all

lemma trace_is_Nil[simp]: "\<And>i. (trace d i xs = []) = (xs = [])"
by (case_tac "xs") simp_all

lemma trace_is_Cons_conv[simp]:
 "(trace d i xs = n#ns) =
  (case xs of [] \<Rightarrow> False | y#ys \<Rightarrow> n = d y i \<and> ns = trace d n ys)"
apply (case_tac "xs")
apply simp_all
apply (blast)
done

lemma set_trace_conv:
 "\<And>i. set(trace d i xs) =
  (if xs=[] then {} else insert(deltas d xs i)(set(butlast(trace d i xs))))"
apply (induct "xs")
 apply (simp)
apply (simp add: insert_commute)
done

lemma deltas_concat[simp]:
 "(\<forall>mid\<in>set mids. deltas d mid k = k) \<Longrightarrow> deltas d (concat mids) k = k"
by (induct mids) simp_all

lemma lem: "[| n < Suc k; n \<noteq> k |] ==> n < k"
by arith

lemma regset_spec:
 "\<And>i j xs. xs \<in> regset d i j k =
        ((\<forall>n\<in>set(butlast(trace d i xs)). n < k) \<and> deltas d xs i = j)"
apply (induct k)
 apply(simp split: list.split)
 apply(fastforce)
apply (simp add: conc_def)
apply (rule iffI)
 apply (erule disjE)
  apply simp
 apply (erule exE conjE)+
 apply simp
 apply (subgoal_tac
      "(\<forall>m\<in>set(butlast(trace d k xsb)). m < Suc k) \<and> deltas d xsb k = k")
  apply (simp add: set_trace_conv butlast_append ball_Un)
 apply (erule star_induct)
  apply (simp)
 apply (simp add: set_trace_conv butlast_append ball_Un)
apply (case_tac "k : set(butlast(trace d i xs))")
 prefer 2 apply (rule disjI1)
 apply (blast intro:lem)
apply (rule disjI2)
apply (drule in_set_butlastD[THEN decompose])
apply (clarify)
apply (rule_tac x = "pref" in exI)
apply simp
apply (rule conjI)
 apply (rule ballI)
 apply (rule lem)
  prefer 2 apply simp
 apply (drule bspec) prefer 2 apply assumption
 apply simp
apply (rule_tac x = "concat mids" in exI)
apply (simp)
apply (rule conjI)
 apply (rule concat_in_star)
 apply (clarsimp simp: subset_iff)
 apply (rule lem)
  prefer 2 apply simp
 apply (drule bspec) prefer 2 apply assumption
 apply (simp add: image_eqI in_set_butlast_concatI)
apply (rule ballI)
apply (rule lem)
 apply auto
done

lemma trace_below:
 "bounded d k \<Longrightarrow> \<forall>i. i < k \<longrightarrow> (\<forall>n\<in>set(trace d i xs). n < k)"
apply (unfold bounded_def)
apply (induct "xs")
 apply simp
apply (simp (no_asm))
apply (blast)
done

lemma regset_below:
 "[| bounded d k; i < k; j < k |] ==>
  regset d i j k = {xs. deltas d xs i = j}"
apply (rule set_eqI)
apply (simp add: regset_spec)
apply (blast dest: trace_below in_set_butlastD)
done

lemma deltas_below:
 "\<And>i. bounded d k \<Longrightarrow> i < k \<Longrightarrow> deltas d w i < k"
apply (unfold bounded_def)
apply (induct "w")
 apply simp_all
done

lemma regset_DA_equiv:
 "[| bounded (next A) k; start A < k; j < k |] ==>
  w : regset_of_DA A k = accepts A w"
apply(unfold regset_of_DA_def)
apply (simp cong: conj_cong
            add: regset_below deltas_below accepts_def delta_def)
done

end


theory AoC
imports Main

begin

typedecl c (*Type for concepts*)

consts contains :: "c\<Rightarrow>c\<Rightarrow>bool" (infix "\<^bold>\<in>" 65)
consts conjunction :: "c\<Rightarrow>c\<Rightarrow>c" (infixr"\<^bold>+" 70)
consts not :: "c\<Rightarrow>c" ("\<^bold>~ _" 75)

definition notcontains :: "c\<Rightarrow>c\<Rightarrow>bool" (infix "\<^bold>\<notin>" 65) where
          "notcontains A B  \<equiv> \<not> (A \<^bold>\<in> B) "
definition equal :: "c \<Rightarrow> c \<Rightarrow> bool" (infixr "\<^bold>=" 40) where
          "equal A B \<equiv> A \<^bold>\<in> B \<and> B \<^bold>\<in> A"
definition notequal :: "c \<Rightarrow> c \<Rightarrow> bool" (infixr "\<^bold>\<noteq>" 40) where
          "notequal A B \<equiv>  \<not> equal A B"
definition possible :: "c \<Rightarrow> bool" ("P _" 74) where
          "P B \<equiv> \<forall>A. B \<^bold>\<notin> A \<^bold>+ \<^bold>~ A"
(*Note that possible does not mean possible propositions but possible concepts*)
definition disjunction :: "c \<Rightarrow> c \<Rightarrow> c" (infixr "\<^bold>\<or>" 71) where
          "A \<^bold>\<or> B \<equiv>  \<^bold>~ ((\<^bold>~A) \<^bold>+ \<^bold>~B)"
definition indconcept :: "c \<Rightarrow> bool" ("Ind _" 75) where
          "indconcept A  \<equiv> (P A) \<and> (\<forall>Y. (P (A \<^bold>+ Y)) \<longrightarrow> A \<^bold>\<in> Y)"
definition indexists :: "(c \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<^bold>\<exists>" 10) where(*Lenzen uses different symbol*)
          "\<^bold>\<exists>x. A x  \<equiv> \<exists>(X::c). (Ind X) \<and> A X"
definition indforall :: "(c \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<^bold>\<forall>" 10) where (*Lenzen uses different symbol*)
          "\<^bold>\<forall>x. A x \<equiv> \<forall>(X::c). (Ind X) \<longrightarrow> A X"

axiomatization where
IDEN2: "\<And>A B. A \<^bold>= B \<longrightarrow> (\<forall>\<alpha>. \<alpha> A \<longleftrightarrow> \<alpha> B)" and
CONT2: "\<And>A B C. A \<^bold>\<in> B \<Longrightarrow> B \<^bold>\<in> C \<Longrightarrow> A \<^bold>\<in> C" and
(*Lenzen uses conjunction here. For computational reasons implications are used*)

CONJ1: "\<And>A B C. A \<^bold>\<in> B \<^bold>+ C \<equiv> A \<^bold>\<in> B \<and> A \<^bold>\<in> C" and
NEG1: "\<And>A. (\<^bold>~ \<^bold>~ A) \<^bold>= A" and
NEG2: "\<And>A B. A \<^bold>\<in> B \<equiv> (\<^bold>~ B) \<^bold>\<in> \<^bold>~ A" and
NEG3: "\<And>A.\<not> (A \<^bold>= \<^bold>~ A)" and
POSS2: "\<And>A B. A \<^bold>\<in> B \<equiv> \<not> P(A \<^bold>+ \<^bold>~ B)" and
MAX: "\<And>B. P B \<Longrightarrow> \<exists>C. \<forall>A. ((B \<^bold>\<in> A) \<longrightarrow> (C \<^bold>\<in> A \<and> C \<^bold>\<notin> \<^bold>~ A))
     \<and> ((B \<^bold>\<in> \<^bold>~ A) \<longrightarrow>(C \<^bold>\<notin> A \<and> C \<^bold>\<in> \<^bold>~ A))
     \<and> ((B \<^bold>\<notin> A \<and> B \<^bold>\<notin> \<^bold>~ A) \<longrightarrow> (((C \<^bold>\<in> \<^bold>~ A) \<or> C \<^bold>\<in> A) \<and> (C \<^bold>\<notin> A \<^bold>+ \<^bold>~ A)))"
(*MAX is an axiom which does not occur in Lenzens paper.
It turns out to be equivalent to POSS3 and can thus, in principle, be replaced by it *)

lemma CONT1: "A \<^bold>\<in> A" (* This is not needed as an axiom. *)
using CONT2 NEG1 equal_def
by blast

lemma IDEN1: "A \<^bold>= A" (* This is not needed as an axiom. Lenzen explicitly lists it as one.*)
by(simp add: CONT1 equal_def)

lemma equal_sym: "A \<^bold>= B \<equiv> B \<^bold>= A" (*As far as i can tell: we don't need this*)
using equal_def
by smt

lemma CONJ2: "A \<^bold>+ A \<^bold>= A"
using CONJ1 CONT1 equal_def
by auto

lemma CONJ3: "A \<^bold>+ B \<^bold>= B \<^bold>+ A"
using CONJ1 CONT1 equal_def
by auto

lemma CONJ4: "A \<^bold>+ B \<^bold>\<in> A"
using CONJ1 CONT1 by auto

lemma CONJ5: "A \<^bold>+ B \<^bold>\<in> B"
using CONJ1 CONT1
by auto

lemma NEG4: "A \<^bold>= B \<Longrightarrow> (A \<^bold>\<noteq> \<^bold>~B)"
by (meson IDEN2 NEG3 notequal_def)

lemma NEG5: "P A \<Longrightarrow> (A \<^bold>\<notin> \<^bold>~ A)"
by(simp add: CONJ1 CONT1 possible_def notcontains_def)

lemma NEG6: "P A \<Longrightarrow> A \<^bold>\<in> B \<Longrightarrow> (A \<^bold>\<notin> \<^bold>~ B)"
by(simp add: CONJ1 possible_def notcontains_def)

lemma POSS1: "A \<^bold>\<in> B \<Longrightarrow> P(A) \<Longrightarrow> P(B)"
using CONT2 possible_def notcontains_def
by blast
(*Lenzen uses conjunction, for computational purposes we use implication*)

lemma NEG7: "(A \<^bold>+ \<^bold>~ A) \<^bold>\<in> B" sledgehammer[remote_leo2, verbose]
using CONJ4 CONT1 POSS1 POSS2 by blast
(*Lenzen perhaps thinks this should not be a theorem (p.14).
It is not clear whether this is a mistake on Lenzens part or if it follows
out of some extensional principle where Lenzen wants intensionality.*)

lemma DISJ1: "A \<^bold>\<in> (A \<^bold>\<or> B)"
by(metis CONJ3 CONJ4 NEG2 POSS1 POSS2 disjunction_def equal_def)

lemma DISJ2: "B \<^bold>\<in> (A \<^bold>\<or> B)"
by(metis CONJ3 CONJ5 NEG2 POSS1 POSS2 disjunction_def equal_def)

lemma DISJ3: "A \<^bold>\<in> C \<Longrightarrow> B \<^bold>\<in> C \<Longrightarrow> (A \<^bold>\<or> B) \<^bold>\<in> C"
proof -
fix A :: c and B :: c and C :: c
assume a1: "A \<^bold>\<in> C"
assume a2: "B \<^bold>\<in> C"
have f3: "(\<^bold>~ C) \<^bold>\<in> \<^bold>~ A"
  using a1
  by (metis NEG2)
have f4: "(\<^bold>~ C) \<^bold>\<in> \<^bold>~ B"
  using a2
  by (metis NEG2)
have "(\<^bold>~ C) \<^bold>\<in> (\<^bold>~ A) \<^bold>+ (\<^bold>~ B)"
  using f3 f4
  by (simp add: CONJ1)
thus "A \<^bold>\<or> B \<^bold>\<in> C"
  by(metis CONJ3 POSS1 POSS2 disjunction_def equal_def)
qed
(*Lenzen uses conjunction, for computational purposes we use implication*)

lemma cont3: "A \<^bold>\<in> B \<longleftrightarrow> (\<exists>Y. A \<^bold>= (B \<^bold>+ Y))"
using CONJ1 CONT1 equal_def
by blast
(*used for computation reasons, since Isabelle is not able to show
CONT3 in one step; at least on our machines*)

lemma CONT3: "A \<^bold>\<in> B \<equiv> (\<exists>Y. A \<^bold>= (B \<^bold>+ Y))"
by (simp add: cont3)

lemma CONJ6: "\<exists>Y. Y \<^bold>+ A \<^bold>\<in> B"
using CONJ1 CONT1
by blast

lemma CONJ7: "\<exists>Y. \<exists>Z. Y  \<^bold>+  A  \<^bold>=  Z  \<^bold>+  B"
using CONJ3
by blast

lemma NEG8: "A \<^bold>\<notin> B \<equiv> (\<exists>Y. (P(Y  \<^bold>+  A)) \<and> Y \<^bold>+ A \<^bold>\<in> \<^bold>~ B)"
by(smt CONJ3 CONJ5 CONT2 NEG6 POSS1 POSS2 equal_def notcontains_def)

lemma CONT4: "A \<^bold>\<in> B \<equiv> (\<forall>Y. Y \<^bold>\<in> A \<longrightarrow> Y \<^bold>\<in> B)"
by(smt CONT1 CONT2)

lemma CONT5: "A \<^bold>\<notin> B \<equiv> (\<forall>Y. A \<^bold>\<noteq> Y \<^bold>+ B)"
by(smt CONJ1 CONT1 equal_def notcontains_def notequal_def)

lemma IND1: "(Ind A) \<equiv> (\<forall>Y. (A \<^bold>\<in> \<^bold>~ Y) \<longleftrightarrow> A \<^bold>\<notin> Y)"
proof -
have "(\<forall>Y. (A \<^bold>\<in> \<^bold>~ Y) \<longleftrightarrow> A \<^bold>\<notin> Y) \<Longrightarrow> (Ind A)"
  by(metis CONJ1 CONJ4 CONT4 indconcept_def notcontains_def possible_def)
moreover have "(Ind A) \<Longrightarrow> (\<forall>Y. (A \<^bold>\<in> \<^bold>~ Y) \<longleftrightarrow> A \<^bold>\<notin> Y)"
  using NEG6 POSS2 indconcept_def notcontains_def
  by auto
ultimately show "(Ind A) \<equiv> (\<forall>Y. (A \<^bold>\<in> \<^bold>~ Y) \<longleftrightarrow> A \<^bold>\<notin> Y)"
  by smt
qed

lemma NEG9: "(Ind A) \<Longrightarrow> A \<^bold>\<notin> B \<Longrightarrow> A \<^bold>\<in> \<^bold>~ B"
by(simp add: IND1)

lemma POSS3: "P B \<equiv> \<^bold>\<exists>X. X \<^bold>\<in> B"
proof -
have f1:"P B \<Longrightarrow> \<^bold>\<exists>X. X \<^bold>\<in> B"
  proof -
  {
  assume a1: "P B"
  have "\<exists>C. \<forall>A. ((B \<^bold>\<in> A) \<longrightarrow> (C \<^bold>\<in> A \<and> C \<^bold>\<notin> \<^bold>~ A))
    \<and> ((B \<^bold>\<in> \<^bold>~ A) \<longrightarrow> (C \<^bold>\<notin> A \<and> C \<^bold>\<in> \<^bold>~ A))
    \<and> ((B \<^bold>\<notin> A \<and> B \<^bold>\<notin> \<^bold>~ A) \<longrightarrow> (((C \<^bold>\<in> \<^bold>~ A) \<or> C \<^bold>\<in> A) \<and> (C \<^bold>\<notin> A \<^bold>+ \<^bold>~ A)))"
    by(simp add: a1 MAX)
  then obtain C where o1: "\<forall>A. ((B \<^bold>\<in> A) \<longrightarrow> (C \<^bold>\<in> A \<and> C \<^bold>\<notin> \<^bold>~ A))
    \<and> ((B \<^bold>\<in> \<^bold>~ A) \<longrightarrow>(C \<^bold>\<notin> A \<and> C \<^bold>\<in> \<^bold>~ A))
    \<and> ((B \<^bold>\<notin> A \<and> B \<^bold>\<notin> \<^bold>~ A) \<longrightarrow> (((C \<^bold>\<in> \<^bold>~ A) \<or> C \<^bold>\<in> A) \<and> (C \<^bold>\<notin> A \<^bold>+ \<^bold>~ A)))"
    by blast
  have f2: "P C"
    using o1 CONJ4 POSS1 POSS2 notcontains_def
    by blast
  have "\<forall>Y. (P (C \<^bold>+ Y)) \<longrightarrow> C \<^bold>\<in> Y"
    using o1 CONJ4 CONJ5 CONT2 NEG6 notcontains_def
    by blast
  thus ?thesis
    using CONT1 indconcept_def indexists_def o1 possible_def f2
    by auto
  }
  qed
have "\<^bold>\<exists>x. x \<^bold>\<in> B \<Longrightarrow> P B"
  using POSS1 indconcept_def indexists_def
  by auto
with f1 show "P B \<equiv> \<^bold>\<exists>x. x \<^bold>\<in> B"
  by linarith
qed
(*As a side note: It follows from this that everything that is a non-contradictory
concept sans (non-)existence predicate does in fact exist.
So this axiomatization implies flying elephants  *)
(*Also note that MAX is used in this proof*)

lemma CONT5: "B \<^bold>\<in> C \<equiv> \<^bold>\<forall>X. (X \<^bold>\<in> B) \<longrightarrow> X \<^bold>\<in> C"
proof -
have "B \<^bold>\<in> C \<Longrightarrow> \<^bold>\<forall>X. (X \<^bold>\<in> B) \<longrightarrow> X \<^bold>\<in> C"
  using CONT2 indforall_def
  by blast
moreover have "\<^bold>\<forall>X. (X \<^bold>\<in> B) \<longrightarrow> X \<^bold>\<in> C \<Longrightarrow> B \<^bold>\<in> C"
  proof -
  assume a1: "\<^bold>\<forall>X. (X \<^bold>\<in> B) \<longrightarrow> X \<^bold>\<in> C"
    {
    assume a1: " B \<^bold>\<notin> C"
    hence "\<exists>A. B \<^bold>\<notin> A \<and> C \<^bold>\<in> A"
      using CONT1
      by blast
    then obtain A where o1: "B \<^bold>\<notin> A \<and> C \<^bold>\<in> A"
      by blast
    hence "B \<^bold>\<notin> A"
      by simp
    hence "(B \<^bold>\<in> \<^bold>~ A) \<or> (B \<^bold>\<notin> A \<and> B \<^bold>\<notin> A)"
      by simp
    hence "\<exists>E. E \<^bold>\<in> B \<and> (E \<^bold>\<in> \<^bold>~ A) \<and> (P E)"
      using CONJ4 CONJ5 POSS2 notcontains_def o1
      by blast
    then obtain E where o2: "E \<^bold>\<in> B \<and> (E \<^bold>\<in> \<^bold>~ A) \<and> (P E)"
      by blast
    hence "P E"
      by simp
    hence "\<exists>C. \<forall>A. ((E \<^bold>\<in> A) \<longrightarrow> (C \<^bold>\<in> A \<and> C \<^bold>\<notin> \<^bold>~ A))
      \<and> ((E \<^bold>\<in> \<^bold>~ A) \<longrightarrow> (C \<^bold>\<notin> A \<and> C \<^bold>\<in> \<^bold>~ A))
      \<and> ((E \<^bold>\<notin> A \<and> E \<^bold>\<notin> \<^bold>~ A) \<longrightarrow> (((C \<^bold>\<in> \<^bold>~ A) \<or> C \<^bold>\<in> A) \<and> (C \<^bold>\<notin> A \<^bold>+ \<^bold>~ A)))"
      by(rule MAX)
    then obtain D where o3: "\<forall>A. ((E \<^bold>\<in> A) \<longrightarrow> (D \<^bold>\<in> A \<and> D \<^bold>\<notin> \<^bold>~ A))
      \<and> ((E \<^bold>\<in> \<^bold>~ A) \<longrightarrow>(D \<^bold>\<notin> A \<and> D \<^bold>\<in> \<^bold>~ A))
      \<and> ((E \<^bold>\<notin> A \<and> E \<^bold>\<notin> \<^bold>~ A) \<longrightarrow> (((D \<^bold>\<in> \<^bold>~ A) \<or> D \<^bold>\<in> A) \<and> (D \<^bold>\<notin> A \<^bold>+ \<^bold>~ A)))"
      by blast
    with o2 have "D \<^bold>\<notin> A"
      by simp
    with o1 have "D \<^bold>\<notin> C"
      using CONT2 notcontains_def by blast
    moreover have "Ind D"
      by(metis o3 CONJ5 IND1 NEG6 NEG8 POSS1 notcontains_def)
    moreover have "D \<^bold>\<in> B"
      using o2 o3
      by simp
    ultimately have "\<^bold>\<exists>X. \<not> ((X \<^bold>\<in> B) \<longrightarrow> X \<^bold>\<in> C)"
      using indexists_def notcontains_def
      by auto
    hence "\<not> (\<^bold>\<forall>X. (X \<^bold>\<in> B) \<longrightarrow> X \<^bold>\<in> C)"
      by(simp add: indexists_def indforall_def)
    }
  with a1 show ?thesis
    using notcontains_def
    by blast
  qed
ultimately show "B \<^bold>\<in> C \<equiv> \<^bold>\<forall>X. (X \<^bold>\<in> B) \<longrightarrow> X \<^bold>\<in> C"
  by linarith
qed
(*Note that MAX is used in this proof *)

lemma True nitpick[user_axioms, expect=genuine, satisfy] oops
(*Nitpick finds a model; however it is the "empty assignment". Not sure about nitpicks inner workings
to determine if that is a problem.*)
end


(*  Title:      ZF/AC/DC.thy
    Author:     Krzysztof Grabczewski

The proofs concerning the Axiom of Dependent Choice.
*)

theory DC
imports AC_Equiv Hartog Cardinal_aux
begin

lemma RepFun_lepoll: "Ord(a) ==> {P(b). b \<in> a} \<lesssim> a"
apply (unfold lepoll_def)
apply (rule_tac x = "\<lambda>z \<in> RepFun (a,P) . \<mu> i. z=P (i) " in exI)
apply (rule_tac d="%z. P (z)" in lam_injective)
 apply (fast intro!: Least_in_Ord)
apply (rule sym)
apply (fast intro: LeastI Ord_in_Ord)
done

text\<open>Trivial in the presence of AC, but here we need a wellordering of X\<close>
lemma image_Ord_lepoll: "[| f \<in> X->Y; Ord(X) |] ==> f``X \<lesssim> X"
apply (unfold lepoll_def)
apply (rule_tac x = "\<lambda>x \<in> f``X. \<mu> y. f`y = x" in exI)
apply (rule_tac d = "%z. f`z" in lam_injective)
apply (fast intro!: Least_in_Ord apply_equality, clarify)
apply (rule LeastI)
 apply (erule apply_equality, assumption+)
apply (blast intro: Ord_in_Ord)
done

lemma range_subset_domain:
      "[| R \<subseteq> X*X;   !!g. g \<in> X ==> \<exists>u. <g,u> \<in> R |]
       ==> range(R) \<subseteq> domain(R)"
by blast

lemma cons_fun_type: "g \<in> n->X ==> cons(<n,x>, g) \<in> succ(n) -> cons(x, X)"
apply (unfold succ_def)
apply (fast intro!: fun_extend elim!: mem_irrefl)
done

lemma cons_fun_type2:
     "[| g \<in> n->X; x \<in> X |] ==> cons(<n,x>, g) \<in> succ(n) -> X"
by (erule cons_absorb [THEN subst], erule cons_fun_type)

lemma cons_image_n: "n \<in> nat ==> cons(<n,x>, g)``n = g``n"
by (fast elim!: mem_irrefl)

lemma cons_val_n: "g \<in> n->X ==> cons(<n,x>, g)`n = x"
by (fast intro!: apply_equality elim!: cons_fun_type)

lemma cons_image_k: "k \<in> n ==> cons(<n,x>, g)``k = g``k"
by (fast elim: mem_asym)

lemma cons_val_k: "[| k \<in> n; g \<in> n->X |] ==> cons(<n,x>, g)`k = g`k"
by (fast intro!: apply_equality consI2 elim!: cons_fun_type apply_Pair)

lemma domain_cons_eq_succ: "domain(f)=x ==> domain(cons(<x,y>, f)) = succ(x)"
by (simp add: domain_cons succ_def)

lemma restrict_cons_eq: "g \<in> n->X ==> restrict(cons(<n,x>, g), n) = g"
apply (simp add: restrict_def Pi_iff)
apply (blast intro: elim: mem_irrefl)
done

lemma succ_in_succ: "[| Ord(k); i \<in> k |] ==> succ(i) \<in> succ(k)"
apply (rule Ord_linear [of "succ(i)" "succ(k)", THEN disjE])
apply (fast elim: Ord_in_Ord mem_irrefl mem_asym)+
done

lemma restrict_eq_imp_val_eq:
      "[|restrict(f, domain(g)) = g; x \<in> domain(g)|]
       ==> f`x = g`x"
by (erule subst, simp add: restrict)

lemma domain_eq_imp_fun_type: "[| domain(f)=A; f \<in> B->C |] ==> f \<in> A->C"
by (frule domain_of_fun, fast)

lemma ex_in_domain: "[| R \<subseteq> A * B; R \<noteq> 0 |] ==> \<exists>x. x \<in> domain(R)"
by (fast elim!: not_emptyE)

definition
  DC  :: "i => o"  where
    "DC(a) == \<forall>X R. R \<subseteq> Pow(X)*X  &
                    (\<forall>Y \<in> Pow(X). Y \<prec> a \<longrightarrow> (\<exists>x \<in> X. <Y,x> \<in> R))
                    \<longrightarrow> (\<exists>f \<in> a->X. \<forall>b<a. <f``b,f`b> \<in> R)"

definition
  DC0 :: o  where
    "DC0 == \<forall>A B R. R \<subseteq> A*B & R\<noteq>0 & range(R) \<subseteq> domain(R)
                    \<longrightarrow> (\<exists>f \<in> nat->domain(R). \<forall>n \<in> nat. <f`n,f`succ(n)>:R)"

definition
  ff  :: "[i, i, i, i] => i"  where
    "ff(b, X, Q, R) ==
           transrec(b, %c r. THE x. first(x, {x \<in> X. <r``c, x> \<in> R}, Q))"

locale DC0_imp =
  fixes XX and RR and X and R

  assumes all_ex: "\<forall>Y \<in> Pow(X). Y \<prec> nat \<longrightarrow> (\<exists>x \<in> X. <Y, x> \<in> R)"

  defines XX_def: "XX == (\<Union>n \<in> nat. {f \<in> n->X. \<forall>k \<in> n. <f``k, f`k> \<in> R})"
     and RR_def:  "RR == {<z1,z2>:XX*XX. domain(z2)=succ(domain(z1))
                                       & restrict(z2, domain(z1)) = z1}"

(* ********************************************************************** *)
(* DC ==> DC(omega)                                                       *)
(*                                                                        *)
(* The scheme of the proof:                                               *)
(*                                                                        *)
(* Assume DC. Let R and X satisfy the premise of DC(omega).               *)
(*                                                                        *)
(* Define XX and RR as follows:                                           *)
(*                                                                        *)
(*       XX = (\<Union>n \<in> nat. {f \<in> n->X. \<forall>k \<in> n. <f``k, f`k> \<in> R})           *)
(*       f RR g iff domain(g)=succ(domain(f)) &                           *)
(*              restrict(g, domain(f)) = f                                *)
(*                                                                        *)
(* Then RR satisfies the hypotheses of DC.                                *)
(* So applying DC:                                                        *)
(*                                                                        *)
(*       \<exists>f \<in> nat->XX. \<forall>n \<in> nat. f`n RR f`succ(n)                        *)
(*                                                                        *)
(* Thence                                                                 *)
(*                                                                        *)
(*       ff = {<n, f`succ(n)`n>. n \<in> nat}                                 *)
(*                                                                        *)
(* is the desired function.                                               *)
(*                                                                        *)
(* ********************************************************************** *)

lemma (in DC0_imp) lemma1_1: "RR \<subseteq> XX*XX"
by (unfold RR_def, fast)

lemma (in DC0_imp) lemma1_2: "RR \<noteq> 0"
apply (unfold RR_def XX_def)
apply (rule all_ex [THEN ballE])
apply (erule_tac [2] notE [OF _ empty_subsetI [THEN PowI]])
apply (erule_tac impE [OF _ nat_0I [THEN n_lesspoll_nat]])
apply (erule bexE)
apply (rule_tac a = "<0, {<0, x>}>" in not_emptyI)
apply (rule CollectI)
apply (rule SigmaI)
apply (rule nat_0I [THEN UN_I])
apply (simp (no_asm_simp) add: nat_0I [THEN UN_I])
apply (rule nat_1I [THEN UN_I])
apply (force intro!: singleton_fun [THEN Pi_type]
             simp add: singleton_0 [symmetric])
apply (simp add: singleton_0)
done

lemma (in DC0_imp) lemma1_3: "range(RR) \<subseteq> domain(RR)"
apply (unfold RR_def XX_def)
apply (rule range_subset_domain, blast, clarify)
apply (frule fun_is_rel [THEN image_subset, THEN PowI,
                         THEN all_ex [THEN bspec]])
apply (erule impE[OF _ lesspoll_trans1[OF image_Ord_lepoll
                                          [OF _ nat_into_Ord] n_lesspoll_nat]],
       assumption+)
apply (erule bexE)
apply (rule_tac x = "cons (<n,x>, g) " in exI)
apply (rule CollectI)
apply (force elim!: cons_fun_type2
             simp add: cons_image_n cons_val_n cons_image_k cons_val_k)
apply (simp add: domain_of_fun succ_def restrict_cons_eq)
done

lemma (in DC0_imp) lemma2:
     "[| \<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  n \<in> nat |]
      ==> \<exists>k \<in> nat. f`succ(n) \<in> k -> X & n \<in> k
                  & <f`succ(n)``n, f`succ(n)`n> \<in> R"
apply (induct_tac "n")
apply (drule apply_type [OF _ nat_1I])
apply (drule bspec [OF _ nat_0I])
apply (simp add: XX_def, safe)
apply (rule rev_bexI, assumption)
apply (subgoal_tac "0 \<in> y", force)
apply (force simp add: RR_def
             intro: ltD elim!: nat_0_le [THEN leE])
(** LEVEL 7, other subgoal **)
apply (drule bspec [OF _ nat_succI], assumption)
apply (subgoal_tac "f ` succ (succ (x)) \<in> succ (k) ->X")
apply (drule apply_type [OF _ nat_succI [THEN nat_succI]], assumption)
apply (simp (no_asm_use) add: XX_def RR_def)
apply safe
apply (frule_tac a="succ(k)" in domain_of_fun [symmetric, THEN trans],
       assumption)
apply (frule_tac a=y in domain_of_fun [symmetric, THEN trans],
       assumption)
apply (fast elim!: nat_into_Ord [THEN succ_in_succ]
            dest!: bspec [OF _ nat_into_Ord [THEN succ_in_succ]])
apply (drule domain_of_fun)
apply (simp add: XX_def RR_def, clarify)
apply (blast dest: domain_of_fun [symmetric, THEN trans] )
done

lemma (in DC0_imp) lemma3_1:
     "[| \<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  m \<in> nat |]
      ==>  {f`succ(x)`x. x \<in> m} = {f`succ(m)`x. x \<in> m}"
apply (subgoal_tac "\<forall>x \<in> m. f`succ (m) `x = f`succ (x) `x")
apply simp
apply (induct_tac "m", blast)
apply (rule ballI)
apply (erule succE)
 apply (rule restrict_eq_imp_val_eq)
  apply (drule bspec [OF _ nat_succI], assumption)
  apply (simp add: RR_def)
 apply (drule lemma2, assumption+)
 apply (fast dest!: domain_of_fun)
apply (drule_tac x = xa in bspec, assumption)
apply (erule sym [THEN trans, symmetric])
apply (rule restrict_eq_imp_val_eq [symmetric])
 apply (drule bspec [OF _ nat_succI], assumption)
 apply (simp add: RR_def)
apply (drule lemma2, assumption+)
apply (blast dest!: domain_of_fun
             intro: nat_into_Ord OrdmemD [THEN subsetD])
done

lemma (in DC0_imp) lemma3:
     "[| \<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  m \<in> nat |]
      ==> (\<lambda>x \<in> nat. f`succ(x)`x) `` m = f`succ(m)``m"
apply (erule natE, simp)
apply (subst image_lam)
 apply (fast elim!: OrdmemD [OF nat_succI Ord_nat])
apply (subst lemma3_1, assumption+)
 apply fast
apply (fast dest!: lemma2
            elim!: image_fun [symmetric, OF _ OrdmemD [OF _ nat_into_Ord]])
done

theorem DC0_imp_DC_nat: "DC0 ==> DC(nat)"
apply (unfold DC_def DC0_def, clarify)
apply (elim allE)
apply (erule impE)
   (*these three results comprise Lemma 1*)
apply (blast intro!: DC0_imp.lemma1_1 [OF DC0_imp.intro] DC0_imp.lemma1_2 [OF DC0_imp.intro] DC0_imp.lemma1_3 [OF DC0_imp.intro])
apply (erule bexE)
apply (rule_tac x = "\<lambda>n \<in> nat. f`succ (n) `n" in rev_bexI)
 apply (rule lam_type, blast dest!: DC0_imp.lemma2 [OF DC0_imp.intro] intro: fun_weaken_type)
apply (rule oallI)
apply (frule DC0_imp.lemma2 [OF DC0_imp.intro], assumption)
  apply (blast intro: fun_weaken_type)
 apply (erule ltD)
(** LEVEL 11: last subgoal **)
apply (subst DC0_imp.lemma3 [OF DC0_imp.intro], assumption+)
  apply (fast elim!: fun_weaken_type)
 apply (erule ltD)
apply (force simp add: lt_def)
done

(* ************************************************************************
   DC(omega) ==> DC

   The scheme of the proof:

   Assume DC(omega). Let R and x satisfy the premise of DC.

   Define XX and RR as follows:

    XX = (\<Union>n \<in> nat. {f \<in> succ(n)->domain(R). \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})

    RR = {<z1,z2>:Fin(XX)*XX.
           (domain(z2)=succ(\<Union>f \<in> z1. domain(f)) &
            (\<forall>f \<in> z1. restrict(z2, domain(f)) = f)) |
           (~ (\<exists>g \<in> XX. domain(g)=succ(\<Union>f \<in> z1. domain(f)) &
                        (\<forall>f \<in> z1. restrict(g, domain(f)) = f)) &
            z2={<0,x>})}

   Then XX and RR satisfy the hypotheses of DC(omega).
   So applying DC:

         \<exists>f \<in> nat->XX. \<forall>n \<in> nat. f``n RR f`n

   Thence

         ff = {<n, f`n`n>. n \<in> nat}

   is the desired function.

************************************************************************* *)

lemma singleton_in_funs:
 "x \<in> X ==> {<0,x>} \<in>
            (\<Union>n \<in> nat. {f \<in> succ(n)->X. \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})"
apply (rule nat_0I [THEN UN_I])
apply (force simp add: singleton_0 [symmetric]
             intro!: singleton_fun [THEN Pi_type])
done

locale imp_DC0 =
  fixes XX and RR and x and R and f and allRR
  defines XX_def: "XX == (\<Union>n \<in> nat.
                      {f \<in> succ(n)->domain(R). \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})"
      and RR_def:
         "RR == {<z1,z2>:Fin(XX)*XX.
                  (domain(z2)=succ(\<Union>f \<in> z1. domain(f))
                    & (\<forall>f \<in> z1. restrict(z2, domain(f)) = f))
                  | (~ (\<exists>g \<in> XX. domain(g)=succ(\<Union>f \<in> z1. domain(f))
                     & (\<forall>f \<in> z1. restrict(g, domain(f)) = f)) & z2={<0,x>})}"
      and allRR_def:
        "allRR == \<forall>b<nat.
                   <f``b, f`b> \<in>
                    {<z1,z2>\<in>Fin(XX)*XX. (domain(z2)=succ(\<Union>f \<in> z1. domain(f))
                                    & (\<Union>f \<in> z1. domain(f)) = b
                                    & (\<forall>f \<in> z1. restrict(z2,domain(f)) = f))}"

lemma (in imp_DC0) lemma4:
     "[| range(R) \<subseteq> domain(R);  x \<in> domain(R) |]
      ==> RR \<subseteq> Pow(XX)*XX &
             (\<forall>Y \<in> Pow(XX). Y \<prec> nat \<longrightarrow> (\<exists>x \<in> XX. <Y,x>:RR))"
apply (rule conjI)
apply (force dest!: FinD [THEN PowI] simp add: RR_def)
apply (rule impI [THEN ballI])
apply (drule Finite_Fin [OF lesspoll_nat_is_Finite PowD], assumption)
apply (case_tac
       "\<exists>g \<in> XX. domain (g) =
             succ(\<Union>f \<in> Y. domain(f)) & (\<forall>f\<in>Y. restrict(g, domain(f)) = f)")
apply (simp add: RR_def, blast)
apply (safe del: domainE)
apply (unfold XX_def RR_def)
apply (rule rev_bexI, erule singleton_in_funs)
apply (simp add: nat_0I [THEN rev_bexI] cons_fun_type2)
done

lemma (in imp_DC0) UN_image_succ_eq:
     "[| f \<in> nat->X; n \<in> nat |]
      ==> (\<Union>x \<in> f``succ(n). P(x)) =  P(f`n) \<union> (\<Union>x \<in> f``n. P(x))"
by (simp add: image_fun OrdmemD)

lemma (in imp_DC0) UN_image_succ_eq_succ:
     "[| (\<Union>x \<in> f``n. P(x)) = y; P(f`n) = succ(y);
         f \<in> nat -> X; n \<in> nat |] ==> (\<Union>x \<in> f``succ(n). P(x)) = succ(y)"
by (simp add: UN_image_succ_eq, blast)

lemma (in imp_DC0) apply_domain_type:
     "[| h \<in> succ(n) -> D;  n \<in> nat; domain(h)=succ(y) |] ==> h`y \<in> D"
by (fast elim: apply_type dest!: trans [OF sym domain_of_fun])

lemma (in imp_DC0) image_fun_succ:
     "[| h \<in> nat -> X; n \<in> nat |] ==> h``succ(n) = cons(h`n, h``n)"
by (simp add: image_fun OrdmemD)

lemma (in imp_DC0) f_n_type:
     "[| domain(f`n) = succ(k); f \<in> nat -> XX;  n \<in> nat |]
      ==> f`n \<in> succ(k) -> domain(R)"
apply (unfold XX_def)
apply (drule apply_type, assumption)
apply (fast elim: domain_eq_imp_fun_type)
done

lemma (in imp_DC0) f_n_pairs_in_R [rule_format]:
     "[| h \<in> nat -> XX;  domain(h`n) = succ(k);  n \<in> nat |]
      ==> \<forall>i \<in> k. <h`n`i, h`n`succ(i)> \<in> R"
apply (unfold XX_def)
apply (drule apply_type, assumption)
apply (elim UN_E CollectE)
apply (drule domain_of_fun [symmetric, THEN trans], assumption, simp)
done

lemma (in imp_DC0) restrict_cons_eq_restrict:
     "[| restrict(h, domain(u))=u;  h \<in> n->X;  domain(u) \<subseteq> n |]
      ==> restrict(cons(<n, y>, h), domain(u)) = u"
apply (unfold restrict_def)
apply (simp add: restrict_def Pi_iff)
apply (erule sym [THEN trans, symmetric])
apply (blast elim: mem_irrefl)
done

lemma (in imp_DC0) all_in_image_restrict_eq:
     "[| \<forall>x \<in> f``n. restrict(f`n, domain(x))=x;
         f \<in> nat -> XX;
         n \<in> nat;  domain(f`n) = succ(n);
         (\<Union>x \<in> f``n. domain(x)) \<subseteq> n |]
      ==> \<forall>x \<in> f``succ(n). restrict(cons(<succ(n),y>, f`n), domain(x)) = x"
apply (rule ballI)
apply (simp add: image_fun_succ)
apply (drule f_n_type, assumption+)
apply (erule disjE)
 apply (simp add: domain_of_fun restrict_cons_eq)
apply (blast intro!: restrict_cons_eq_restrict)
done

lemma (in imp_DC0) simplify_recursion:
     "[| \<forall>b<nat. <f``b, f`b> \<in> RR;
         f \<in> nat -> XX; range(R) \<subseteq> domain(R); x \<in> domain(R)|]
      ==> allRR"
apply (unfold RR_def allRR_def)
apply (rule oallI, drule ltD)
apply (erule nat_induct)
apply (drule_tac x=0 in ospec, blast intro: Limit_has_0)
apply (force simp add: singleton_fun [THEN domain_of_fun] singleton_in_funs)
(*induction step*) (** LEVEL 5 **)
(*prevent simplification of ~\<exists> to \<forall>~ *)
apply (simp only: separation split)
apply (drule_tac x="succ(xa)" in ospec, blast intro: ltI)
apply (elim conjE disjE)
apply (force elim!: trans subst_context
             intro!: UN_image_succ_eq_succ)
apply (erule notE)
apply (simp add: XX_def UN_image_succ_eq_succ)
apply (elim conjE bexE)
apply (drule apply_domain_type, assumption+)
apply (erule domainE)+
apply (frule f_n_type)
apply (simp add: XX_def, assumption+)
apply (rule rev_bexI, erule nat_succI)
apply (rename_tac m i j y z)
apply (rule_tac x = "cons(<succ(m), z>, f`m)" in bexI)
prefer 2 apply (blast intro: cons_fun_type2)
apply (rule conjI)
prefer 2 apply (fast del: ballI subsetI
                 elim: trans [OF _ subst_context, THEN domain_cons_eq_succ]
                       subst_context
                       all_in_image_restrict_eq [simplified XX_def]
                       trans equalityD1)
(*one remaining subgoal*)
apply (rule ballI)
apply (erule succE)
(** LEVEL 25 **)
 apply (simp add: cons_val_n cons_val_k)
(*assumption+ will not perform the required backtracking!*)
apply (drule f_n_pairs_in_R [simplified XX_def, OF _ domain_of_fun],
       assumption, assumption, assumption)
apply (simp add: nat_into_Ord [THEN succ_in_succ] succI2 cons_val_k)
done

lemma (in imp_DC0) lemma2:
     "[| allRR; f \<in> nat->XX; range(R) \<subseteq> domain(R); x \<in> domain(R); n \<in> nat |]
      ==> f`n \<in> succ(n) -> domain(R) & (\<forall>i \<in> n. <f`n`i, f`n`succ(i)>:R)"
apply (unfold allRR_def)
apply (drule ospec)
apply (erule ltI [OF _ Ord_nat])
apply (erule CollectE, simp)
apply (rule conjI)
prefer 2 apply (fast elim!: f_n_pairs_in_R trans subst_context)
apply (unfold XX_def)
apply (fast elim!: trans [THEN domain_eq_imp_fun_type] subst_context)
done

lemma (in imp_DC0) lemma3:
     "[| allRR; f \<in> nat->XX; n\<in>nat; range(R) \<subseteq> domain(R);  x \<in> domain(R) |]
      ==> f`n`n = f`succ(n)`n"
apply (frule lemma2 [THEN conjunct1, THEN domain_of_fun], assumption+)
apply (unfold allRR_def)
apply (drule ospec)
apply (drule ltI [OF nat_succI Ord_nat], assumption, simp)
apply (elim conjE ballE)
apply (erule restrict_eq_imp_val_eq [symmetric], force)
apply (simp add: image_fun OrdmemD)
done

theorem DC_nat_imp_DC0: "DC(nat) ==> DC0"
apply (unfold DC_def DC0_def)
apply (intro allI impI)
apply (erule asm_rl conjE ex_in_domain [THEN exE] allE)+
apply (erule impE [OF _ imp_DC0.lemma4], assumption+)
apply (erule bexE)
apply (drule imp_DC0.simplify_recursion, assumption+)
apply (rule_tac x = "\<lambda>n \<in> nat. f`n`n" in bexI)
apply (rule_tac [2] lam_type)
apply (erule_tac [2] apply_type [OF imp_DC0.lemma2 [THEN conjunct1] succI1])
apply (rule ballI)
apply (frule_tac n="succ(n)" in imp_DC0.lemma2,
       (assumption|erule nat_succI)+)
apply (drule imp_DC0.lemma3, auto)
done

(* ********************************************************************** *)
(* \<forall>K. Card(K) \<longrightarrow> DC(K) ==> WO3                                       *)
(* ********************************************************************** *)

lemma fun_Ord_inj:
      "[| f \<in> a->X;  Ord(a);
          !!b c. [| b<c; c \<in> a |] ==> f`b\<noteq>f`c |]
       ==> f \<in> inj(a, X)"
apply (unfold inj_def, simp)
apply (intro ballI impI)
apply (rule_tac j=x in Ord_in_Ord [THEN Ord_linear_lt], assumption+)
apply (blast intro: Ord_in_Ord, auto)
apply (atomize, blast dest: not_sym)
done

lemma value_in_image: "[| f \<in> X->Y; A \<subseteq> X; a \<in> A |] ==> f`a \<in> f``A"
by (fast elim!: image_fun [THEN ssubst])

lemma lesspoll_lemma: "[| ~ A \<prec> B; C \<prec> B |] ==> A - C \<noteq> 0"
apply (unfold lesspoll_def)
apply (fast dest!: Diff_eq_0_iff [THEN iffD1, THEN subset_imp_lepoll]
            intro!: eqpollI elim: notE
            elim!: eqpollE lepoll_trans)
done

theorem DC_WO3: "(\<forall>K. Card(K) \<longrightarrow> DC(K)) ==> WO3"
apply (unfold DC_def WO3_def)
apply (rule allI)
apply (case_tac "A \<prec> Hartog (A)")
apply (fast dest!: lesspoll_imp_ex_lt_eqpoll
            intro!: Ord_Hartog leI [THEN le_imp_subset])
apply (erule allE impE)+
apply (rule Card_Hartog)
apply (erule_tac x = A in allE)
apply (erule_tac x = "{<z1,z2> \<in> Pow (A) *A . z1 \<prec> Hartog (A) & z2 \<notin> z1}"
                 in allE)
apply simp
apply (erule impE, fast elim: lesspoll_lemma [THEN not_emptyE])
apply (erule bexE)
apply (rule Hartog_lepoll_selfE)
apply (rule lepoll_def [THEN def_imp_iff, THEN iffD2])
apply (rule exI, rule fun_Ord_inj, assumption, rule Ord_Hartog)
apply (drule value_in_image)
apply (drule OrdmemD, rule Ord_Hartog, assumption+, erule ltD)
apply (drule ospec)
apply (blast intro: ltI Ord_Hartog, force)
done

(* ********************************************************************** *)
(* WO1 ==> \<forall>K. Card(K) \<longrightarrow> DC(K)                                       *)
(* ********************************************************************** *)

lemma images_eq:
     "[| \<forall>x \<in> A. f`x=g`x; f \<in> Df->Cf; g \<in> Dg->Cg; A \<subseteq> Df; A \<subseteq> Dg |]
      ==> f``A = g``A"
apply (simp (no_asm_simp) add: image_fun)
done

lemma lam_images_eq:
     "[| Ord(a); b \<in> a |] ==> (\<lambda>x \<in> a. h(x))``b = (\<lambda>x \<in> b. h(x))``b"
apply (rule images_eq)
    apply (rule ballI)
    apply (drule OrdmemD [THEN subsetD], assumption+)
    apply simp
   apply (fast elim!: RepFunI OrdmemD intro!: lam_type)+
done

lemma lam_type_RepFun: "(\<lambda>b \<in> a. h(b)) \<in> a -> {h(b). b \<in> a}"
by (fast intro!: lam_type RepFunI)

lemma lemmaX:
     "[| \<forall>Y \<in> Pow(X). Y \<prec> K \<longrightarrow> (\<exists>x \<in> X. <Y, x> \<in> R);
         b \<in> K; Z \<in> Pow(X); Z \<prec> K |]
      ==> {x \<in> X. <Z,x> \<in> R} \<noteq> 0"
by blast

lemma WO1_DC_lemma:
     "[| Card(K); well_ord(X,Q);
         \<forall>Y \<in> Pow(X). Y \<prec> K \<longrightarrow> (\<exists>x \<in> X. <Y, x> \<in> R); b \<in> K |]
      ==> ff(b, X, Q, R) \<in> {x \<in> X. <(\<lambda>c \<in> b. ff(c, X, Q, R))``b, x> \<in> R}"
apply (rule_tac P = "b \<in> K" in impE, (erule_tac [2] asm_rl)+)
apply (rule_tac i=b in Card_is_Ord [THEN Ord_in_Ord, THEN trans_induct],
       assumption+)
apply (rule impI)
apply (rule ff_def [THEN def_transrec, THEN ssubst])
apply (erule the_first_in, fast)
apply (simp add: image_fun [OF lam_type_RepFun subset_refl])
apply (erule lemmaX, assumption)
 apply (blast intro: Card_is_Ord OrdmemD [THEN subsetD])
apply (blast intro: lesspoll_trans1 in_Card_imp_lesspoll RepFun_lepoll)
done

theorem WO1_DC_Card: "WO1 ==> \<forall>K. Card(K) \<longrightarrow> DC(K)"
apply (unfold DC_def WO1_def)
apply (rule allI impI)+
apply (erule allE exE conjE)+
apply (rule_tac x = "\<lambda>b \<in> K. ff (b, X, Ra, R) " in bexI)
 apply (simp add: lam_images_eq [OF Card_is_Ord ltD])
 apply (fast elim!: ltE WO1_DC_lemma [THEN CollectD2])
apply (rule_tac lam_type)
apply (rule WO1_DC_lemma [THEN CollectD1], assumption+)
done

end