(*  Title:      HOL/UNITY/Transformers.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2003  University of Cambridge

Predicate Transformers.  From

    David Meier and Beverly Sanders,
    Composing Leads-to Properties
    Theoretical Computer Science 243:1-2 (2000), 339-361.

    David Meier,
    Progress Properties in Program Refinement and Parallel Composition
    Swiss Federal Institute of Technology Zurich (1997)
*)

section{*Predicate Transformers*}

theory Transformers imports Comp begin

subsection{*Defining the Predicate Transformers @{term wp},
   @{term awp} and  @{term wens}*}

definition wp :: "[('a*'a) set, 'a set] => 'a set" where
    --{*Dijkstra's weakest-precondition operator (for an individual command)*}
    "wp act B == - (act^-1 `` (-B))"

definition awp :: "['a program, 'a set] => 'a set" where
    --{*Dijkstra's weakest-precondition operator (for a program)*}
    "awp F B == (\<Inter>act \<in> Acts F. wp act B)"

definition wens :: "['a program, ('a*'a) set, 'a set] => 'a set" where
    --{*The weakest-ensures transformer*}
    "wens F act B == gfp(\<lambda>X. (wp act B \<inter> awp F (B \<union> X)) \<union> B)"

text{*The fundamental theorem for wp*}
theorem wp_iff: "(A <= wp act B) = (act `` A <= B)"
by (force simp add: wp_def)

text{*This lemma is a good deal more intuitive than the definition!*}
lemma in_wp_iff: "(a \<in> wp act B) = (\<forall>x. (a,x) \<in> act --> x \<in> B)"
by (simp add: wp_def, blast)

lemma Compl_Domain_subset_wp: "- (Domain act) \<subseteq> wp act B"
by (force simp add: wp_def)

lemma wp_empty [simp]: "wp act {} = - (Domain act)"
by (force simp add: wp_def)

text{*The identity relation is the skip action*}
lemma wp_Id [simp]: "wp Id B = B"
by (simp add: wp_def)

lemma wp_totalize_act:
     "wp (totalize_act act) B = (wp act B \<inter> Domain act) \<union> (B - Domain act)"
by (simp add: wp_def totalize_act_def, blast)

lemma awp_subset: "(awp F A \<subseteq> A)"
by (force simp add: awp_def wp_def)

lemma awp_Int_eq: "awp F (A\<inter>B) = awp F A \<inter> awp F B"
by (simp add: awp_def wp_def, blast)

text{*The fundamental theorem for awp*}
theorem awp_iff_constrains: "(A <= awp F B) = (F \<in> A co B)"
by (simp add: awp_def constrains_def wp_iff INT_subset_iff)

lemma awp_iff_stable: "(A \<subseteq> awp F A) = (F \<in> stable A)"
by (simp add: awp_iff_constrains stable_def)

lemma stable_imp_awp_ident: "F \<in> stable A ==> awp F A = A"
apply (rule equalityI [OF awp_subset])
apply (simp add: awp_iff_stable)
done

lemma wp_mono: "(A \<subseteq> B) ==> wp act A \<subseteq> wp act B"
by (simp add: wp_def, blast)

lemma awp_mono: "(A \<subseteq> B) ==> awp F A \<subseteq> awp F B"
by (simp add: awp_def wp_def, blast)

lemma wens_unfold:
     "wens F act B = (wp act B \<inter> awp F (B \<union> wens F act B)) \<union> B"
apply (simp add: wens_def)
apply (rule gfp_unfold)
apply (simp add: mono_def wp_def awp_def, blast)
done

lemma wens_Id [simp]: "wens F Id B = B"
by (simp add: wens_def gfp_def wp_def awp_def, blast)

text{*These two theorems justify the claim that @{term wens} returns the
weakest assertion satisfying the ensures property*}
lemma ensures_imp_wens: "F \<in> A ensures B ==> \<exists>act \<in> Acts F. A \<subseteq> wens F act B"
apply (simp add: wens_def ensures_def transient_def, clarify)
apply (rule rev_bexI, assumption)
apply (rule gfp_upperbound)
apply (simp add: constrains_def awp_def wp_def, blast)
done

lemma wens_ensures: "act \<in> Acts F ==> F \<in> (wens F act B) ensures B"
by (simp add: wens_def gfp_def constrains_def awp_def wp_def
              ensures_def transient_def, blast)

text{*These two results constitute assertion (4.13) of the thesis*}
lemma wens_mono: "(A \<subseteq> B) ==> wens F act A \<subseteq> wens F act B"
apply (simp add: wens_def wp_def awp_def)
apply (rule gfp_mono, blast)
done

lemma wens_weakening: "B \<subseteq> wens F act B"
by (simp add: wens_def gfp_def, blast)

text{*Assertion (6), or 4.16 in the thesis*}
lemma subset_wens: "A-B \<subseteq> wp act B \<inter> awp F (B \<union> A) ==> A \<subseteq> wens F act B"
apply (simp add: wens_def wp_def awp_def)
apply (rule gfp_upperbound, blast)
done

text{*Assertion 4.17 in the thesis*}
lemma Diff_wens_constrains: "F \<in> (wens F act A - A) co wens F act A"
by (simp add: wens_def gfp_def wp_def awp_def constrains_def, blast)
  --{*Proved instantly, yet remarkably fragile. If @{text Un_subset_iff}
      is declared as an iff-rule, then it's almost impossible to prove.
      One proof is via @{text meson} after expanding all definitions, but it's
      slow!*}

text{*Assertion (7): 4.18 in the thesis.  NOTE that many of these results
hold for an arbitrary action.  We often do not require @{term "act \<in> Acts F"}*}
lemma stable_wens: "F \<in> stable A ==> F \<in> stable (wens F act A)"
apply (simp add: stable_def)
apply (drule constrains_Un [OF Diff_wens_constrains [of F act A]])
apply (simp add: Un_Int_distrib2 Compl_partition2)
apply (erule constrains_weaken, blast)
apply (simp add: wens_weakening)
done

text{*Assertion 4.20 in the thesis.*}
lemma wens_Int_eq_lemma:
      "[|T-B \<subseteq> awp F T; act \<in> Acts F|]
       ==> T \<inter> wens F act B \<subseteq> wens F act (T\<inter>B)"
apply (rule subset_wens)
apply (rule_tac P="\<lambda>x. ?f x \<subseteq> ?b" in ssubst [OF wens_unfold])
apply (simp add: wp_def awp_def, blast)
done

text{*Assertion (8): 4.21 in the thesis. Here we indeed require
      @{term "act \<in> Acts F"}*}
lemma wens_Int_eq:
      "[|T-B \<subseteq> awp F T; act \<in> Acts F|]
       ==> T \<inter> wens F act B = T \<inter> wens F act (T\<inter>B)"
apply (rule equalityI)
 apply (simp_all add: Int_lower1)
 apply (rule wens_Int_eq_lemma, assumption+)
apply (rule subset_trans [OF _ wens_mono [of "T\<inter>B" B]], auto)
done

subsection{*Defining the Weakest Ensures Set*}

inductive_set
  wens_set :: "['a program, 'a set] => 'a set set"
  for F :: "'a program" and B :: "'a set"
where

  Basis: "B \<in> wens_set F B"

| Wens:  "[|X \<in> wens_set F B; act \<in> Acts F|] ==> wens F act X \<in> wens_set F B"

| Union: "W \<noteq> {} ==> \<forall>U \<in> W. U \<in> wens_set F B ==> \<Union>W \<in> wens_set F B"

lemma wens_set_imp_co: "A \<in> wens_set F B ==> F \<in> (A-B) co A"
apply (erule wens_set.induct)
  apply (simp add: constrains_def)
 apply (drule_tac act1=act and A1=X
        in constrains_Un [OF Diff_wens_constrains])
 apply (erule constrains_weaken, blast)
 apply (simp add: wens_weakening)
apply (rule constrains_weaken)
apply (rule_tac I=W and A="\<lambda>v. v-B" and A'="\<lambda>v. v" in constrains_UN, blast+)
done

lemma wens_set_imp_leadsTo: "A \<in> wens_set F B ==> F \<in> A leadsTo B"
apply (erule wens_set.induct)
  apply (rule leadsTo_refl)
 apply (blast intro: wens_ensures leadsTo_Trans)
apply (blast intro: leadsTo_Union)
done

lemma leadsTo_imp_wens_set: "F \<in> A leadsTo B ==> \<exists>C \<in> wens_set F B. A \<subseteq> C"
apply (erule leadsTo_induct_pre)
  apply (blast dest!: ensures_imp_wens intro: wens_set.Basis wens_set.Wens)
 apply (clarify, drule ensures_weaken_R, assumption)
 apply (blast dest!: ensures_imp_wens intro: wens_set.Wens)
apply (case_tac "S={}")
 apply (simp, blast intro: wens_set.Basis)
apply (clarsimp dest!: bchoice simp: ball_conj_distrib Bex_def)
apply (rule_tac x = "\<Union>{Z. \<exists>U\<in>S. Z = f U}" in exI)
apply (blast intro: wens_set.Union)
done

text{*Assertion (9): 4.27 in the thesis.*}
lemma leadsTo_iff_wens_set: "(F \<in> A leadsTo B) = (\<exists>C \<in> wens_set F B. A \<subseteq> C)"
by (blast intro: leadsTo_imp_wens_set leadsTo_weaken_L wens_set_imp_leadsTo)

text{*This is the result that requires the definition of @{term wens_set} to
  require @{term W} to be non-empty in the Unio case, for otherwise we should
  always have @{term "{} \<in> wens_set F B"}.*}
lemma wens_set_imp_subset: "A \<in> wens_set F B ==> B \<subseteq> A"
apply (erule wens_set.induct)
  apply (blast intro: wens_weakening [THEN subsetD])+
done

subsection{*Properties Involving Program Union*}

text{*Assertion (4.30) of thesis, reoriented*}
lemma awp_Join_eq: "awp (F\<squnion>G) B = awp F B \<inter> awp G B"
by (simp add: awp_def wp_def, blast)

lemma wens_subset: "wens F act B - B \<subseteq> wp act B \<inter> awp F (B \<union> wens F act B)"
by (subst wens_unfold, fast)

text{*Assertion (4.31)*}
lemma subset_wens_Join:
      "[|A = T \<inter> wens F act B;  T-B \<subseteq> awp F T; A-B \<subseteq> awp G (A \<union> B)|]
       ==> A \<subseteq> wens (F\<squnion>G) act B"
apply (subgoal_tac "(T \<inter> wens F act B) - B \<subseteq>
                    wp act B \<inter> awp F (B \<union> wens F act B) \<inter> awp F T")
 apply (rule subset_wens)
 apply (simp add: awp_Join_eq awp_Int_eq Un_commute)
 apply (simp add: awp_def wp_def, blast)
apply (insert wens_subset [of F act B], blast)
done

text{*Assertion (4.32)*}
lemma wens_Join_subset: "wens (F\<squnion>G) act B \<subseteq> wens F act B"
apply (simp add: wens_def)
apply (rule gfp_mono)
apply (auto simp add: awp_Join_eq)
done

text{*Lemma, because the inductive step is just too messy.*}
lemma wens_Union_inductive_step:
  assumes awpF: "T-B \<subseteq> awp F T"
      and awpG: "!!X. X \<in> wens_set F B ==> (T\<inter>X) - B \<subseteq> awp G (T\<inter>X)"
  shows "[|X \<in> wens_set F B; act \<in> Acts F; Y \<subseteq> X; T\<inter>X = T\<inter>Y|]
         ==> wens (F\<squnion>G) act Y \<subseteq> wens F act X \<and>
             T \<inter> wens F act X = T \<inter> wens (F\<squnion>G) act Y"
apply (subgoal_tac "wens (F\<squnion>G) act Y \<subseteq> wens F act X")
 prefer 2
 apply (blast dest: wens_mono intro: wens_Join_subset [THEN subsetD], simp)
apply (rule equalityI)
 prefer 2 apply blast
apply (simp add: Int_lower1)
apply (frule wens_set_imp_subset)
apply (subgoal_tac "T-X \<subseteq> awp F T")
 prefer 2 apply (blast intro: awpF [THEN subsetD])
apply (rule_tac B = "wens (F\<squnion>G) act (T\<inter>X)" in subset_trans)
 prefer 2 apply (blast intro!: wens_mono)
apply (subst wens_Int_eq, assumption+)
apply (rule subset_wens_Join [of _ T], simp, blast)
apply (subgoal_tac "T \<inter> wens F act (T\<inter>X) \<union> T\<inter>X = T \<inter> wens F act X")
 prefer 2
 apply (subst wens_Int_eq [symmetric], assumption+)
 apply (blast intro: wens_weakening [THEN subsetD], simp)
apply (blast intro: awpG [THEN subsetD] wens_set.Wens)
done

theorem wens_Union:
  assumes awpF: "T-B \<subseteq> awp F T"
      and awpG: "!!X. X \<in> wens_set F B ==> (T\<inter>X) - B \<subseteq> awp G (T\<inter>X)"
      and major: "X \<in> wens_set F B"
  shows "\<exists>Y \<in> wens_set (F\<squnion>G) B. Y \<subseteq> X & T\<inter>X = T\<inter>Y"
apply (rule wens_set.induct [OF major])
  txt{*Basis: trivial*}
  apply (blast intro: wens_set.Basis)
 txt{*Inductive step*}
 apply clarify
 apply (rule_tac x = "wens (F\<squnion>G) act Y" in rev_bexI)
  apply (force intro: wens_set.Wens)
 apply (simp add: wens_Union_inductive_step [OF awpF awpG])
txt{*Union: by Axiom of Choice*}
apply (simp add: ball_conj_distrib Bex_def)
apply (clarify dest!: bchoice)
apply (rule_tac x = "\<Union>{Z. \<exists>U\<in>W. Z = f U}" in exI)
apply (blast intro: wens_set.Union)
done

theorem leadsTo_Join:
  assumes leadsTo: "F \<in> A leadsTo B"
      and awpF: "T-B \<subseteq> awp F T"
      and awpG: "!!X. X \<in> wens_set F B ==> (T\<inter>X) - B \<subseteq> awp G (T\<inter>X)"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
apply (rule leadsTo [THEN leadsTo_imp_wens_set, THEN bexE])
apply (rule wens_Union [THEN bexE])
   apply (rule awpF)
  apply (erule awpG, assumption)
apply (blast intro: wens_set_imp_leadsTo [THEN leadsTo_weaken_L])
done

subsection {*The Set @{term "wens_set F B"} for a Single-Assignment Program*}
text{*Thesis Section 4.3.3*}

text{*We start by proving laws about single-assignment programs*}
lemma awp_single_eq [simp]:
     "awp (mk_program (init, {act}, allowed)) B = B \<inter> wp act B"
by (force simp add: awp_def wp_def)

lemma wp_Un_subset: "wp act A \<union> wp act B \<subseteq> wp act (A \<union> B)"
by (force simp add: wp_def)

lemma wp_Un_eq: "single_valued act ==> wp act (A \<union> B) = wp act A \<union> wp act B"
apply (rule equalityI)
 apply (force simp add: wp_def single_valued_def)
apply (rule wp_Un_subset)
done

lemma wp_UN_subset: "(\<Union>i\<in>I. wp act (A i)) \<subseteq> wp act (\<Union>i\<in>I. A i)"
by (force simp add: wp_def)

lemma wp_UN_eq:
     "[|single_valued act; I\<noteq>{}|]
      ==> wp act (\<Union>i\<in>I. A i) = (\<Union>i\<in>I. wp act (A i))"
apply (rule equalityI)
 prefer 2 apply (rule wp_UN_subset)
 apply (simp add: wp_def Image_INT_eq)
done

lemma wens_single_eq:
     "wens (mk_program (init, {act}, allowed)) act B = B \<union> wp act B"
by (simp add: wens_def gfp_def wp_def, blast)

text{*Next, we express the @{term "wens_set"} for single-assignment programs*}

definition wens_single_finite :: "[('a*'a) set, 'a set, nat] => 'a set" where
    "wens_single_finite act B k == \<Union>i \<in> atMost k. (wp act ^^ i) B"

definition wens_single :: "[('a*'a) set, 'a set] => 'a set" where
    "wens_single act B == \<Union>i. (wp act ^^ i) B"

lemma wens_single_Un_eq:
      "single_valued act
       ==> wens_single act B \<union> wp act (wens_single act B) = wens_single act B"
apply (rule equalityI)
 apply (simp_all add: Un_upper1)
apply (simp add: wens_single_def wp_UN_eq, clarify)
apply (rule_tac a="Suc xa" in UN_I, auto)
done

lemma atMost_nat_nonempty: "atMost (k::nat) \<noteq> {}"
by force

lemma wens_single_finite_0 [simp]: "wens_single_finite act B 0 = B"
by (simp add: wens_single_finite_def)

lemma wens_single_finite_Suc:
      "single_valued act
       ==> wens_single_finite act B (Suc k) =
           wens_single_finite act B k \<union> wp act (wens_single_finite act B k)"
apply (simp add: wens_single_finite_def image_def
                 wp_UN_eq [OF _ atMost_nat_nonempty])
apply (force elim!: le_SucE)
done

lemma wens_single_finite_Suc_eq_wens:
     "single_valued act
       ==> wens_single_finite act B (Suc k) =
           wens (mk_program (init, {act}, allowed)) act
                (wens_single_finite act B k)"
by (simp add: wens_single_finite_Suc wens_single_eq)

lemma def_wens_single_finite_Suc_eq_wens:
     "[|F = mk_program (init, {act}, allowed); single_valued act|]
       ==> wens_single_finite act B (Suc k) =
           wens F act (wens_single_finite act B k)"
by (simp add: wens_single_finite_Suc_eq_wens)

lemma wens_single_finite_Un_eq:
      "single_valued act
       ==> wens_single_finite act B k \<union> wp act (wens_single_finite act B k)
           \<in> range (wens_single_finite act B)"
by (simp add: wens_single_finite_Suc [symmetric])

lemma wens_single_eq_Union:
      "wens_single act B = \<Union>range (wens_single_finite act B)"
by (simp add: wens_single_finite_def wens_single_def, blast)

lemma wens_single_finite_eq_Union:
     "wens_single_finite act B n = (\<Union>k\<in>atMost n. wens_single_finite act B k)"
apply (auto simp add: wens_single_finite_def)
apply (blast intro: le_trans)
done

lemma wens_single_finite_mono:
     "m \<le> n ==> wens_single_finite act B m \<subseteq> wens_single_finite act B n"
by (force simp add:  wens_single_finite_eq_Union [of act B n])

lemma wens_single_finite_subset_wens_single:
      "wens_single_finite act B k \<subseteq> wens_single act B"
by (simp add: wens_single_eq_Union, blast)

lemma subset_wens_single_finite:
      "[|W \<subseteq> wens_single_finite act B ` (atMost k); single_valued act; W\<noteq>{}|]
       ==> \<exists>m. \<Union>W = wens_single_finite act B m"
apply (induct k)
 apply (rule_tac x=0 in exI, simp, blast)
apply (auto simp add: atMost_Suc)
apply (case_tac "wens_single_finite act B (Suc k) \<in> W")
 prefer 2 apply blast
apply (drule_tac x="Suc k" in spec)
apply (erule notE, rule equalityI)
 prefer 2 apply blast
apply (subst wens_single_finite_eq_Union)
apply (simp add: atMost_Suc, blast)
done

text{*lemma for Union case*}
lemma Union_eq_wens_single:
      "\<lbrakk>\<forall>k. \<not> W \<subseteq> wens_single_finite act B ` {..k};
        W \<subseteq> insert (wens_single act B)
            (range (wens_single_finite act B))\<rbrakk>
       \<Longrightarrow> \<Union>W = wens_single act B"
apply (cases "wens_single act B \<in> W")
 apply (blast dest: wens_single_finite_subset_wens_single [THEN subsetD])
apply (simp add: wens_single_eq_Union)
apply (rule equalityI, blast)
apply (simp add: UN_subset_iff, clarify)
apply (subgoal_tac "\<exists>y\<in>W. \<exists>n. y = wens_single_finite act B n & i\<le>n")
 apply (blast intro: wens_single_finite_mono [THEN subsetD])
apply (drule_tac x=i in spec)
apply (force simp add: atMost_def)
done

lemma wens_set_subset_single:
      "single_valued act
       ==> wens_set (mk_program (init, {act}, allowed)) B \<subseteq>
           insert (wens_single act B) (range (wens_single_finite act B))"
apply (rule subsetI)
apply (erule wens_set.induct)
  txt{*Basis*}
  apply (fastforce simp add: wens_single_finite_def)
 txt{*Wens inductive step*}
 apply (case_tac "acta = Id", simp)
 apply (simp add: wens_single_eq)
 apply (elim disjE)
 apply (simp add: wens_single_Un_eq)
 apply (force simp add: wens_single_finite_Un_eq)
txt{*Union inductive step*}
apply (case_tac "\<exists>k. W \<subseteq> wens_single_finite act B ` (atMost k)")
 apply (blast dest!: subset_wens_single_finite, simp)
apply (rule disjI1 [OF Union_eq_wens_single], blast+)
done

lemma wens_single_finite_in_wens_set:
      "single_valued act \<Longrightarrow>
         wens_single_finite act B k
         \<in> wens_set (mk_program (init, {act}, allowed)) B"
apply (induct_tac k)
 apply (simp add: wens_single_finite_def wens_set.Basis)
apply (simp add: wens_set.Wens
                 wens_single_finite_Suc_eq_wens [of act B _ init allowed])
done

lemma single_subset_wens_set:
      "single_valued act
       ==> insert (wens_single act B) (range (wens_single_finite act B)) \<subseteq>
           wens_set (mk_program (init, {act}, allowed)) B"
apply (simp add: SUP_def image_def wens_single_eq_Union)
apply (blast intro: wens_set.Union wens_single_finite_in_wens_set)
done

text{*Theorem (4.29)*}
theorem wens_set_single_eq:
     "[|F = mk_program (init, {act}, allowed); single_valued act|]
      ==> wens_set F B =
          insert (wens_single act B) (range (wens_single_finite act B))"
apply (rule equalityI)
 apply (simp add: wens_set_subset_single)
apply (erule ssubst, erule single_subset_wens_set)
done

text{*Generalizing Misra's Fixed Point Union Theorem (4.41)*}

lemma fp_leadsTo_Join:
    "[|T-B \<subseteq> awp F T; T-B \<subseteq> FP G; F \<in> A leadsTo B|] ==> F\<squnion>G \<in> T\<inter>A leadsTo B"
apply (rule leadsTo_Join, assumption, blast)
apply (simp add: FP_def awp_iff_constrains stable_def constrains_def, blast)
done

end


header {* Some preliminaries on equivalence relations and quotients *}

(* author: Andrei Popescu *)

theory Equiv_Relation2 imports Preliminaries
begin

(* Recall the following constants and lemmas:

term Eps
term "A//r"
lemmas equiv_def
lemmas refl_on_def
 -- note that "reflexivity on" also assumes inclusion of the relation's field into r

*)

definition proj :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
where "proj r x = r `` {x}"

abbreviation
  EpsSet where "EpsSet X \<equiv> Eps (% x. x \<in> X)"

definition univ :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a set \<Rightarrow> 'b)"
where "univ f X == f (EpsSet X)"

lemma proj_preserves:
"x \<in> A \<Longrightarrow> proj r x \<in> A//r"
unfolding proj_def by (rule quotientI)

lemma proj_in_iff:
assumes "equiv A r"
shows "(proj r x \<in> A//r) = (x \<in> A)"
apply(rule iffI)  apply(auto simp add: proj_preserves)
unfolding proj_def quotient_def proof auto
  fix y assume y: "y \<in> A" and "r `` {x} = r `` {y}"
  moreover have "y \<in> r `` {y}" using assms y unfolding equiv_def refl_on_def by auto
  ultimately have "(x,y) \<in> r" by auto
  thus "x \<in> A" using assms unfolding equiv_def refl_on_def by auto
qed

lemma proj_iff:
"\<lbrakk>equiv A r; {x,y} \<subseteq> A\<rbrakk> \<Longrightarrow> (proj r x = proj r y) = ((x,y) \<in> r)"
unfolding proj_def by (auto simp add: eq_equiv_class_iff)

lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
unfolding proj_def equiv_def refl_on_def by auto

lemma proj_image: "(proj r) ` A = A//r"
unfolding proj_def[abs_def] quotient_def by auto

lemma in_quotient_imp_non_empty:
assumes "equiv A r" and "X \<in> A//r"
shows "X \<noteq> {}"
proof-
  obtain x where "x \<in> A \<and> X = r `` {x}" using assms unfolding quotient_def by auto
  hence "x \<in> X" using assms equiv_class_self by fastforce
  thus ?thesis by auto
qed

lemma in_quotient_imp_in_rel:
"\<lbrakk>equiv A r; X \<in> A//r; {x,y} \<subseteq> X\<rbrakk> \<Longrightarrow> (x,y) \<in> r"
using assms quotient_eq_iff by fastforce

lemma in_quotient_imp_closed:
"\<lbrakk>equiv A r; X \<in> A//r; x \<in> X; (x,y) \<in> r\<rbrakk> \<Longrightarrow> y \<in> X"
unfolding quotient_def equiv_def trans_def by auto

lemma in_quotient_imp_subset:
"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<subseteq> A"
using assms in_quotient_imp_in_rel equiv_type by fastforce

lemma equiv_Eps_in:
assumes  ECH: "equiv A r" and X: "X \<in> A//r"
shows "EpsSet X \<in> X"
proof(rule "someI2_ex", auto)
  show "\<exists> x. x \<in> X" using assms in_quotient_imp_non_empty by fastforce
qed

lemma equiv_Eps_preserves:
assumes  ECH: "equiv A r" and X: "X \<in> A//r"
shows "EpsSet X \<in> A"
proof(rule "someI2_ex")
  show "\<exists> x. x \<in> X" using assms in_quotient_imp_non_empty by fastforce
next
  fix x assume "x \<in> X"
  moreover have "X \<subseteq> A" using assms in_quotient_imp_subset by fastforce
  ultimately show "x \<in> A" by auto
qed

lemma proj_Eps:
assumes "equiv A r" and "X \<in> A//r"
shows "proj r (EpsSet X) = X"
unfolding proj_def proof(auto)
  fix x assume x: "x \<in> X"
  thus "(Eps (% x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fastforce
next
  fix x assume "(EpsSet X,x) \<in> r"
  thus "x \<in> X" using assms equiv_Eps_in in_quotient_imp_closed by metis
qed

lemma Eps_proj:
assumes "equiv A r" and "x \<in> A"
shows "(EpsSet (proj r x), x) \<in> r"
proof-
  have 1: "proj r x \<in> A//r" using assms proj_preserves by fastforce
  hence "EpsSet (proj r x) \<in> proj r x" using assms equiv_Eps_in by auto
  moreover have "x \<in> proj r x" using assms in_proj by fastforce
  ultimately show ?thesis using assms 1 in_quotient_imp_in_rel by fastforce
qed

lemma equiv_Eps_iff:
assumes "equiv A r" and "{X,Y} \<subseteq> A//r"
shows "((EpsSet X, EpsSet Y) \<in> r) = (X = Y)"
proof-
  have "EpsSet X \<in> X \<and> EpsSet Y \<in> Y" using assms equiv_Eps_in by auto
  thus ?thesis using assms quotient_eq_iff by fastforce
qed

lemma equiv_Eps_inj_on:
assumes "equiv A r"
shows "inj_on EpsSet (A//r)"
unfolding inj_on_def proof clarify
  fix X Y assume X: "X \<in> A//r" and Y: "Y \<in> A//r" and Eps: "EpsSet X = EpsSet Y"
  hence "EpsSet X \<in> A" using assms equiv_Eps_preserves by auto
  hence "(EpsSet X, EpsSet Y) \<in> r"
  using assms Eps unfolding quotient_def equiv_def refl_on_def by auto
  thus "X= Y" using X Y assms equiv_Eps_iff by auto
qed

lemma univ_commute[simp]:
assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
shows "(univ f) (proj r x) = f x"
unfolding univ_def proof-
  have prj: "proj r x \<in> A//r" using x proj_preserves by fastforce
  hence "EpsSet (proj r x) \<in> A" using ECH equiv_Eps_preserves by fastforce
  moreover have "proj r (EpsSet (proj r x)) = proj r x" using ECH prj proj_Eps by fastforce
  ultimately have "(x, EpsSet (proj r x)) \<in> r" using x ECH proj_iff by fastforce
  thus "f (EpsSet (proj r x)) = f x" using RES unfolding congruent_def by auto
qed

lemma univ_unique:
assumes ECH: "equiv A r" and
        RES: "f respects r" and  COM: "\<forall> x \<in> A. G (proj r x) = f x"
shows "\<forall> X \<in> A//r. G X = univ f X"
proof
  fix X assume "X \<in> A//r"
  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
  have "G X = f x" unfolding X using x COM by simp
  thus "G X = univ f X" unfolding X using ECH RES x univ_commute by fastforce
qed

lemma univ_preserves:
assumes ECH: "equiv A r" and RES: "f respects r" and
       PRES: "\<forall> x \<in> A. f x \<in> B"
shows "\<forall> X \<in> A//r. univ f X \<in> B"
proof
  fix X assume "X \<in> A//r"
  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
  hence "univ f X = f x" using assms univ_commute by fastforce
  thus "univ f X \<in> B" using x PRES by auto
qed

end


theory quantifiers_example
  imports quantifiers "../conditions/conditions_kuratowski_infinitary"
begin

subsection \<open>Examples on using quantifiers (restricted and unrestricted)\<close>

(**First-order quantification example*)
lemma "(\<forall>x. A x \<longrightarrow> (\<exists>y. B x y)) \<longleftrightarrow> (\<forall>x. \<exists>y. A x \<longrightarrow> B x y)" by simp
lemma "(\<^bold>\<forall>x. A x  \<^bold>\<rightarrow> (\<^bold>\<exists>y. B x y))  \<approx> (\<^bold>\<forall>x. \<^bold>\<exists>y. A x  \<^bold>\<rightarrow>  B x y)" by (simp add: impl_def mexists_def setequ_def)

(**Propositional quantification example*)
lemma "\<forall>A. (\<exists>B. (A \<longleftrightarrow> \<not>B))" by blast
lemma "(\<^bold>\<forall>A. (\<^bold>\<exists>B. A  \<^bold>\<leftrightarrow> \<^bold>\<midarrow>B)) \<approx> \<^bold>\<top>" unfolding mforall_def mexists_def by (smt (verit) compl_def dimpl_def setequ_def top_def)

(*Drinker's principle*)
lemma "\<^bold>\<exists>x. Drunk x \<^bold>\<rightarrow> (\<^bold>\<forall>y. Drunk y) \<approx> \<^bold>\<top>"
  by (simp add: impl_def mexists_def mforall_def setequ_def top_def)

(**Example in non-classical logics*)
typedecl w
type_synonym \<sigma> = "(w \<sigma>)"

consts \<C>::"\<sigma> \<Rightarrow> \<sigma>"
abbreviation "\<I> \<equiv> \<C>\<^sup>d"
abbreviation "CLOSURE \<phi> \<equiv> ADDI \<phi> \<and> EXPN \<phi> \<and> NORM \<phi> \<and> IDEM \<phi>"
abbreviation "INTERIOR \<phi> \<equiv> MULT \<phi> \<and> CNTR \<phi> \<and> DNRM \<phi> \<and> IDEM \<phi>"

definition mforallInt::"(\<sigma> \<Rightarrow> \<sigma>) \<Rightarrow> \<sigma>" ("\<^bold>\<Pi>\<^sup>I_")
  where "\<^bold>\<Pi>\<^sup>I\<phi> \<equiv> \<^bold>\<Pi>[fp \<I>]\<phi>"
definition mexistsInt::"(\<sigma> \<Rightarrow> \<sigma>) \<Rightarrow> \<sigma>" ("\<^bold>\<Sigma>\<^sup>I_")
  where "\<^bold>\<Sigma>\<^sup>I\<phi> \<equiv> \<^bold>\<Sigma>[fp \<I>]\<phi>"

(**To improve readability, we introduce for them standard binder notation.*)
notation mforallInt (binder "\<^bold>\<forall>\<^sup>I" [48]49)
notation mexistsInt (binder "\<^bold>\<exists>\<^sup>I" [48]49)

abbreviation intneg ("\<^bold>\<not>\<^sup>I_") where "\<^bold>\<not>\<^sup>IA \<equiv> \<I>\<^sup>- A"
abbreviation parneg ("\<^bold>\<not>\<^sup>C_") where "\<^bold>\<not>\<^sup>CA \<equiv> \<C>\<^sup>- A"
abbreviation turnstile ("\<turnstile>_") where "\<turnstile> A \<equiv> \<forall>w. A w"

lemma "(\<^bold>\<forall>X. (\<^bold>\<exists>B. (X  \<^bold>\<leftrightarrow> \<^bold>\<midarrow>B))) \<approx> \<^bold>\<top>" by (smt (verit, del_insts) compl_def dimpl_def mexists_def mforall_def setequ_def top_def)
lemma "(\<^bold>\<forall>\<^sup>IX. (\<^bold>\<exists>\<^sup>IB. (X  \<^bold>\<leftrightarrow> \<^bold>\<not>\<^sup>IB))) \<approx> \<^bold>\<top>" nitpick oops

subsection \<open>Exploring the Barcan formula and its converse\<close>

(**The converse Barcan formula follows readily from monotonicity.*)
lemma CBarcan1: "MONO \<phi> \<Longrightarrow> \<forall>\<pi>.  \<phi>(\<^bold>\<forall>x. \<pi> x)  \<preceq> (\<^bold>\<forall>x. \<phi>(\<pi> x))" by (smt (verit, ccfv_SIG) MONO_def mforall_def subset_def)
lemma CBarcan2: "MONO \<phi> \<Longrightarrow> \<forall>\<pi>. (\<^bold>\<exists>x. \<phi>(\<pi> x)) \<preceq> \<phi>(\<^bold>\<exists>x. \<pi> x)" by (smt (verit) MONO_def mexists_def subset_def)

(**However, the Barcan formula requires a stronger assumption (of an infinitary character).*)
lemma Barcan1: "iMULT\<^sup>b \<phi> \<Longrightarrow> \<forall>\<pi>. (\<^bold>\<forall>x. \<phi>(\<pi> x)) \<preceq> \<phi>(\<^bold>\<forall>x. \<pi> x)" unfolding iMULT_b_def by (smt (verit) infimum_def mforall_char image_def range_char1 subset_def)
(*proof  assume imultb: "iMULT_b \<phi>"
  { fix \<pi>::"'a\<Rightarrow>\<sigma>"
    from imultb have "(\<^bold>\<And>Ra(\<phi>\<circ>\<pi>)) \<^bold>\<preceq> \<phi>(\<^bold>\<And>Ra(\<pi>))" unfolding iMULT_b_def by (smt comp_apply infimum_def pfunRange_def pfunRange_restr_def)
    moreover have "\<^bold>\<And>Ra(\<pi>) = (\<^bold>\<forall>x. \<pi> x)" unfolding Ra_all by simp
    moreover have "\<^bold>\<And>Ra(\<phi>\<circ>\<pi>) = (\<^bold>\<forall>x. \<phi>(\<pi> x))" unfolding Ra_all by simp
    ultimately have "(\<^bold>\<forall>x. \<phi>(\<pi> x)) \<^bold>\<preceq> \<phi>(\<^bold>\<forall>x. \<pi> x)" by simp
  } thus ?thesis by simp
qed*)
lemma Barcan2: "iADDI\<^sup>a \<phi> \<Longrightarrow> \<forall>\<pi>. \<phi>(\<^bold>\<exists>x. \<pi> x) \<preceq> (\<^bold>\<exists>x. \<phi>(\<pi> x))" unfolding iADDI_a_def by (smt (verit, ccfv_threshold) mexists_char image_def range_char1 subset_def supremum_def)
(*proof -
  assume iaddia: "iADDI_a \<phi>"
  { fix \<pi>::"'a\<Rightarrow>\<sigma>"
    from iaddia have "\<phi>(\<^bold>\<Or>Ra(\<pi>)) \<^bold>\<preceq> (\<^bold>\<Or>Ra(\<phi>\<circ>\<pi>))" unfolding iADDI_a_def Ra_restr_ex by (smt fcomp_comp fcomp_def pfunRange_def sup_char)
    moreover have "\<^bold>\<Or>Ra(\<pi>) = (\<^bold>\<exists>x. \<pi> x)" unfolding Ra_ex by simp
    moreover have "\<^bold>\<Or>Ra(\<phi>\<circ>\<pi>) = (\<^bold>\<exists>x. \<phi>(\<pi> x))" unfolding Ra_ex by simp
    ultimately have "\<phi>(\<^bold>\<exists>x. \<pi> x) \<^bold>\<preceq> (\<^bold>\<exists>x. \<phi>(\<pi> x))" by simp
  } thus ?thesis by simp
qed
*)

(*CBF*)
lemma "MONO \<phi> \<Longrightarrow> \<forall>\<pi>.  \<phi>(\<^bold>\<Pi> \<pi>) \<preceq> \<^bold>\<Pi>(\<phi> \<circ> \<pi>)" by (metis MONO_iMULTa iMULT_a_def mforall_char mforall_comp mforall_const_char)
lemma "MONO \<phi> \<Longrightarrow> \<forall>\<pi>.  \<phi>(\<^bold>\<Pi>[D] \<pi>) \<preceq> \<^bold>\<Pi>[D](\<phi> \<circ> \<pi>)"  by (smt (verit) MONO_iMULTa fun_comp_def iMULT_a_def mforall_const_char mforall_const_def image_def subset_def)
lemma "CNTR \<phi> \<Longrightarrow> iMULT \<phi> \<Longrightarrow> IDEM \<phi> \<Longrightarrow>  \<forall>\<pi>.  \<phi>(\<^bold>\<Pi>{\<psi>} \<pi>) \<preceq> \<^bold>\<Pi>{\<psi>}(\<phi> \<circ> \<pi>)" nitpick oops

(*BF*)
lemma "iMULT\<^sup>b \<phi> \<Longrightarrow> \<forall>\<pi>. \<^bold>\<Pi>(\<phi> \<circ> \<pi>) \<preceq> \<phi>(\<^bold>\<Pi> \<pi>)" by (metis iMULT_b_def mforall_char mforall_comp mforall_const_char)
lemma "iMULT\<^sup>b \<phi> \<Longrightarrow> \<forall>\<pi>. \<^bold>\<Pi>[D](\<phi> \<circ> \<pi>) \<preceq> \<phi>(\<^bold>\<Pi>[D] \<pi>)" by (smt (verit) fun_comp_def iMULT_b_def infimum_def mforall_const_char image_def subset_def)
lemma "iADDI \<phi> \<Longrightarrow> iMULT \<phi> \<Longrightarrow> \<forall>\<pi>. \<^bold>\<Pi>{\<psi>}(\<phi> \<circ> \<pi>) \<preceq> \<phi>(\<^bold>\<Pi>{\<psi>} \<pi>)" nitpick oops

end


(*  Title:      HOL/Library/Log_Nat.thy
    Author:     Johannes Hölzl, Fabian Immler
    Copyright   2012  TU München
*)

section \<open>Logarithm of Natural Numbers\<close>

theory Log_Nat
imports Complex_Main
begin

definition floorlog :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"floorlog b a = (if a > 0 \<and> b > 1 then nat \<lfloor>log b a\<rfloor> + 1 else 0)"

lemma floorlog_mono: "x \<le> y \<Longrightarrow> floorlog b x \<le> floorlog b y"
by(auto simp: floorlog_def floor_mono nat_mono)

lemma floorlog_bounds:
  assumes "x > 0" "b > 1"
  shows "b ^ (floorlog b x - 1) \<le> x \<and> x < b ^ (floorlog b x)"
proof
  show "b ^ (floorlog b x - 1) \<le> x"
  proof -
    have "b ^ nat \<lfloor>log b x\<rfloor> = b powr \<lfloor>log b x\<rfloor>"
      using powr_realpow[symmetric, of b "nat \<lfloor>log b x\<rfloor>"] \<open>x > 0\<close> \<open>b > 1\<close>
      by simp
    also have "\<dots> \<le> b powr log b x" using \<open>b > 1\<close> by simp
    also have "\<dots> = real_of_int x" using \<open>0 < x\<close> \<open>b > 1\<close> by simp
    finally have "b ^ nat \<lfloor>log b x\<rfloor> \<le> real_of_int x" by simp
    then show ?thesis
      using \<open>0 < x\<close> \<open>b > 1\<close> of_nat_le_iff
      by (fastforce simp add: floorlog_def)
  qed
  show "x < b ^ (floorlog b x)"
  proof -
    have "x \<le> b powr (log b x)" using \<open>x > 0\<close> \<open>b > 1\<close> by simp
    also have "\<dots> < b powr (\<lfloor>log b x\<rfloor> + 1)"
      using assms by (intro powr_less_mono) auto
    also have "\<dots> = b ^ nat (\<lfloor>log b (real_of_int x)\<rfloor> + 1)"
      using assms by (simp add: powr_realpow[symmetric])
    finally
    have "x < b ^ nat (\<lfloor>log b (int x)\<rfloor> + 1)"
      by (rule of_nat_less_imp_less)
    then show ?thesis
      using \<open>x > 0\<close> \<open>b > 1\<close> by (simp add: floorlog_def nat_add_distrib)
  qed
qed

lemma floorlog_power[simp]:
  assumes "a > 0" "b > 1"
  shows "floorlog b (a * b ^ c) = floorlog b a + c"
proof -
  have "\<lfloor>log b a + real c\<rfloor> = \<lfloor>log b a\<rfloor> + c" by arith
  then show ?thesis using assms
    by (auto simp: floorlog_def log_mult powr_realpow[symmetric] nat_add_distrib)
qed

lemma floor_log_add_eqI:
  fixes a::nat and b::nat and r::real
  assumes "b > 1" "a \<ge> 1" "0 \<le> r" "r < 1"
  shows "\<lfloor>log b (a + r)\<rfloor> = \<lfloor>log b a\<rfloor>"
proof (rule floor_eq2)
  have "log b a \<le> log b (a + r)" using assms by force
  then show "\<lfloor>log b a\<rfloor> \<le> log b (a + r)" by arith
next
  define l::int where "l = int b ^ (nat \<lfloor>log b a\<rfloor> + 1)"
  have l_def_real: "l = b powr (\<lfloor>log b a\<rfloor> + 1)"
    using assms by (simp add: l_def powr_add powr_real_of_int)
  have "a < l"
  proof -
    have "a = b powr (log b a)" using assms by simp
    also have "\<dots> < b powr floor ((log b a) + 1)"
      using assms(1) by auto
    also have "\<dots> = l"
      using assms by (simp add: l_def powr_real_of_int powr_add)
    finally show ?thesis by simp
  qed
  then have "a + r < l" using assms by simp
  then have "log b (a + r) < log b l" using assms by simp
  also have "\<dots> = real_of_int \<lfloor>log b a\<rfloor> + 1"
    using assms by (simp add: l_def_real)
  finally show "log b (a + r) < real_of_int \<lfloor>log b a\<rfloor> + 1" .
qed

lemma divide_nat_diff_div_nat_less_one:
  fixes x b::nat shows "x / b - x div b < 1"
proof -
  have "int 0 \<noteq> \<lfloor>1::real\<rfloor>" by simp
  thus ?thesis
    by (metis add_diff_cancel_left' floor_divide_of_nat_eq less_eq_real_def
        mod_div_trivial real_of_nat_div3 real_of_nat_div_aux)
qed

lemma floor_log_div:
  fixes b x :: nat assumes "b > 1" "x > 0" "x div b > 0"
  shows "\<lfloor>log b x\<rfloor> = \<lfloor>log b (x div b)\<rfloor> + 1"
proof-
  have "\<lfloor>log b x\<rfloor> = \<lfloor>log b (x / b * b)\<rfloor>" using assms by simp
  also have "\<dots> = \<lfloor>log b (x / b) + log b b\<rfloor>"
    using assms by (subst log_mult) auto
  also have "\<dots> = \<lfloor>log b (x / b)\<rfloor> + 1" using assms by simp
  also have "\<lfloor>log b (x / b)\<rfloor> = \<lfloor>log b (x div b + (x / b - x div b))\<rfloor>" by simp
  also have "\<dots> = \<lfloor>log b (x div b)\<rfloor>"
    using assms real_of_nat_div4 divide_nat_diff_div_nat_less_one
    by (intro floor_log_add_eqI) auto
  finally show ?thesis .
qed

lemma compute_floorlog[code]:
  "floorlog b x = (if x > 0 \<and> b > 1 then floorlog b (x div b) + 1 else 0)"
by (auto simp: floorlog_def floor_log_div[of b x] div_eq_0_iff nat_add_distrib
    intro!: floor_eq2)

lemma floor_log_eq_if:
  fixes b x y :: nat
  assumes "x div b = y div b" "b > 1" "x > 0" "x div b \<ge> 1"
  shows "floor(log b x) = floor(log b y)"
proof -
  have "y > 0" using assms by(auto intro: ccontr)
  thus ?thesis using assms by (simp add: floor_log_div)
qed

lemma floorlog_eq_if:
  fixes b x y :: nat
  assumes "x div b = y div b" "b > 1" "x > 0" "x div b \<ge> 1"
  shows "floorlog b x = floorlog b y"
proof -
  have "y > 0" using assms by(auto intro: ccontr)
  thus ?thesis using assms
    by(auto simp add: floorlog_def eq_nat_nat_iff intro: floor_log_eq_if)
qed

definition bitlen :: "int \<Rightarrow> int" where "bitlen a = floorlog 2 (nat a)"

lemma bitlen_alt_def: "bitlen a = (if a > 0 then \<lfloor>log 2 a\<rfloor> + 1 else 0)"
by (simp add: bitlen_def floorlog_def)

lemma bitlen_nonneg: "0 \<le> bitlen x"
by (simp add: bitlen_def)

lemma bitlen_bounds:
  assumes "x > 0"
  shows "2 ^ nat (bitlen x - 1) \<le> x \<and> x < 2 ^ nat (bitlen x)"
proof -
  from assms have "bitlen x \<ge> 1" by (auto simp: bitlen_alt_def)
  with assms floorlog_bounds[of "nat x" 2] show ?thesis
    by (auto simp add: bitlen_def le_nat_iff nat_less_iff nat_diff_distrib)
qed

lemma bitlen_pow2[simp]:
  assumes "b > 0"
  shows "bitlen (b * 2 ^ c) = bitlen b + c"
  using assms
  by (simp add: bitlen_def nat_mult_distrib nat_power_eq)

lemma compute_bitlen[code]:
  "bitlen x = (if x > 0 then bitlen (x div 2) + 1 else 0)"
by (simp add: bitlen_def nat_div_distrib compute_floorlog)

lemma bitlen_eq_zero_iff: "bitlen x = 0 \<longleftrightarrow> x \<le> 0"
by (auto simp add: bitlen_alt_def)
   (metis compute_bitlen add.commute bitlen_alt_def bitlen_nonneg less_add_same_cancel2
      not_less zero_less_one)

lemma bitlen_div:
  assumes "0 < m"
  shows "1 \<le> real_of_int m / 2^nat (bitlen m - 1)"
    and "real_of_int m / 2^nat (bitlen m - 1) < 2"
proof -
  let ?B = "2^nat (bitlen m - 1)"

  have "?B \<le> m" using bitlen_bounds[OF \<open>0 <m\<close>] ..
  then have "1 * ?B \<le> real_of_int m"
    unfolding of_int_le_iff[symmetric] by auto
  then show "1 \<le> real_of_int m / ?B" by auto

  from assms have "m \<noteq> 0" by auto
  from assms have "0 \<le> bitlen m - 1" by (auto simp: bitlen_alt_def)

  have "m < 2^nat(bitlen m)" using bitlen_bounds[OF assms] ..
  also from assms have "\<dots> = 2^nat(bitlen m - 1 + 1)"
    by (auto simp: bitlen_def)
  also have "\<dots> = ?B * 2"
    unfolding nat_add_distrib[OF \<open>0 \<le> bitlen m - 1\<close> zero_le_one] by auto
  finally have "real_of_int m < 2 * ?B"
    by (metis (full_types) mult.commute power.simps(2) real_of_int_less_numeral_power_cancel_iff)
  then have "real_of_int m / ?B < 2 * ?B / ?B"
    by (rule divide_strict_right_mono) auto
  then show "real_of_int m / ?B < 2" by auto
qed

end


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

section{*Transitive Sets and Ordinals*}

theory Ordinal imports WF Bool equalities begin

definition
  Memrel        :: "i=>i"  where
    "Memrel(A)   == {z\<in>A*A . \<exists>x y. z=<x,y> & x\<in>y }"

definition
  Transset  :: "i=>o"  where
    "Transset(i) == \<forall>x\<in>i. x<=i"

definition
  Ord  :: "i=>o"  where
    "Ord(i)      == Transset(i) & (\<forall>x\<in>i. Transset(x))"

definition
  lt        :: "[i,i] => o"  (infixl "<" 50)   (*less-than on ordinals*)  where
    "i<j         == i\<in>j & Ord(j)"

definition
  Limit         :: "i=>o"  where
    "Limit(i)    == Ord(i) & 0<i & (\<forall>y. y<i \<longrightarrow> succ(y)<i)"

abbreviation
  le  (infixl "le" 50) where
  "x le y == x < succ(y)"

notation (xsymbols)
  le  (infixl "\<le>" 50)

notation (HTML output)
  le  (infixl "\<le>" 50)

subsection{*Rules for Transset*}

subsubsection{*Three Neat Characterisations of Transset*}

lemma Transset_iff_Pow: "Transset(A) <-> A<=Pow(A)"
by (unfold Transset_def, blast)

lemma Transset_iff_Union_succ: "Transset(A) <-> \<Union>(succ(A)) = A"
apply (unfold Transset_def)
apply (blast elim!: equalityE)
done

lemma Transset_iff_Union_subset: "Transset(A) <-> \<Union>(A) \<subseteq> A"
by (unfold Transset_def, blast)

subsubsection{*Consequences of Downwards Closure*}

lemma Transset_doubleton_D:
    "[| Transset(C); {a,b}: C |] ==> a\<in>C & b\<in>C"
by (unfold Transset_def, blast)

lemma Transset_Pair_D:
    "[| Transset(C); <a,b>\<in>C |] ==> a\<in>C & b\<in>C"
apply (simp add: Pair_def)
apply (blast dest: Transset_doubleton_D)
done

lemma Transset_includes_domain:
    "[| Transset(C); A*B \<subseteq> C; b \<in> B |] ==> A \<subseteq> C"
by (blast dest: Transset_Pair_D)

lemma Transset_includes_range:
    "[| Transset(C); A*B \<subseteq> C; a \<in> A |] ==> B \<subseteq> C"
by (blast dest: Transset_Pair_D)

subsubsection{*Closure Properties*}

lemma Transset_0: "Transset(0)"
by (unfold Transset_def, blast)

lemma Transset_Un:
    "[| Transset(i);  Transset(j) |] ==> Transset(i \<union> j)"
by (unfold Transset_def, blast)

lemma Transset_Int:
    "[| Transset(i);  Transset(j) |] ==> Transset(i \<inter> j)"
by (unfold Transset_def, blast)

lemma Transset_succ: "Transset(i) ==> Transset(succ(i))"
by (unfold Transset_def, blast)

lemma Transset_Pow: "Transset(i) ==> Transset(Pow(i))"
by (unfold Transset_def, blast)

lemma Transset_Union: "Transset(A) ==> Transset(\<Union>(A))"
by (unfold Transset_def, blast)

lemma Transset_Union_family:
    "[| !!i. i\<in>A ==> Transset(i) |] ==> Transset(\<Union>(A))"
by (unfold Transset_def, blast)

lemma Transset_Inter_family:
    "[| !!i. i\<in>A ==> Transset(i) |] ==> Transset(\<Inter>(A))"
by (unfold Inter_def Transset_def, blast)

lemma Transset_UN:
     "(!!x. x \<in> A ==> Transset(B(x))) ==> Transset (\<Union>x\<in>A. B(x))"
by (rule Transset_Union_family, auto)

lemma Transset_INT:
     "(!!x. x \<in> A ==> Transset(B(x))) ==> Transset (\<Inter>x\<in>A. B(x))"
by (rule Transset_Inter_family, auto)

subsection{*Lemmas for Ordinals*}

lemma OrdI:
    "[| Transset(i);  !!x. x\<in>i ==> Transset(x) |]  ==>  Ord(i)"
by (simp add: Ord_def)

lemma Ord_is_Transset: "Ord(i) ==> Transset(i)"
by (simp add: Ord_def)

lemma Ord_contains_Transset:
    "[| Ord(i);  j\<in>i |] ==> Transset(j) "
by (unfold Ord_def, blast)

lemma Ord_in_Ord: "[| Ord(i);  j\<in>i |] ==> Ord(j)"
by (unfold Ord_def Transset_def, blast)

(*suitable for rewriting PROVIDED i has been fixed*)
lemma Ord_in_Ord': "[| j\<in>i; Ord(i) |] ==> Ord(j)"
by (blast intro: Ord_in_Ord)

(* Ord(succ(j)) ==> Ord(j) *)
lemmas Ord_succD = Ord_in_Ord [OF _ succI1]

lemma Ord_subset_Ord: "[| Ord(i);  Transset(j);  j<=i |] ==> Ord(j)"
by (simp add: Ord_def Transset_def, blast)

lemma OrdmemD: "[| j\<in>i;  Ord(i) |] ==> j<=i"
by (unfold Ord_def Transset_def, blast)

lemma Ord_trans: "[| i\<in>j;  j\<in>k;  Ord(k) |] ==> i\<in>k"
by (blast dest: OrdmemD)

lemma Ord_succ_subsetI: "[| i\<in>j;  Ord(j) |] ==> succ(i) \<subseteq> j"
by (blast dest: OrdmemD)

subsection{*The Construction of Ordinals: 0, succ, Union*}

lemma Ord_0 [iff,TC]: "Ord(0)"
by (blast intro: OrdI Transset_0)

lemma Ord_succ [TC]: "Ord(i) ==> Ord(succ(i))"
by (blast intro: OrdI Transset_succ Ord_is_Transset Ord_contains_Transset)

lemmas Ord_1 = Ord_0 [THEN Ord_succ]

lemma Ord_succ_iff [iff]: "Ord(succ(i)) <-> Ord(i)"
by (blast intro: Ord_succ dest!: Ord_succD)

lemma Ord_Un [intro,simp,TC]: "[| Ord(i); Ord(j) |] ==> Ord(i \<union> j)"
apply (unfold Ord_def)
apply (blast intro!: Transset_Un)
done

lemma Ord_Int [TC]: "[| Ord(i); Ord(j) |] ==> Ord(i \<inter> j)"
apply (unfold Ord_def)
apply (blast intro!: Transset_Int)
done

text{*There is no set of all ordinals, for then it would contain itself*}
lemma ON_class: "~ (\<forall>i. i\<in>X <-> Ord(i))"
proof (rule notI)
  assume X: "\<forall>i. i \<in> X \<longleftrightarrow> Ord(i)"
  have "\<forall>x y. x\<in>X \<longrightarrow> y\<in>x \<longrightarrow> y\<in>X"
    by (simp add: X, blast intro: Ord_in_Ord)
  hence "Transset(X)"
     by (auto simp add: Transset_def)
  moreover have "\<And>x. x \<in> X \<Longrightarrow> Transset(x)"
     by (simp add: X Ord_def)
  ultimately have "Ord(X)" by (rule OrdI)
  hence "X \<in> X" by (simp add: X)
  thus "False" by (rule mem_irrefl)
qed

subsection{*< is 'less Than' for Ordinals*}

lemma ltI: "[| i\<in>j;  Ord(j) |] ==> i<j"
by (unfold lt_def, blast)

lemma ltE:
    "[| i<j;  [| i\<in>j;  Ord(i);  Ord(j) |] ==> P |] ==> P"
apply (unfold lt_def)
apply (blast intro: Ord_in_Ord)
done

lemma ltD: "i<j ==> i\<in>j"
by (erule ltE, assumption)

lemma not_lt0 [simp]: "~ i<0"
by (unfold lt_def, blast)

lemma lt_Ord: "j<i ==> Ord(j)"
by (erule ltE, assumption)

lemma lt_Ord2: "j<i ==> Ord(i)"
by (erule ltE, assumption)

(* @{term"ja \<le> j ==> Ord(j)"} *)
lemmas le_Ord2 = lt_Ord2 [THEN Ord_succD]

(* i<0 ==> R *)
lemmas lt0E = not_lt0 [THEN notE, elim!]

lemma lt_trans [trans]: "[| i<j;  j<k |] ==> i<k"
by (blast intro!: ltI elim!: ltE intro: Ord_trans)

lemma lt_not_sym: "i<j ==> ~ (j<i)"
apply (unfold lt_def)
apply (blast elim: mem_asym)
done

(* [| i<j;  ~P ==> j<i |] ==> P *)
lemmas lt_asym = lt_not_sym [THEN swap]

lemma lt_irrefl [elim!]: "i<i ==> P"
by (blast intro: lt_asym)

lemma lt_not_refl: "~ i<i"
apply (rule notI)
apply (erule lt_irrefl)
done

text{* Recall that  @{term"i \<le> j"}  abbreviates  @{term"i<succ(j)"} !! *}

lemma le_iff: "i \<le> j <-> i<j | (i=j & Ord(j))"
by (unfold lt_def, blast)

(*Equivalently, i<j ==> i < succ(j)*)
lemma leI: "i<j ==> i \<le> j"
by (simp add: le_iff)

lemma le_eqI: "[| i=j;  Ord(j) |] ==> i \<le> j"
by (simp add: le_iff)

lemmas le_refl = refl [THEN le_eqI]

lemma le_refl_iff [iff]: "i \<le> i <-> Ord(i)"
by (simp (no_asm_simp) add: lt_not_refl le_iff)

lemma leCI: "(~ (i=j & Ord(j)) ==> i<j) ==> i \<le> j"
by (simp add: le_iff, blast)

lemma leE:
    "[| i \<le> j;  i<j ==> P;  [| i=j;  Ord(j) |] ==> P |] ==> P"
by (simp add: le_iff, blast)

lemma le_anti_sym: "[| i \<le> j;  j \<le> i |] ==> i=j"
apply (simp add: le_iff)
apply (blast elim: lt_asym)
done

lemma le0_iff [simp]: "i \<le> 0 <-> i=0"
by (blast elim!: leE)

lemmas le0D = le0_iff [THEN iffD1, dest!]

subsection{*Natural Deduction Rules for Memrel*}

(*The lemmas MemrelI/E give better speed than [iff] here*)
lemma Memrel_iff [simp]: "<a,b> \<in> Memrel(A) <-> a\<in>b & a\<in>A & b\<in>A"
by (unfold Memrel_def, blast)

lemma MemrelI [intro!]: "[| a \<in> b;  a \<in> A;  b \<in> A |] ==> <a,b> \<in> Memrel(A)"
by auto

lemma MemrelE [elim!]:
    "[| <a,b> \<in> Memrel(A);
        [| a \<in> A;  b \<in> A;  a\<in>b |]  ==> P |]
     ==> P"
by auto

lemma Memrel_type: "Memrel(A) \<subseteq> A*A"
by (unfold Memrel_def, blast)

lemma Memrel_mono: "A<=B ==> Memrel(A) \<subseteq> Memrel(B)"
by (unfold Memrel_def, blast)

lemma Memrel_0 [simp]: "Memrel(0) = 0"
by (unfold Memrel_def, blast)

lemma Memrel_1 [simp]: "Memrel(1) = 0"
by (unfold Memrel_def, blast)

lemma relation_Memrel: "relation(Memrel(A))"
by (simp add: relation_def Memrel_def)

(*The membership relation (as a set) is well-founded.
  Proof idea: show A<=B by applying the foundation axiom to A-B *)
lemma wf_Memrel: "wf(Memrel(A))"
apply (unfold wf_def)
apply (rule foundation [THEN disjE, THEN allI], erule disjI1, blast)
done

text{*The premise @{term "Ord(i)"} does not suffice.*}
lemma trans_Memrel:
    "Ord(i) ==> trans(Memrel(i))"
by (unfold Ord_def Transset_def trans_def, blast)

text{*However, the following premise is strong enough.*}
lemma Transset_trans_Memrel:
    "\<forall>j\<in>i. Transset(j) ==> trans(Memrel(i))"
by (unfold Transset_def trans_def, blast)

(*If Transset(A) then Memrel(A) internalizes the membership relation below A*)
lemma Transset_Memrel_iff:
    "Transset(A) ==> <a,b> \<in> Memrel(A) <-> a\<in>b & b\<in>A"
by (unfold Transset_def, blast)

subsection{*Transfinite Induction*}

(*Epsilon induction over a transitive set*)
lemma Transset_induct:
    "[| i \<in> k;  Transset(k);
        !!x.[| x \<in> k;  \<forall>y\<in>x. P(y) |] ==> P(x) |]
     ==>  P(i)"
apply (simp add: Transset_def)
apply (erule wf_Memrel [THEN wf_induct2], blast+)
done

(*Induction over an ordinal*)
lemmas Ord_induct [consumes 2] = Transset_induct [rule_format, OF _ Ord_is_Transset]

(*Induction over the class of ordinals -- a useful corollary of Ord_induct*)

lemma trans_induct [rule_format, consumes 1, case_names step]:
    "[| Ord(i);
        !!x.[| Ord(x);  \<forall>y\<in>x. P(y) |] ==> P(x) |]
     ==>  P(i)"
apply (rule Ord_succ [THEN succI1 [THEN Ord_induct]], assumption)
apply (blast intro: Ord_succ [THEN Ord_in_Ord])
done

section{*Fundamental properties of the epsilon ordering (< on ordinals)*}

subsubsection{*Proving That < is a Linear Ordering on the Ordinals*}

lemma Ord_linear:
     "Ord(i) \<Longrightarrow> Ord(j) \<Longrightarrow> i\<in>j | i=j | j\<in>i"
proof (induct i arbitrary: j rule: trans_induct)
  case (step i)
  note step_i = step
  show ?case using `Ord(j)`
    proof (induct j rule: trans_induct)
      case (step j)
      thus ?case using step_i
        by (blast dest: Ord_trans)
    qed
qed

text{*The trichotomy law for ordinals*}
lemma Ord_linear_lt:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (lt) "i<j" | (eq) "i=j" | (gt) "j<i"
apply (simp add: lt_def)
apply (rule_tac i1=i and j1=j in Ord_linear [THEN disjE])
apply (blast intro: o)+
done

lemma Ord_linear2:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (lt) "i<j" | (ge) "j \<le> i"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: leI le_eqI sym o) +
done

lemma Ord_linear_le:
 assumes o: "Ord(i)" "Ord(j)"
 obtains (le) "i \<le> j" | (ge) "j \<le> i"
apply (rule_tac i = i and j = j in Ord_linear_lt)
apply (blast intro: leI le_eqI o) +
done

lemma le_imp_not_lt: "j \<le> i ==> ~ i<j"
by (blast elim!: leE elim: lt_asym)

lemma not_lt_imp_le: "[| ~ i<j;  Ord(i);  Ord(j) |] ==> j \<le> i"
by (rule_tac i = i and j = j in Ord_linear2, auto)

subsubsection{*Some Rewrite Rules for <, le*}

lemma Ord_mem_iff_lt: "Ord(j) ==> i\<in>j <-> i<j"
by (unfold lt_def, blast)

lemma not_lt_iff_le: "[| Ord(i);  Ord(j) |] ==> ~ i<j <-> j \<le> i"
by (blast dest: le_imp_not_lt not_lt_imp_le)

lemma not_le_iff_lt: "[| Ord(i);  Ord(j) |] ==> ~ i \<le> j <-> j<i"
by (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])

(*This is identical to 0<succ(i) *)
lemma Ord_0_le: "Ord(i) ==> 0 \<le> i"
by (erule not_lt_iff_le [THEN iffD1], auto)

lemma Ord_0_lt: "[| Ord(i);  i\<noteq>0 |] ==> 0<i"
apply (erule not_le_iff_lt [THEN iffD1])
apply (rule Ord_0, blast)
done

lemma Ord_0_lt_iff: "Ord(i) ==> i\<noteq>0 <-> 0<i"
by (blast intro: Ord_0_lt)

subsection{*Results about Less-Than or Equals*}

(** For ordinals, @{term"j\<subseteq>i"} implies @{term"j \<le> i"} (less-than or equals) **)

lemma zero_le_succ_iff [iff]: "0 \<le> succ(x) <-> Ord(x)"
by (blast intro: Ord_0_le elim: ltE)

lemma subset_imp_le: "[| j<=i;  Ord(i);  Ord(j) |] ==> j \<le> i"
apply (rule not_lt_iff_le [THEN iffD1], assumption+)
apply (blast elim: ltE mem_irrefl)
done

lemma le_imp_subset: "i \<le> j ==> i<=j"
by (blast dest: OrdmemD elim: ltE leE)

lemma le_subset_iff: "j \<le> i <-> j<=i & Ord(i) & Ord(j)"
by (blast dest: subset_imp_le le_imp_subset elim: ltE)

lemma le_succ_iff: "i \<le> succ(j) <-> i \<le> j | i=succ(j) & Ord(i)"
apply (simp (no_asm) add: le_iff)
apply blast
done

(*Just a variant of subset_imp_le*)
lemma all_lt_imp_le: "[| Ord(i);  Ord(j);  !!x. x<j ==> x<i |] ==> j \<le> i"
by (blast intro: not_lt_imp_le dest: lt_irrefl)

subsubsection{*Transitivity Laws*}

lemma lt_trans1: "[| i \<le> j;  j<k |] ==> i<k"
by (blast elim!: leE intro: lt_trans)

lemma lt_trans2: "[| i<j;  j \<le> k |] ==> i<k"
by (blast elim!: leE intro: lt_trans)

lemma le_trans: "[| i \<le> j;  j \<le> k |] ==> i \<le> k"
by (blast intro: lt_trans1)

lemma succ_leI: "i<j ==> succ(i) \<le> j"
apply (rule not_lt_iff_le [THEN iffD1])
apply (blast elim: ltE leE lt_asym)+
done

(*Identical to  succ(i) < succ(j) ==> i<j  *)
lemma succ_leE: "succ(i) \<le> j ==> i<j"
apply (rule not_le_iff_lt [THEN iffD1])
apply (blast elim: ltE leE lt_asym)+
done

lemma succ_le_iff [iff]: "succ(i) \<le> j <-> i<j"
by (blast intro: succ_leI succ_leE)

lemma succ_le_imp_le: "succ(i) \<le> succ(j) ==> i \<le> j"
by (blast dest!: succ_leE)

lemma lt_subset_trans: "[| i \<subseteq> j;  j<k;  Ord(i) |] ==> i<k"
apply (rule subset_imp_le [THEN lt_trans1])
apply (blast intro: elim: ltE) +
done

lemma lt_imp_0_lt: "j<i ==> 0<i"
by (blast intro: lt_trans1 Ord_0_le [OF lt_Ord])

lemma succ_lt_iff: "succ(i) < j <-> i<j & succ(i) \<noteq> j"
apply auto
apply (blast intro: lt_trans le_refl dest: lt_Ord)
apply (frule lt_Ord)
apply (rule not_le_iff_lt [THEN iffD1])
  apply (blast intro: lt_Ord2)
 apply blast
apply (simp add: lt_Ord lt_Ord2 le_iff)
apply (blast dest: lt_asym)
done

lemma Ord_succ_mem_iff: "Ord(j) ==> succ(i) \<in> succ(j) <-> i\<in>j"
apply (insert succ_le_iff [of i j])
apply (simp add: lt_def)
done

subsubsection{*Union and Intersection*}

lemma Un_upper1_le: "[| Ord(i); Ord(j) |] ==> i \<le> i \<union> j"
by (rule Un_upper1 [THEN subset_imp_le], auto)

lemma Un_upper2_le: "[| Ord(i); Ord(j) |] ==> j \<le> i \<union> j"
by (rule Un_upper2 [THEN subset_imp_le], auto)

(*Replacing k by succ(k') yields the similar rule for le!*)
lemma Un_least_lt: "[| i<k;  j<k |] ==> i \<union> j < k"
apply (rule_tac i = i and j = j in Ord_linear_le)
apply (auto simp add: Un_commute le_subset_iff subset_Un_iff lt_Ord)
done

lemma Un_least_lt_iff: "[| Ord(i); Ord(j) |] ==> i \<union> j < k  <->  i<k & j<k"
apply (safe intro!: Un_least_lt)
apply (rule_tac [2] Un_upper2_le [THEN lt_trans1])
apply (rule Un_upper1_le [THEN lt_trans1], auto)
done

lemma Un_least_mem_iff:
    "[| Ord(i); Ord(j); Ord(k) |] ==> i \<union> j \<in> k  <->  i\<in>k & j\<in>k"
apply (insert Un_least_lt_iff [of i j k])
apply (simp add: lt_def)
done

(*Replacing k by succ(k') yields the similar rule for le!*)
lemma Int_greatest_lt: "[| i<k;  j<k |] ==> i \<inter> j < k"
apply (rule_tac i = i and j = j in Ord_linear_le)
apply (auto simp add: Int_commute le_subset_iff subset_Int_iff lt_Ord)
done

lemma Ord_Un_if:
     "[| Ord(i); Ord(j) |] ==> i \<union> j = (if j<i then i else j)"
by (simp add: not_lt_iff_le le_imp_subset leI
              subset_Un_iff [symmetric]  subset_Un_iff2 [symmetric])

lemma succ_Un_distrib:
     "[| Ord(i); Ord(j) |] ==> succ(i \<union> j) = succ(i) \<union> succ(j)"
by (simp add: Ord_Un_if lt_Ord le_Ord2)

lemma lt_Un_iff:
     "[| Ord(i); Ord(j) |] ==> k < i \<union> j <-> k < i | k < j"
apply (simp add: Ord_Un_if not_lt_iff_le)
apply (blast intro: leI lt_trans2)+
done

lemma le_Un_iff:
     "[| Ord(i); Ord(j) |] ==> k \<le> i \<union> j <-> k \<le> i | k \<le> j"
by (simp add: succ_Un_distrib lt_Un_iff [symmetric])

lemma Un_upper1_lt: "[|k < i; Ord(j)|] ==> k < i \<union> j"
by (simp add: lt_Un_iff lt_Ord2)

lemma Un_upper2_lt: "[|k < j; Ord(i)|] ==> k < i \<union> j"
by (simp add: lt_Un_iff lt_Ord2)

(*See also Transset_iff_Union_succ*)
lemma Ord_Union_succ_eq: "Ord(i) ==> \<Union>(succ(i)) = i"
by (blast intro: Ord_trans)

subsection{*Results about Limits*}

lemma Ord_Union [intro,simp,TC]: "[| !!i. i\<in>A ==> Ord(i) |] ==> Ord(\<Union>(A))"
apply (rule Ord_is_Transset [THEN Transset_Union_family, THEN OrdI])
apply (blast intro: Ord_contains_Transset)+
done

lemma Ord_UN [intro,simp,TC]:
     "[| !!x. x\<in>A ==> Ord(B(x)) |] ==> Ord(\<Union>x\<in>A. B(x))"
by (rule Ord_Union, blast)

lemma Ord_Inter [intro,simp,TC]:
    "[| !!i. i\<in>A ==> Ord(i) |] ==> Ord(\<Inter>(A))"
apply (rule Transset_Inter_family [THEN OrdI])
apply (blast intro: Ord_is_Transset)
apply (simp add: Inter_def)
apply (blast intro: Ord_contains_Transset)
done

lemma Ord_INT [intro,simp,TC]:
    "[| !!x. x\<in>A ==> Ord(B(x)) |] ==> Ord(\<Inter>x\<in>A. B(x))"
by (rule Ord_Inter, blast)

(* No < version of this theorem: consider that @{term"(\<Union>i\<in>nat.i)=nat"}! *)
lemma UN_least_le:
    "[| Ord(i);  !!x. x\<in>A ==> b(x) \<le> i |] ==> (\<Union>x\<in>A. b(x)) \<le> i"
apply (rule le_imp_subset [THEN UN_least, THEN subset_imp_le])
apply (blast intro: Ord_UN elim: ltE)+
done

lemma UN_succ_least_lt:
    "[| j<i;  !!x. x\<in>A ==> b(x)<j |] ==> (\<Union>x\<in>A. succ(b(x))) < i"
apply (rule ltE, assumption)
apply (rule UN_least_le [THEN lt_trans2])
apply (blast intro: succ_leI)+
done

lemma UN_upper_lt:
     "[| a\<in>A;  i < b(a);  Ord(\<Union>x\<in>A. b(x)) |] ==> i < (\<Union>x\<in>A. b(x))"
by (unfold lt_def, blast)

lemma UN_upper_le:
     "[| a \<in> A;  i \<le> b(a);  Ord(\<Union>x\<in>A. b(x)) |] ==> i \<le> (\<Union>x\<in>A. b(x))"
apply (frule ltD)
apply (rule le_imp_subset [THEN subset_trans, THEN subset_imp_le])
apply (blast intro: lt_Ord UN_upper)+
done

lemma lt_Union_iff: "\<forall>i\<in>A. Ord(i) ==> (j < \<Union>(A)) <-> (\<exists>i\<in>A. j<i)"
by (auto simp: lt_def Ord_Union)

lemma Union_upper_le:
     "[| j \<in> J;  i\<le>j;  Ord(\<Union>(J)) |] ==> i \<le> \<Union>J"
apply (subst Union_eq_UN)
apply (rule UN_upper_le, auto)
done

lemma le_implies_UN_le_UN:
    "[| !!x. x\<in>A ==> c(x) \<le> d(x) |] ==> (\<Union>x\<in>A. c(x)) \<le> (\<Union>x\<in>A. d(x))"
apply (rule UN_least_le)
apply (rule_tac [2] UN_upper_le)
apply (blast intro: Ord_UN le_Ord2)+
done

lemma Ord_equality: "Ord(i) ==> (\<Union>y\<in>i. succ(y)) = i"
by (blast intro: Ord_trans)

(*Holds for all transitive sets, not just ordinals*)
lemma Ord_Union_subset: "Ord(i) ==> \<Union>(i) \<subseteq> i"
by (blast intro: Ord_trans)

subsection{*Limit Ordinals -- General Properties*}

lemma Limit_Union_eq: "Limit(i) ==> \<Union>(i) = i"
apply (unfold Limit_def)
apply (fast intro!: ltI elim!: ltE elim: Ord_trans)
done

lemma Limit_is_Ord: "Limit(i) ==> Ord(i)"
apply (unfold Limit_def)
apply (erule conjunct1)
done

lemma Limit_has_0: "Limit(i) ==> 0 < i"
apply (unfold Limit_def)
apply (erule conjunct2 [THEN conjunct1])
done

lemma Limit_nonzero: "Limit(i) ==> i \<noteq> 0"
by (drule Limit_has_0, blast)

lemma Limit_has_succ: "[| Limit(i);  j<i |] ==> succ(j) < i"
by (unfold Limit_def, blast)

lemma Limit_succ_lt_iff [simp]: "Limit(i) ==> succ(j) < i <-> (j<i)"
apply (safe intro!: Limit_has_succ)
apply (frule lt_Ord)
apply (blast intro: lt_trans)
done

lemma zero_not_Limit [iff]: "~ Limit(0)"
by (simp add: Limit_def)

lemma Limit_has_1: "Limit(i) ==> 1 < i"
by (blast intro: Limit_has_0 Limit_has_succ)

lemma increasing_LimitI: "[| 0<l; \<forall>x\<in>l. \<exists>y\<in>l. x<y |] ==> Limit(l)"
apply (unfold Limit_def, simp add: lt_Ord2, clarify)
apply (drule_tac i=y in ltD)
apply (blast intro: lt_trans1 [OF _ ltI] lt_Ord2)
done

lemma non_succ_LimitI:
  assumes i: "0<i" and nsucc: "\<And>y. succ(y) \<noteq> i"
  shows "Limit(i)"
proof -
  have Oi: "Ord(i)" using i by (simp add: lt_def)
  { fix y
    assume yi: "y<i"
    hence Osy: "Ord(succ(y))" by (simp add: lt_Ord Ord_succ)
    have "~ i \<le> y" using yi by (blast dest: le_imp_not_lt)
    hence "succ(y) < i" using nsucc [of y]
      by (blast intro: Ord_linear_lt [OF Osy Oi]) }
  thus ?thesis using i Oi by (auto simp add: Limit_def)
qed

lemma succ_LimitE [elim!]: "Limit(succ(i)) ==> P"
apply (rule lt_irrefl)
apply (rule Limit_has_succ, assumption)
apply (erule Limit_is_Ord [THEN Ord_succD, THEN le_refl])
done

lemma not_succ_Limit [simp]: "~ Limit(succ(i))"
by blast

lemma Limit_le_succD: "[| Limit(i);  i \<le> succ(j) |] ==> i \<le> j"
by (blast elim!: leE)

subsubsection{*Traditional 3-Way Case Analysis on Ordinals*}

lemma Ord_cases_disj: "Ord(i) ==> i=0 | (\<exists>j. Ord(j) & i=succ(j)) | Limit(i)"
by (blast intro!: non_succ_LimitI Ord_0_lt)

lemma Ord_cases:
 assumes i: "Ord(i)"
 obtains ("0") "i=0" | (succ) j where "Ord(j)" "i=succ(j)" | (limit) "Limit(i)"
by (insert Ord_cases_disj [OF i], auto)

lemma trans_induct3_raw:
     "[| Ord(i);
         P(0);
         !!x. [| Ord(x);  P(x) |] ==> P(succ(x));
         !!x. [| Limit(x);  \<forall>y\<in>x. P(y) |] ==> P(x)
      |] ==> P(i)"
apply (erule trans_induct)
apply (erule Ord_cases, blast+)
done

lemmas trans_induct3 = trans_induct3_raw [rule_format, case_names 0 succ limit, consumes 1]

text{*A set of ordinals is either empty, contains its own union, or its
union is a limit ordinal.*}

lemma Union_le: "[| !!x. x\<in>I ==> x\<le>j; Ord(j) |] ==> \<Union>(I) \<le> j"
  by (auto simp add: le_subset_iff Union_least)

lemma Ord_set_cases:
  assumes I: "\<forall>i\<in>I. Ord(i)"
  shows "I=0 \<or> \<Union>(I) \<in> I \<or> (\<Union>(I) \<notin> I \<and> Limit(\<Union>(I)))"
proof (cases "\<Union>(I)" rule: Ord_cases)
  show "Ord(\<Union>I)" using I by (blast intro: Ord_Union)
next
  assume "\<Union>I = 0" thus ?thesis by (simp, blast intro: subst_elem)
next
  fix j
  assume j: "Ord(j)" and UIj:"\<Union>(I) = succ(j)"
  { assume "\<forall>i\<in>I. i\<le>j"
    hence "\<Union>(I) \<le> j"
      by (simp add: Union_le j)
    hence False
      by (simp add: UIj lt_not_refl) }
  then obtain i where i: "i \<in> I" "succ(j) \<le> i" using I j
    by (atomize, auto simp add: not_le_iff_lt)
  have "\<Union>(I) \<le> succ(j)" using UIj j by auto
  hence "i \<le> succ(j)" using i
    by (simp add: le_subset_iff Union_subset_iff)
  hence "succ(j) = i" using i
    by (blast intro: le_anti_sym)
  hence "succ(j) \<in> I" by (simp add: i)
  thus ?thesis by (simp add: UIj)
next
  assume "Limit(\<Union>I)" thus ?thesis by auto
qed

text{*If the union of a set of ordinals is a successor, then it is an element of that set.*}
lemma Ord_Union_eq_succD: "[|\<forall>x\<in>X. Ord(x);  \<Union>X = succ(j)|] ==> succ(j) \<in> X"
  by (drule Ord_set_cases, auto)

lemma Limit_Union [rule_format]: "[| I \<noteq> 0;  \<forall>i\<in>I. Limit(i) |] ==> Limit(\<Union>I)"
apply (simp add: Limit_def lt_def)
apply (blast intro!: equalityI)
done

end


(*  Title:      HOL/Cardinals/Fun_More.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

More on injections, bijections and inverses.
*)

section \<open>More on Injections, Bijections and Inverses\<close>

theory Fun_More
imports MainRLT
begin

subsection \<open>Purely functional properties\<close>

(* unused *)
(*1*)lemma notIn_Un_bij_betw2:
assumes NIN: "b \<notin> A" and NIN': "b' \<notin> A'" and
        BIJ: "bij_betw f A A'"
shows "bij_betw f (A \<union> {b}) (A' \<union> {b'}) = (f b = b')"
proof
  assume "f b = b'"
  thus "bij_betw f (A \<union> {b}) (A' \<union> {b'})"
  using assms notIn_Un_bij_betw[of b A f A'] by auto
next
  assume *: "bij_betw f (A \<union> {b}) (A' \<union> {b'})"
  hence "f b \<in> A' \<union> {b'}"
  unfolding bij_betw_def by auto
  moreover
  {assume "f b \<in> A'"
   then obtain b1 where 1: "b1 \<in> A" and 2: "f b1 = f b" using BIJ
   by (auto simp add: bij_betw_def)
   hence "b = b1" using *
   by (auto simp add: bij_betw_def inj_on_def)
   with 1 NIN have False by auto
  }
  ultimately show "f b = b'" by blast
qed

(* unused *)
(*1*)lemma bij_betw_ball:
assumes BIJ: "bij_betw f A B"
shows "(\<forall>b \<in> B. phi b) = (\<forall>a \<in> A. phi(f a))"
using assms unfolding bij_betw_def inj_on_def by blast

(* unused *)
(*1*)lemma bij_betw_diff_singl:
assumes BIJ: "bij_betw f A A'" and IN: "a \<in> A"
shows "bij_betw f (A - {a}) (A' - {f a})"
proof-
  let ?B = "A - {a}"   let ?B' = "A' - {f a}"
  have "f a \<in> A'" using IN BIJ unfolding bij_betw_def by blast
  hence "a \<notin> ?B \<and> f a \<notin> ?B' \<and> A = ?B \<union> {a} \<and> A' = ?B' \<union> {f a}"
  using IN by blast
  thus ?thesis using notIn_Un_bij_betw3[of a ?B f ?B'] BIJ by simp
qed

subsection \<open>Properties involving finite and infinite sets\<close>

(* unused *)
(*1*)lemma bij_betw_inv_into_RIGHT:
assumes BIJ: "bij_betw f A A'" and SUB: "B' \<le> A'"
shows "f `((inv_into A f)`B') = B'"
using assms
proof(auto simp add: bij_betw_inv_into_right)
  let ?f' = "(inv_into A f)"
  fix a' assume *: "a' \<in> B'"
  hence "a' \<in> A'" using SUB by auto
  hence "a' = f (?f' a')"
  using BIJ by (auto simp add: bij_betw_inv_into_right)
  thus "a' \<in> f ` (?f' ` B')" using * by blast
qed

(* unused *)
(*1*)lemma bij_betw_inv_into_RIGHT_LEFT:
assumes BIJ: "bij_betw f A A'" and SUB: "B' \<le> A'" and
        IM: "(inv_into A f) ` B' = B"
shows "f ` B = B'"
proof-
  have "f`((inv_into A f)` B') = B'"
  using assms bij_betw_inv_into_RIGHT[of f A A' B'] by auto
  thus ?thesis using IM by auto
qed

(* unused *)
(*2*)lemma bij_betw_inv_into_twice:
assumes "bij_betw f A A'"
shows "\<forall>a \<in> A. inv_into A' (inv_into A f) a = f a"
proof
  let ?f' = "inv_into A f"   let ?f'' = "inv_into A' ?f'"
  have 1: "bij_betw ?f' A' A" using assms
  by (auto simp add: bij_betw_inv_into)
  fix a assume *: "a \<in> A"
  then obtain a' where 2: "a' \<in> A'" and 3: "?f' a' = a"
  using 1 unfolding bij_betw_def by force
  hence "?f'' a = a'"
  using * 1 3 by (auto simp add: bij_betw_inv_into_left)
  moreover have "f a = a'" using assms 2 3
  by (auto simp add: bij_betw_inv_into_right)
  ultimately show "?f'' a = f a" by simp
qed

subsection \<open>Properties involving Hilbert choice\<close>

(*1*)lemma bij_betw_inv_into_LEFT:
assumes BIJ: "bij_betw f A A'" and SUB: "B \<le> A"
shows "(inv_into A f)`(f ` B) = B"
using assms unfolding bij_betw_def using inv_into_image_cancel by force

(*1*)lemma bij_betw_inv_into_LEFT_RIGHT:
assumes BIJ: "bij_betw f A A'" and SUB: "B \<le> A" and
        IM: "f ` B = B'"
shows "(inv_into A f) ` B' = B"
using assms bij_betw_inv_into_LEFT[of f A A' B] by fast

subsection \<open>Other facts\<close>

(*3*)lemma atLeastLessThan_injective:
assumes "{0 ..< m::nat} = {0 ..< n}"
shows "m = n"
proof-
  {assume "m < n"
   hence "m \<in> {0 ..< n}" by auto
   hence "{0 ..< m} < {0 ..< n}" by auto
   hence False using assms by blast
  }
  moreover
  {assume "n < m"
   hence "n \<in> {0 ..< m}" by auto
   hence "{0 ..< n} < {0 ..< m}" by auto
   hence False using assms by blast
  }
  ultimately show ?thesis by force
qed

(*2*)lemma atLeastLessThan_injective2:
"bij_betw f {0 ..< m::nat} {0 ..< n} \<Longrightarrow> m = n"
using finite_atLeastLessThan[of m] finite_atLeastLessThan[of n]
      card_atLeastLessThan[of m] card_atLeastLessThan[of n]
      bij_betw_iff_card[of "{0 ..< m}" "{0 ..< n}"] by auto

(*2*)lemma atLeastLessThan_less_eq:
"({0..<m} \<le> {0..<n}) = ((m::nat) \<le> n)"
unfolding ivl_subset by arith

(*2*)lemma atLeastLessThan_less_eq2:
assumes "inj_on f {0..<(m::nat)} \<and> f ` {0..<m} \<le> {0..<n}"
shows "m \<le> n"
using assms
using finite_atLeastLessThan[of m] finite_atLeastLessThan[of n]
      card_atLeastLessThan[of m] card_atLeastLessThan[of n]
      card_inj_on_le[of f "{0 ..< m}" "{0 ..< n}"] by fastforce

(* unused *)
(*2*)lemma atLeastLessThan_less_eq3:
"(\<exists>f. inj_on f {0..<(m::nat)} \<and> f ` {0..<m} \<le> {0..<n}) = (m \<le> n)"
using atLeastLessThan_less_eq2
proof(auto)
  assume "m \<le> n"
  hence "inj_on id {0..<m} \<and> id ` {0..<m} \<subseteq> {0..<n}" unfolding inj_on_def by force
  thus "\<exists>f. inj_on f {0..<m} \<and> f ` {0..<m} \<subseteq> {0..<n}" by blast
qed

(* unused *)
(*3*)lemma atLeastLessThan_less:
"({0..<m} < {0..<n}) = ((m::nat) < n)"
proof-
  have "({0..<m} < {0..<n}) = ({0..<m} \<le> {0..<n} \<and> {0..<m} ~= {0..<n})"
  using subset_iff_psubset_eq by blast
  also have "\<dots> = (m \<le> n \<and> m ~= n)"
  using atLeastLessThan_less_eq atLeastLessThan_injective by blast
  also have "\<dots> = (m < n)" by auto
  finally show ?thesis .
qed

end


theory Ex1_1
  imports ZF
begin

consts
  snoc :: "[i,i] \<Rightarrow> i"

primrec
"snoc ([] , val)  = [val]"
"snoc (Cons(x , xs) , val) = Cons (x, (snoc (xs , val)))"

lemma snoc_app : "xs \<in> list (A) \<Longrightarrow> ys \<in> list(A) \<Longrightarrow> val \<in> A \<Longrightarrow> snoc (app(xs,ys), val) = app(xs , snoc (ys , val))"
proof (induct_tac xs)
  assume h1:"ys \<in> list(A)"
     and h2:"val \<in> A"
  show "snoc([] @ ys, val) = [] @ snoc(ys, val)" by auto
next
  fix a l
  assume h1:"ys \<in> list(A)"
     and h2:"val \<in> A"
     and h3:"a \<in> A"
     and h4:"l \<in> list(A)"
     and h5:"snoc(l @ ys, val) = l @ snoc(ys, val)"
  show "snoc(Cons(a, l) @ ys, val) = Cons(a, l) @ snoc(ys, val)" using h5 by simp
qed

notation
  Cons ( infix  "$$" 50)

theorem rev_cons : "xs \<in> list(A) \<Longrightarrow> ys \<in> list(A) \<Longrightarrow> val \<in> A \<Longrightarrow> rev (val $$ xs) = snoc ((rev(xs)) , val)"
proof (induct_tac xs)
  assume h1:"ys \<in> list(A)"
     and h2:"val \<in> A"
  show "rev( val $$ []) = snoc(rev([]), val)" by simp
next
  fix a l
  assume h1:"ys \<in> list(A)"
     and h2:"val \<in> A"
     and h3:"a \<in> A"
     and h4:"l \<in> list(A)"
     and h5:"rev(val $$ l) = snoc(rev(l), val)"

  have "rev(val $$ (a $$ l)) = rev(a $$ l) @ [val]" by simp
  also have "\<dots> = rev (l) @ [a] @ [val]" by (subst rev.simps , subst app_assoc , rule rev_type , rule h4 , rule refl)
  also have "\<dots> = rev (l) @ [a] @ snoc ([],val)" by simp
  also have "\<dots> = rev (l) @ snoc ([a],val)" by simp
  also have "\<dots> = snoc (rev(l) @ [a], val)" using h2 h3 h4 snoc_app by auto
  finally show "rev(val $$ (a $$ l)) = snoc(rev(a $$ l), val)" by simp
qed


(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

header {* Tests *}

theory Relation_Algebra_Tests
  imports Relation_Algebra
begin

subsection {* Tests *}

text {* Tests or subidentities provide another way of modelling sets. Once more
we prove the basic properties, most of which stem from Maddux's book. *}

context relation_algebra
begin

definition is_test :: "'a \<Rightarrow> bool"
  where "is_test x \<equiv> x \<le> 1'"

lemma test_conv: "is_test x \<Longrightarrow> is_test (x\<^sup>\<smile>)"
by (metis conv_e conv_iso is_test_def)

lemma test_conv_var: "is_test x \<Longrightarrow> x\<^sup>\<smile> \<le> 1'"
by (metis test_conv is_test_def)

lemma test_eq_conv [simp]: "is_test x \<Longrightarrow> x\<^sup>\<smile> = x"
proof (rule antisym)
  assume hyp: "is_test x"
  hence "x \<le> x ; (1' \<cdot> x\<^sup>\<smile> ; 1')"
    by (metis inf.commute inf_absorb2 inf_le2 modular_1' mult.right_neutral is_test_def)
  thus "x \<le> x\<^sup>\<smile>"
    by (metis comp_unitr conv_contrav conv_invol eq_iff hyp inf_absorb2 mult_subdistl test_conv_var)
  thus "x\<^sup>\<smile> \<le> x"
    by (metis conv_invol conv_times le_iff_inf)
qed

lemma test_sum: "\<lbrakk>is_test x; is_test y\<rbrakk> \<Longrightarrow> is_test (x + y)"
by (metis add_lub is_test_def)

lemma test_prod: "\<lbrakk>is_test x; is_test y\<rbrakk> \<Longrightarrow> is_test (x \<cdot> y)"
by (metis le_infI2 is_test_def)

lemma test_comp: "\<lbrakk>is_test x; is_test y\<rbrakk> \<Longrightarrow> is_test (x ; y)"
by (metis mult_isol comp_unitr order_trans is_test_def)

lemma test_comp_eq_mult:
  assumes "is_test x"
    and "is_test y"
  shows "x ; y = x \<cdot> y"
proof (rule antisym)
  show "x ; y \<le> x \<cdot> y"
    by (metis assms comp_unitr inf_absorb2 le_inf_iff mult_onel mult_subdistl mult_subdistr is_test_def)
next
  have "x \<cdot> y \<le> x ; (1' \<cdot> x\<^sup>\<smile> ; y)"
    by (metis comp_unitr modular_1_var)
  thus "x \<cdot> y \<le> x ; y"
    by (metis assms(1) inf_absorb2 le_infI2 mult.left_neutral mult_isol mult_subdistr order_trans test_eq_conv is_test_def)
qed

lemma test_1 [simp]: "is_test x \<Longrightarrow> x ; 1 \<cdot> y = x ; y"
by (metis inf.commute inf.idem inf_absorb2 mult.left_neutral one_conv ra_1 test_comp_eq_mult test_eq_conv is_test_def)

lemma maddux_32 [simp]: "is_test x \<Longrightarrow> -(x ; 1) \<cdot> 1' = -x \<cdot> 1'"
proof (rule antisym)
  assume "is_test x"
  show "-(x ; 1) \<cdot> 1' \<le> -x \<cdot> 1'"
    by (metis maddux_20 comp_anti inf.commute meet_isor)
next
  assume "is_test x"
  have one: "x ; 1 \<cdot> (-x \<cdot> 1') \<le> x ; x\<^sup>\<smile> ; (-x \<cdot> 1')"
    by (metis maddux_16 inf_top_left mult.assoc)
  hence two: "x ; 1 \<cdot> (-x \<cdot> 1') \<le> -x"
    by (metis inf.commute inf_le1 le_infE)
  hence "x ; 1 \<cdot> (-x \<cdot> 1') \<le> x"
    by (metis one inf.commute le_infE meet_iso one_conv `is_test x` eq_iff test_1 test_eq_conv)
  hence "x ; 1 \<cdot> (-x \<cdot> 1') = 0"
    by (metis two galois_aux2 le_iff_inf)
  thus "-x \<cdot> 1' \<le> -(x ; 1) \<cdot> 1'"
    by (metis double_compl galois_aux2 inf.commute inf_le1 le_inf_iff)
qed

lemma test_distr_1 :
  assumes "is_test x"
    and "is_test y"
  shows "x ; z \<cdot> y ; z = (x \<cdot> y) ; z"
proof (rule antisym)
  have "x ; z \<cdot> y ; z \<le> x ; 1 \<cdot> y ; z"
    by (metis inf_top_left meet_iso mult_subdistl)
  also have "\<dots> = x ; y ; z"
    by (metis assms(1) mult.assoc test_1)
  finally show "x ; z \<cdot> y ; z \<le> (x \<cdot> y) ; z"
    by (metis assms test_comp_eq_mult)
next
  show "(x \<cdot> y) ; z \<le> x ; z \<cdot> y ; z"
    by (metis mult_subdistr_var)
qed

lemma maddux_35: "is_test x \<Longrightarrow> x ; y \<cdot> -z = x ; y \<cdot> -(x ; z)"
proof (rule antisym)
  assume "is_test x"
  show "x ; y \<cdot> -z \<le> x ; y \<cdot> -(x ; z)"
    by (metis `is_test x` comp_anti mult_isor mult_onel is_test_def inf.commute inf_le2 le_infI le_infI1)
  have one: "x ; y \<cdot> -(x ; z) \<le> x ; (y \<cdot> -z)"
    by (metis eq_iff le_infE maddux_23)
  hence two: "x ; y \<cdot> -(x ; z) \<le> x ; y"
    by (metis inf_le1)
  have "x ; y \<cdot> -(x ; z) \<le>  x ; -z"
    using one
    by (metis galois_1 le_iff_sup distrib_left sup_compl_top sup_top_right)
  hence "x ; y \<cdot> -(x ; z) \<le> -z"
    by (metis `is_test x` mult_isor mult_onel is_test_def order_trans)
  thus "x ; y \<cdot> -(x ; z) \<le> x ; y \<cdot> -z"
    using two
    by (metis le_inf_iff)
qed

subsection {* Test Complements *}

text {* Text complements are complements of elements that are ``pushed below''
the multiplicative unit. *}

definition test_compl :: "'a \<Rightarrow> 'a" ("(_ \<^sup>\<dagger>)" [1000] 999)
  where "x\<^sup>\<dagger> = 1' \<cdot> -x"

lemma test_compl_1 [simp]: "is_test x \<Longrightarrow> x + x\<^sup>\<dagger> = 1'"
  by (metis aux4 inf_absorb2 test_compl_def is_test_def)

lemma test_compl_2 [simp]: "is_test x \<Longrightarrow> x \<cdot> x\<^sup>\<dagger> = 0"
  by (metis galois_aux inf.commute inf_le2 test_compl_def)

lemma test_test_compl: "is_test x \<Longrightarrow> is_test (x\<^sup>\<dagger>)"
  by (metis add_ub2 test_compl_1 is_test_def)

lemma test_compl_de_morgan_1: "(x + y)\<^sup>\<dagger> = x\<^sup>\<dagger> \<cdot> y\<^sup>\<dagger>"
  by (metis compl_sup inf.left_commute inf.left_idem meet_assoc test_compl_def)

lemma test_compl_de_morgan_2: "(x \<cdot> y)\<^sup>\<dagger> = x\<^sup>\<dagger> + y\<^sup>\<dagger>"
  by (metis compl_inf inf_sup_distrib1 test_compl_def)

lemma test_compl_three [simp]: "((x\<^sup>\<dagger>)\<^sup>\<dagger>)\<^sup>\<dagger> = x\<^sup>\<dagger>"
  by (metis aux4 aux6 de_morgan_3 inf.commute inf_sup_absorb test_compl_def)

lemma test_compl_double [simp]: "is_test x \<Longrightarrow> (x\<^sup>\<dagger>)\<^sup>\<dagger> = x"
  by (metis aux6_var compl_inf double_compl inf.commute le_iff_inf test_compl_def is_test_def)

end (* relation_algebra *)

end


(* 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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_MSortTDPermutes
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun minus :: "Nat => Nat => Nat" where
"minus (Z) y = Z"
| "minus (S z) (S y2) = minus z y2"

fun lt :: "Nat => Nat => bool" where
"lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S n) (S z) = lt n z"

fun length :: "'a list => Nat" where
"length (nil2) = Z"
| "length (cons2 y l) = plus (S Z) (length l)"

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

fun lmerge :: "Nat list => Nat list => Nat list" where
"lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun take :: "Nat => 'a list => 'a list" where
"take x y =
   (if le x Z then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => (case x of S x2 => cons2 z (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
"idiv x y = (if lt x y then Z else S (idiv (minus x y) y))"
  by pat_completeness auto

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun drop :: "Nat => 'a list => 'a list" where
"drop x y =
   (if le x Z then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => (case x of S x2 => drop x2 xs1)))"

(*fun did not finish the proof*)
function msorttd :: "Nat list => Nat list" where
"msorttd (nil2) = nil2"
| "msorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "msorttd (cons2 y (cons2 x2 x3)) =
     (let k :: Nat = idiv (length (cons2 y (cons2 x2 x3))) (S (S Z))
     in lmerge
          (msorttd (take k (cons2 y (cons2 x2 x3))))
          (msorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (msorttd xs) xs"
  oops

end