(*  Title:      HOL/Algebra/Exact_Sequence.thy
    Author:     Martin Baillon
*)

theory Exact_Sequence
  imports Group Coset Solvable_Groups
begin

section \<open>Exact Sequences\<close>

subsection \<open>Definitions\<close>

inductive exact_seq :: "'a monoid list \<times> ('a \<Rightarrow> 'a) list \<Rightarrow> bool"  where
unity:     " group_hom G1 G2 f \<Longrightarrow> exact_seq ([G2, G1], [f])" |
extension: "\<lbrakk> exact_seq ((G # K # l), (g # q)); group H ; h \<in> hom G H ;
              kernel G H h = image g (carrier K) \<rbrakk> \<Longrightarrow> exact_seq (H # G # K # l, h # g # q)"

abbreviation exact_seq_arrow ::
  "('a \<Rightarrow> 'a) \<Rightarrow> 'a monoid list \<times> ('a \<Rightarrow> 'a) list \<Rightarrow>  'a monoid \<Rightarrow> 'a monoid list \<times> ('a \<Rightarrow> 'a) list"
  ("(3_ / \<longlongrightarrow>\<index> _)" [1000, 60])
  where "exact_seq_arrow  f t G \<equiv> (G # (fst t), f # (snd t))"

subsection \<open>Basic Properties\<close>

lemma exact_seq_length1: "exact_seq t \<Longrightarrow> length (fst t) = Suc (length (snd t))"
  by (induct t rule: exact_seq.induct) auto

lemma exact_seq_length2: "exact_seq t \<Longrightarrow> length (snd t) \<ge> Suc 0"
  by (induct t rule: exact_seq.induct) auto

lemma dropped_seq_is_exact_seq:
  assumes "exact_seq (G, F)" and "(i :: nat) < length F"
  shows "exact_seq (drop i G, drop i F)"
proof-
  { fix t i assume "exact_seq t" "i < length (snd t)"
    hence "exact_seq (drop i (fst t), drop i (snd t))"
    proof (induction arbitrary: i)
      case (unity G1 G2 f) thus ?case
        by (simp add: exact_seq.unity)
    next
      case (extension G K l g q H h) show ?case
      proof (cases)
        assume "i = 0" thus ?case
          using exact_seq.extension[OF extension.hyps] by simp
      next
        assume "i \<noteq> 0" hence "i \<ge> Suc 0" by simp
        then obtain k where "k < length (snd (G # K # l, g # q))" "i = Suc k"
          using Suc_le_D extension.prems by auto
        thus ?thesis using extension.IH by simp
      qed
    qed }

  thus ?thesis using assms by auto
qed

lemma truncated_seq_is_exact_seq:
  assumes "exact_seq (l, q)" and "length l \<ge> 3"
  shows "exact_seq (tl l, tl q)"
  using exact_seq_length1[OF assms(1)] dropped_seq_is_exact_seq[OF assms(1), of "Suc 0"]
        exact_seq_length2[OF assms(1)] assms(2) by (simp add: drop_Suc)

lemma exact_seq_imp_exact_hom:
   assumes "exact_seq (G1 # l,q) \<longlongrightarrow>\<^bsub>g1\<^esub> G2 \<longlongrightarrow>\<^bsub>g2\<^esub> G3"
   shows "g1 ` (carrier G1) = kernel G2 G3 g2"
proof-
  { fix t assume "exact_seq t" and "length (fst t) \<ge> 3 \<and> length (snd t) \<ge> 2"
    hence "(hd (tl (snd t))) ` (carrier (hd (tl (tl (fst t))))) =
            kernel (hd (tl (fst t))) (hd (fst t)) (hd (snd t))"
    proof (induction)
      case (unity G1 G2 f)
      then show ?case by auto
    next
      case (extension G l g q H h)
      then show ?case by auto
    qed }
  thus ?thesis using assms by fastforce
qed

lemma exact_seq_imp_exact_hom_arbitrary:
   assumes "exact_seq (G, F)"
     and "Suc i < length F"
   shows "(F ! (Suc i)) ` (carrier (G ! (Suc (Suc i)))) = kernel (G ! (Suc i)) (G ! i) (F ! i)"
proof -
  have "length (drop i F) \<ge> 2" "length (drop i G) \<ge> 3"
    using assms(2) exact_seq_length1[OF assms(1)] by auto
  then obtain l q
    where "drop i G = (G ! i) # (G ! (Suc i)) # (G ! (Suc (Suc i))) # l"
     and  "drop i F = (F ! i) # (F ! (Suc i)) # q"
    by (metis Cons_nth_drop_Suc Suc_less_eq assms exact_seq_length1 fst_conv
        le_eq_less_or_eq le_imp_less_Suc prod.sel(2))
  thus ?thesis
  using dropped_seq_is_exact_seq[OF assms(1), of i] assms(2)
        exact_seq_imp_exact_hom[of "G ! i" "G ! (Suc i)" "G ! (Suc (Suc i))" l q] by auto
qed

lemma exact_seq_imp_group_hom :
  assumes "exact_seq ((G # l, q)) \<longlongrightarrow>\<^bsub>g\<^esub> H"
  shows "group_hom G H g"
proof-
  { fix t assume "exact_seq t"
    hence "group_hom (hd (tl (fst t))) (hd (fst t)) (hd(snd t))"
    proof (induction)
      case (unity G1 G2 f)
      then show ?case by auto
    next
      case (extension G l g q H h)
      then show ?case unfolding group_hom_def group_hom_axioms_def by auto
    qed }
  note aux_lemma = this
  show ?thesis using aux_lemma[OF assms]
    by simp
qed

lemma exact_seq_imp_group_hom_arbitrary:
  assumes "exact_seq (G, F)" and "(i :: nat) < length F"
  shows "group_hom (G ! (Suc i)) (G ! i) (F ! i)"
proof -
  have "length (drop i F) \<ge> 1" "length (drop i G) \<ge> 2"
    using assms(2) exact_seq_length1[OF assms(1)] by auto
  then obtain l q
    where "drop i G = (G ! i) # (G ! (Suc i)) # l"
     and  "drop i F = (F ! i) # q"
    by (metis Cons_nth_drop_Suc Suc_leI assms exact_seq_length1 fst_conv
        le_eq_less_or_eq le_imp_less_Suc prod.sel(2))
  thus ?thesis
  using dropped_seq_is_exact_seq[OF assms(1), of i] assms(2)
        exact_seq_imp_group_hom[of "G ! i" "G ! (Suc i)" l q "F ! i"] by simp
qed

subsection \<open>Link Between Exact Sequences and Solvable Conditions\<close>

lemma exact_seq_solvable_imp :
  assumes "exact_seq ([G1],[]) \<longlongrightarrow>\<^bsub>g1\<^esub> G2 \<longlongrightarrow>\<^bsub>g2\<^esub> G3"
    and "inj_on g1 (carrier G1)"
    and "g2 ` (carrier G2) = carrier G3"
  shows "solvable G2 \<Longrightarrow> (solvable G1) \<and> (solvable G3)"
proof -
  assume G2: "solvable G2"
  have "group_hom G1 G2 g1"
    using exact_seq_imp_group_hom_arbitrary[OF assms(1), of "Suc 0"] by simp
  hence "solvable G1"
    using group_hom.inj_hom_imp_solvable[of G1 G2 g1] assms(2) G2 by simp
  moreover have "group_hom G2 G3 g2"
    using exact_seq_imp_group_hom_arbitrary[OF assms(1), of 0] by simp
  hence "solvable G3"
    using group_hom.surj_hom_imp_solvable[of G2 G3 g2] assms(3) G2 by simp
  ultimately show ?thesis by simp
qed

lemma exact_seq_solvable_recip :
  assumes "exact_seq ([G1],[]) \<longlongrightarrow>\<^bsub>g1\<^esub> G2 \<longlongrightarrow>\<^bsub>g2\<^esub> G3"
    and "inj_on g1 (carrier G1)"
    and "g2 ` (carrier G2) = carrier G3"
  shows "(solvable G1) \<and> (solvable G3) \<Longrightarrow> solvable G2"
proof -
  assume "(solvable G1) \<and> (solvable G3)"
  hence G1: "solvable G1" and G3: "solvable G3" by auto
  have g1: "group_hom G1 G2 g1" and g2: "group_hom G2 G3 g2"
    using exact_seq_imp_group_hom_arbitrary[OF assms(1), of "Suc 0"]
          exact_seq_imp_group_hom_arbitrary[OF assms(1), of 0] by auto
  show ?thesis
    using solvable_condition[OF g1 g2 assms(3)]
          exact_seq_imp_exact_hom[OF assms(1)] G1 G3 by auto
qed

proposition exact_seq_solvable_iff :
  assumes "exact_seq ([G1],[]) \<longlongrightarrow>\<^bsub>g1\<^esub> G2 \<longlongrightarrow>\<^bsub>g2\<^esub> G3"
    and "inj_on g1 (carrier G1)"
    and "g2 ` (carrier G2) = carrier G3"
  shows "(solvable G1) \<and> (solvable G3) \<longleftrightarrow>  solvable G2"
  using exact_seq_solvable_recip exact_seq_solvable_imp assms by blast

end


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

Well-order relations.
*)

section \<open>Well-Order Relations\<close>

theory Wellorder_Relation
imports BNF_Wellorder_Relation Wellfounded_More
begin

context wo_rel
begin

subsection \<open>Auxiliaries\<close>

lemma PREORD: "Preorder r"
using WELL order_on_defs[of _ r] by auto

lemma PARORD: "Partial_order r"
using WELL order_on_defs[of _ r] by auto

lemma cases_Total2:
"\<And> phi a b. \<lbrakk>{a,b} \<le> Field r; ((a,b) \<in> r - Id \<Longrightarrow> phi a b);
              ((b,a) \<in> r - Id \<Longrightarrow> phi a b); (a = b \<Longrightarrow> phi a b)\<rbrakk>
             \<Longrightarrow> phi a b"
using TOTALS by auto

subsection \<open>Well-founded induction and recursion adapted to non-strict well-order relations\<close>

lemma worec_unique_fixpoint:
assumes ADM: "adm_wo H" and fp: "f = H f"
shows "f = worec H"
proof-
  have "adm_wf (r - Id) H"
  unfolding adm_wf_def
  using ADM adm_wo_def[of H] underS_def[of r] by auto
  hence "f = wfrec (r - Id) H"
  using fp WF wfrec_unique_fixpoint[of "r - Id" H] by simp
  thus ?thesis unfolding worec_def .
qed

subsubsection \<open>Properties of max2\<close>

lemma max2_iff:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "((max2 a b, c) \<in> r) = ((a,c) \<in> r \<and> (b,c) \<in> r)"
proof
  assume "(max2 a b, c) \<in> r"
  thus "(a,c) \<in> r \<and> (b,c) \<in> r"
  using assms max2_greater[of a b] TRANS trans_def[of r] by blast
next
  assume "(a,c) \<in> r \<and> (b,c) \<in> r"
  thus "(max2 a b, c) \<in> r"
  using assms max2_among[of a b] by auto
qed

subsubsection \<open>Properties of minim\<close>

lemma minim_Under:
"\<lbrakk>B \<le> Field r; B \<noteq> {}\<rbrakk> \<Longrightarrow> minim B \<in> Under B"
by(auto simp add: Under_def minim_inField minim_least)

lemma equals_minim_Under:
"\<lbrakk>B \<le> Field r; a \<in> B; a \<in> Under B\<rbrakk>
 \<Longrightarrow> a = minim B"
by(auto simp add: Under_def equals_minim)

lemma minim_iff_In_Under:
assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
shows "(a = minim B) = (a \<in> B \<and> a \<in> Under B)"
proof
  assume "a = minim B"
  thus "a \<in> B \<and> a \<in> Under B"
  using assms minim_in minim_Under by simp
next
  assume "a \<in> B \<and> a \<in> Under B"
  thus "a = minim B"
  using assms equals_minim_Under by simp
qed

lemma minim_Under_under:
assumes NE: "A \<noteq> {}" and SUB: "A \<le> Field r"
shows "Under A = under (minim A)"
proof-
  (* Preliminary facts *)
  have 1: "minim A \<in> A"
  using assms minim_in by auto
  have 2: "\<forall>x \<in> A. (minim A, x) \<in> r"
  using assms minim_least by auto
  (* Main proof *)
  have "Under A \<le> under (minim A)"
  proof
    fix x assume "x \<in> Under A"
    with 1 Under_def[of r] have "(x,minim A) \<in> r" by auto
    thus "x \<in> under(minim A)" unfolding under_def by simp
  qed
  (*  *)
  moreover
  (*  *)
  have "under (minim A) \<le> Under A"
  proof
    fix x assume "x \<in> under(minim A)"
    hence 11: "(x,minim A) \<in> r" unfolding under_def by simp
    hence "x \<in> Field r" unfolding Field_def by auto
    moreover
    {fix a assume "a \<in> A"
     with 2 have "(minim A, a) \<in> r" by simp
     with 11 have "(x,a) \<in> r"
     using TRANS trans_def[of r] by blast
    }
    ultimately show "x \<in> Under A" by (unfold Under_def, auto)
  qed
  (*  *)
  ultimately show ?thesis by blast
qed

lemma minim_UnderS_underS:
assumes NE: "A \<noteq> {}" and SUB: "A \<le> Field r"
shows "UnderS A = underS (minim A)"
proof-
  (* Preliminary facts *)
  have 1: "minim A \<in> A"
  using assms minim_in by auto
  have 2: "\<forall>x \<in> A. (minim A, x) \<in> r"
  using assms minim_least by auto
  (* Main proof *)
  have "UnderS A \<le> underS (minim A)"
  proof
    fix x assume "x \<in> UnderS A"
    with 1 UnderS_def[of r] have "x \<noteq> minim A \<and> (x,minim A) \<in> r" by auto
    thus "x \<in> underS(minim A)" unfolding underS_def by simp
  qed
  (*  *)
  moreover
  (*  *)
  have "underS (minim A) \<le> UnderS A"
  proof
    fix x assume "x \<in> underS(minim A)"
    hence 11: "x \<noteq> minim A \<and> (x,minim A) \<in> r" unfolding underS_def by simp
    hence "x \<in> Field r" unfolding Field_def by auto
    moreover
    {fix a assume "a \<in> A"
     with 2 have 3: "(minim A, a) \<in> r" by simp
     with 11 have "(x,a) \<in> r"
     using TRANS trans_def[of r] by blast
     moreover
     have "x \<noteq> a"
     proof
       assume "x = a"
       with 11 3 ANTISYM antisym_def[of r]
       show False by auto
     qed
     ultimately
     have "x \<noteq> a \<and> (x,a) \<in> r" by simp
    }
    ultimately show "x \<in> UnderS A" by (unfold UnderS_def, auto)
  qed
  (*  *)
  ultimately show ?thesis by blast
qed

subsubsection \<open>Properties of supr\<close>

lemma supr_Above:
assumes SUB: "B \<le> Field r" and ABOVE: "Above B \<noteq> {}"
shows "supr B \<in> Above B"
proof(unfold supr_def)
  have "Above B \<le> Field r"
  using Above_Field[of r] by auto
  thus "minim (Above B) \<in> Above B"
  using assms by (simp add: minim_in)
qed

lemma supr_greater:
assumes SUB: "B \<le> Field r" and ABOVE: "Above B \<noteq> {}" and
        IN: "b \<in> B"
shows "(b, supr B) \<in> r"
proof-
  from assms supr_Above
  have "supr B \<in> Above B" by simp
  with IN Above_def[of r] show ?thesis by simp
qed

lemma supr_least_Above:
assumes SUB: "B \<le> Field r" and
        ABOVE: "a \<in> Above B"
shows "(supr B, a) \<in> r"
proof(unfold supr_def)
  have "Above B \<le> Field r"
  using Above_Field[of r] by auto
  thus "(minim (Above B), a) \<in> r"
  using assms minim_least
  by simp
qed

lemma supr_least:
"\<lbrakk>B \<le> Field r; a \<in> Field r; (\<And> b. b \<in> B \<Longrightarrow> (b,a) \<in> r)\<rbrakk>
 \<Longrightarrow> (supr B, a) \<in> r"
by(auto simp add: supr_least_Above Above_def)

lemma equals_supr_Above:
assumes SUB: "B \<le> Field r" and ABV: "a \<in> Above B" and
        MINIM: "\<And> a'. a' \<in> Above B \<Longrightarrow> (a,a') \<in> r"
shows "a = supr B"
proof(unfold supr_def)
  have "Above B \<le> Field r"
  using Above_Field[of r] by auto
  thus "a = minim (Above B)"
  using assms equals_minim by simp
qed

lemma equals_supr:
assumes SUB: "B \<le> Field r" and IN: "a \<in> Field r" and
        ABV: "\<And> b. b \<in> B \<Longrightarrow> (b,a) \<in> r" and
        MINIM: "\<And> a'. \<lbrakk> a' \<in> Field r; \<And> b. b \<in> B \<Longrightarrow> (b,a') \<in> r\<rbrakk> \<Longrightarrow> (a,a') \<in> r"
shows "a = supr B"
proof-
  have "a \<in> Above B"
  unfolding Above_def using ABV IN by simp
  moreover
  have "\<And> a'. a' \<in> Above B \<Longrightarrow> (a,a') \<in> r"
  unfolding Above_def using MINIM by simp
  ultimately show ?thesis
  using equals_supr_Above SUB by auto
qed

lemma supr_inField:
assumes "B \<le> Field r" and  "Above B \<noteq> {}"
shows "supr B \<in> Field r"
proof-
  have "supr B \<in> Above B" using supr_Above assms by simp
  thus ?thesis using assms Above_Field[of r] by auto
qed

lemma supr_above_Above:
assumes SUB: "B \<le> Field r" and  ABOVE: "Above B \<noteq> {}"
shows "Above B = above (supr B)"
proof(unfold Above_def above_def, auto)
  fix a assume "a \<in> Field r" "\<forall>b \<in> B. (b,a) \<in> r"
  with supr_least assms
  show "(supr B, a) \<in> r" by auto
next
  fix b assume "(supr B, b) \<in> r"
  thus "b \<in> Field r"
  using REFL refl_on_def[of _ r] by auto
next
  fix a b
  assume 1: "(supr B, b) \<in> r" and 2: "a \<in> B"
  with assms supr_greater
  have "(a,supr B) \<in> r" by auto
  thus "(a,b) \<in> r"
  using 1 TRANS trans_def[of r] by blast
qed

lemma supr_under:
assumes IN: "a \<in> Field r"
shows "a = supr (under a)"
proof-
  have "under a \<le> Field r"
  using under_Field[of r] by auto
  moreover
  have "under a \<noteq> {}"
  using IN Refl_under_in[of r] REFL by auto
  moreover
  have "a \<in> Above (under a)"
  using in_Above_under[of _ r] IN by auto
  moreover
  have "\<forall>a' \<in> Above (under a). (a,a') \<in> r"
  proof(unfold Above_def under_def, auto)
    fix a'
    assume "\<forall>aa. (aa, a) \<in> r \<longrightarrow> (aa, a') \<in> r"
    hence "(a,a) \<in> r \<longrightarrow> (a,a') \<in> r" by blast
    moreover have "(a,a) \<in> r"
    using REFL IN by (auto simp add: refl_on_def)
    ultimately
    show  "(a, a') \<in> r" by (rule mp)
  qed
  ultimately show ?thesis
  using equals_supr_Above by auto
qed

subsubsection \<open>Properties of successor\<close>

lemma suc_least:
"\<lbrakk>B \<le> Field r; a \<in> Field r; (\<And> b. b \<in> B \<Longrightarrow> a \<noteq> b \<and> (b,a) \<in> r)\<rbrakk>
 \<Longrightarrow> (suc B, a) \<in> r"
by(auto simp add: suc_least_AboveS AboveS_def)

lemma equals_suc:
assumes SUB: "B \<le> Field r" and IN: "a \<in> Field r" and
 ABVS: "\<And> b. b \<in> B \<Longrightarrow> a \<noteq> b \<and> (b,a) \<in> r" and
 MINIM: "\<And> a'. \<lbrakk>a' \<in> Field r; \<And> b. b \<in> B \<Longrightarrow> a' \<noteq> b \<and> (b,a') \<in> r\<rbrakk> \<Longrightarrow> (a,a') \<in> r"
shows "a = suc B"
proof-
  have "a \<in> AboveS B"
  unfolding AboveS_def using ABVS IN by simp
  moreover
  have "\<And> a'. a' \<in> AboveS B \<Longrightarrow> (a,a') \<in> r"
  unfolding AboveS_def using MINIM by simp
  ultimately show ?thesis
  using equals_suc_AboveS SUB by auto
qed

lemma suc_above_AboveS:
assumes SUB: "B \<le> Field r" and
        ABOVE: "AboveS B \<noteq> {}"
shows "AboveS B = above (suc B)"
proof(unfold AboveS_def above_def, auto)
  fix a assume "a \<in> Field r" "\<forall>b \<in> B. a \<noteq> b \<and> (b,a) \<in> r"
  with suc_least assms
  show "(suc B,a) \<in> r" by auto
next
  fix b assume "(suc B, b) \<in> r"
  thus "b \<in> Field r"
  using REFL refl_on_def[of _ r] by auto
next
  fix a b
  assume 1: "(suc B, b) \<in> r" and 2: "a \<in> B"
  with assms suc_greater[of B a]
  have "(a,suc B) \<in> r" by auto
  thus "(a,b) \<in> r"
  using 1 TRANS trans_def[of r] by blast
next
  fix a
  assume 1: "(suc B, a) \<in> r" and 2: "a \<in> B"
  with assms suc_greater[of B a]
  have "(a,suc B) \<in> r" by auto
  moreover have "suc B \<in> Field r"
  using assms suc_inField by simp
  ultimately have "a = suc B"
  using 1 2 SUB ANTISYM antisym_def[of r] by auto
  thus False
  using assms suc_greater[of B a] 2 by auto
qed

lemma suc_singl_pred:
assumes IN: "a \<in> Field r" and ABOVE_NE: "aboveS a \<noteq> {}" and
        REL: "(a',suc {a}) \<in> r" and DIFF: "a' \<noteq> suc {a}"
shows "a' = a \<or> (a',a) \<in> r"
proof-
  have *: "suc {a} \<in> Field r \<and> a' \<in> Field r"
  using WELL REL well_order_on_domain by metis
  {assume **: "a' \<noteq> a"
   hence "(a,a') \<in> r \<or> (a',a) \<in> r"
   using TOTAL IN * by (auto simp add: total_on_def)
   moreover
   {assume "(a,a') \<in> r"
    with ** * assms WELL suc_least[of "{a}" a']
    have "(suc {a},a') \<in> r" by auto
    with REL DIFF * ANTISYM antisym_def[of r]
    have False by simp
   }
   ultimately have "(a',a) \<in> r"
   by blast
  }
  thus ?thesis by blast
qed

lemma under_underS_suc:
assumes IN: "a \<in> Field r" and ABV: "aboveS a \<noteq> {}"
shows "underS (suc {a}) = under a"
proof-
  have 1: "AboveS {a} \<noteq> {}"
  using ABV aboveS_AboveS_singl[of r] by auto
  have 2: "a \<noteq> suc {a} \<and> (a,suc {a}) \<in> r"
  using suc_greater[of "{a}" a] IN 1 by auto
  (*   *)
  have "underS (suc {a}) \<le> under a"
  proof(unfold underS_def under_def, auto)
    fix x assume *: "x \<noteq> suc {a}" and **: "(x,suc {a}) \<in> r"
    with suc_singl_pred[of a x] IN ABV
    have "x = a \<or> (x,a) \<in> r" by auto
    with REFL refl_on_def[of _ r] IN
    show "(x,a) \<in> r" by auto
  qed
  (*  *)
  moreover
  (*   *)
  have "under a \<le> underS (suc {a})"
  proof(unfold underS_def under_def, auto)
    assume "(suc {a}, a) \<in> r"
    with 2 ANTISYM antisym_def[of r]
    show False by auto
  next
    fix x assume *: "(x,a) \<in> r"
    with 2 TRANS trans_def[of r]
    show "(x,suc {a}) \<in> r" by blast
  (*  blast is often better than auto/auto for transitivity-like properties *)
  qed
  (*  *)
  ultimately show ?thesis by blast
qed

subsubsection \<open>Properties of order filters\<close>

lemma ofilter_Under[simp]:
assumes "A \<le> Field r"
shows "ofilter(Under A)"
proof(unfold ofilter_def, auto)
  fix x assume "x \<in> Under A"
  thus "x \<in> Field r"
  using Under_Field[of r] assms by auto
next
  fix a x
  assume "a \<in> Under A" and "x \<in> under a"
  thus "x \<in> Under A"
  using TRANS under_Under_trans[of r] by auto
qed

lemma ofilter_UnderS[simp]:
assumes "A \<le> Field r"
shows "ofilter(UnderS A)"
proof(unfold ofilter_def, auto)
  fix x assume "x \<in> UnderS A"
  thus "x \<in> Field r"
  using UnderS_Field[of r] assms by auto
next
  fix a x
  assume "a \<in> UnderS A" and "x \<in> under a"
  thus "x \<in> UnderS A"
  using TRANS ANTISYM under_UnderS_trans[of r] by auto
qed

lemma ofilter_Int[simp]: "\<lbrakk>ofilter A; ofilter B\<rbrakk> \<Longrightarrow> ofilter(A Int B)"
unfolding ofilter_def by blast

lemma ofilter_Un[simp]: "\<lbrakk>ofilter A; ofilter B\<rbrakk> \<Longrightarrow> ofilter(A \<union> B)"
unfolding ofilter_def by blast

lemma ofilter_INTER:
"\<lbrakk>I \<noteq> {}; \<And> i. i \<in> I \<Longrightarrow> ofilter(A i)\<rbrakk> \<Longrightarrow> ofilter (\<Inter>i \<in> I. A i)"
unfolding ofilter_def by blast

lemma ofilter_Inter:
"\<lbrakk>S \<noteq> {}; \<And> A. A \<in> S \<Longrightarrow> ofilter A\<rbrakk> \<Longrightarrow> ofilter (\<Inter>S)"
unfolding ofilter_def by blast

lemma ofilter_Union:
"(\<And> A. A \<in> S \<Longrightarrow> ofilter A) \<Longrightarrow> ofilter (\<Union>S)"
unfolding ofilter_def by blast

lemma ofilter_under_Union:
"ofilter A \<Longrightarrow> A = \<Union>{under a| a. a \<in> A}"
using ofilter_under_UNION [of A] by auto

subsubsection \<open>Other properties\<close>

lemma Trans_Under_regressive:
assumes NE: "A \<noteq> {}" and SUB: "A \<le> Field r"
shows "Under(Under A) \<le> Under A"
proof
  let ?a = "minim A"
  (*  Preliminary facts *)
  have 1: "minim A \<in> Under A"
  using assms minim_Under by auto
  have 2: "\<forall>y \<in> A. (minim A, y) \<in> r"
  using assms minim_least by auto
  (* Main proof *)
  fix x assume "x \<in> Under(Under A)"
  with 1 have 1: "(x,minim A) \<in> r"
  using Under_def[of r] by auto
  with Field_def have "x \<in> Field r" by fastforce
  moreover
  {fix y assume *: "y \<in> A"
   hence "(x,y) \<in> r"
   using 1 2 TRANS trans_def[of r] by blast
   with Field_def have "(x,y) \<in> r" by auto
  }
  ultimately
  show "x \<in> Under A" unfolding Under_def by auto
qed

lemma ofilter_suc_Field:
assumes OF: "ofilter A" and NE: "A \<noteq> Field r"
shows "ofilter (A \<union> {suc A})"
proof-
  (* Preliminary facts *)
  have 1: "A \<le> Field r" using OF ofilter_def by auto
  hence 2: "AboveS A \<noteq> {}"
  using ofilter_AboveS_Field NE OF by blast
  from 1 2 suc_inField
  have 3: "suc A \<in> Field r" by auto
  (* Main proof *)
  show ?thesis
  proof(unfold ofilter_def, auto simp add: 1 3)
    fix a x
    assume "a \<in> A" "x \<in> under a" "x \<notin> A"
    with OF ofilter_def have False by auto
    thus "x = suc A" by simp
  next
    fix x assume *: "x \<in> under (suc A)" and **: "x \<notin> A"
    hence "x \<in> Field r" using under_def Field_def by fastforce
    with ** have "x \<in> AboveS A"
    using ofilter_AboveS_Field[of A] OF by auto
    hence "(suc A,x) \<in> r"
    using suc_least_AboveS by auto
    moreover
    have "(x,suc A) \<in> r" using * under_def[of r] by auto
    ultimately show "x = suc A"
    using ANTISYM antisym_def[of r] by auto
  qed
qed

(* FIXME: needed? *)
declare
  minim_in[simp]
  minim_inField[simp]
  minim_least[simp]
  under_ofilter[simp]
  underS_ofilter[simp]
  Field_ofilter[simp]

end

abbreviation "worec \<equiv> wo_rel.worec"
abbreviation "adm_wo \<equiv> wo_rel.adm_wo"
abbreviation "isMinim \<equiv> wo_rel.isMinim"
abbreviation "minim \<equiv> wo_rel.minim"
abbreviation "max2 \<equiv> wo_rel.max2"
abbreviation "supr \<equiv> wo_rel.supr"
abbreviation "suc \<equiv> wo_rel.suc"

end


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

Many proofs are borrowed from pair.thy and sum.thy

Do we EVER have rank(a) < rank(<a;b>) ?  Perhaps if the latter rank
is not a limit ordinal?
*)

section{*Quine-Inspired Ordered Pairs and Disjoint Sums*}

theory QPair imports Sum func begin

text{*For non-well-founded data
structures in ZF.  Does not precisely follow Quine's construction.  Thanks
to Thomas Forster for suggesting this approach!

W. V. Quine, On Ordered Pairs and Relations, in Selected Logic Papers,
1966.
*}

definition
  QPair     :: "[i, i] => i"                      ("<(_;/ _)>")  where
    "<a;b> == a+b"

definition
  qfst :: "i => i"  where
    "qfst(p) == THE a. \<exists>b. p=<a;b>"

definition
  qsnd :: "i => i"  where
    "qsnd(p) == THE b. \<exists>a. p=<a;b>"

definition
  qsplit    :: "[[i, i] => 'a, i] => 'a::{}"  (*for pattern-matching*)  where
    "qsplit(c,p) == c(qfst(p), qsnd(p))"

definition
  qconverse :: "i => i"  where
    "qconverse(r) == {z. w \<in> r, \<exists>x y. w=<x;y> & z=<y;x>}"

definition
  QSigma    :: "[i, i => i] => i"  where
    "QSigma(A,B)  ==  \<Union>x\<in>A. \<Union>y\<in>B(x). {<x;y>}"

syntax
  "_QSUM"   :: "[idt, i, i] => i"               ("(3QSUM _ \<in> _./ _)" 10)
translations
  "QSUM x \<in> A. B"  => "CONST QSigma(A, %x. B)"

abbreviation
  qprod  (infixr "<*>" 80) where
  "A <*> B == QSigma(A, %_. B)"

definition
  qsum    :: "[i,i]=>i"                         (infixr "<+>" 65)  where
    "A <+> B      == ({0} <*> A) \<union> ({1} <*> B)"

definition
  QInl :: "i=>i"  where
    "QInl(a)      == <0;a>"

definition
  QInr :: "i=>i"  where
    "QInr(b)      == <1;b>"

definition
  qcase     :: "[i=>i, i=>i, i]=>i"  where
    "qcase(c,d)   == qsplit(%y z. cond(y, d(z), c(z)))"

subsection{*Quine ordered pairing*}

(** Lemmas for showing that <a;b> uniquely determines a and b **)

lemma QPair_empty [simp]: "<0;0> = 0"
by (simp add: QPair_def)

lemma QPair_iff [simp]: "<a;b> = <c;d> \<longleftrightarrow> a=c & b=d"
apply (simp add: QPair_def)
apply (rule sum_equal_iff)
done

lemmas QPair_inject = QPair_iff [THEN iffD1, THEN conjE, elim!]

lemma QPair_inject1: "<a;b> = <c;d> ==> a=c"
by blast

lemma QPair_inject2: "<a;b> = <c;d> ==> b=d"
by blast

subsubsection{*QSigma: Disjoint union of a family of sets
     Generalizes Cartesian product*}

lemma QSigmaI [intro!]: "[| a \<in> A;  b \<in> B(a) |] ==> <a;b> \<in> QSigma(A,B)"
by (simp add: QSigma_def)

(** Elimination rules for <a;b>:A*B -- introducing no eigenvariables **)

lemma QSigmaE [elim!]:
    "[| c \<in> QSigma(A,B);
        !!x y.[| x \<in> A;  y \<in> B(x);  c=<x;y> |] ==> P
     |] ==> P"
by (simp add: QSigma_def, blast)

lemma QSigmaE2 [elim!]:
    "[| <a;b>: QSigma(A,B); [| a \<in> A;  b \<in> B(a) |] ==> P |] ==> P"
by (simp add: QSigma_def)

lemma QSigmaD1: "<a;b> \<in> QSigma(A,B) ==> a \<in> A"
by blast

lemma QSigmaD2: "<a;b> \<in> QSigma(A,B) ==> b \<in> B(a)"
by blast

lemma QSigma_cong:
    "[| A=A';  !!x. x \<in> A' ==> B(x)=B'(x) |] ==>
     QSigma(A,B) = QSigma(A',B')"
by (simp add: QSigma_def)

lemma QSigma_empty1 [simp]: "QSigma(0,B) = 0"
by blast

lemma QSigma_empty2 [simp]: "A <*> 0 = 0"
by blast

subsubsection{*Projections: qfst, qsnd*}

lemma qfst_conv [simp]: "qfst(<a;b>) = a"
by (simp add: qfst_def)

lemma qsnd_conv [simp]: "qsnd(<a;b>) = b"
by (simp add: qsnd_def)

lemma qfst_type [TC]: "p \<in> QSigma(A,B) ==> qfst(p) \<in> A"
by auto

lemma qsnd_type [TC]: "p \<in> QSigma(A,B) ==> qsnd(p) \<in> B(qfst(p))"
by auto

lemma QPair_qfst_qsnd_eq: "a \<in> QSigma(A,B) ==> <qfst(a); qsnd(a)> = a"
by auto

subsubsection{*Eliminator: qsplit*}

(*A META-equality, so that it applies to higher types as well...*)
lemma qsplit [simp]: "qsplit(%x y. c(x,y), <a;b>) == c(a,b)"
by (simp add: qsplit_def)

lemma qsplit_type [elim!]:
    "[|  p \<in> QSigma(A,B);
         !!x y.[| x \<in> A; y \<in> B(x) |] ==> c(x,y):C(<x;y>)
     |] ==> qsplit(%x y. c(x,y), p) \<in> C(p)"
by auto

lemma expand_qsplit:
 "u \<in> A<*>B ==> R(qsplit(c,u)) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. u = <x;y> \<longrightarrow> R(c(x,y)))"
apply (simp add: qsplit_def, auto)
done

subsubsection{*qsplit for predicates: result type o*}

lemma qsplitI: "R(a,b) ==> qsplit(R, <a;b>)"
by (simp add: qsplit_def)

lemma qsplitE:
    "[| qsplit(R,z);  z \<in> QSigma(A,B);
        !!x y. [| z = <x;y>;  R(x,y) |] ==> P
    |] ==> P"
by (simp add: qsplit_def, auto)

lemma qsplitD: "qsplit(R,<a;b>) ==> R(a,b)"
by (simp add: qsplit_def)

subsubsection{*qconverse*}

lemma qconverseI [intro!]: "<a;b>:r ==> <b;a>:qconverse(r)"
by (simp add: qconverse_def, blast)

lemma qconverseD [elim!]: "<a;b> \<in> qconverse(r) ==> <b;a> \<in> r"
by (simp add: qconverse_def, blast)

lemma qconverseE [elim!]:
    "[| yx \<in> qconverse(r);
        !!x y. [| yx=<y;x>;  <x;y>:r |] ==> P
     |] ==> P"
by (simp add: qconverse_def, blast)

lemma qconverse_qconverse: "r<=QSigma(A,B) ==> qconverse(qconverse(r)) = r"
by blast

lemma qconverse_type: "r \<subseteq> A <*> B ==> qconverse(r) \<subseteq> B <*> A"
by blast

lemma qconverse_prod: "qconverse(A <*> B) = B <*> A"
by blast

lemma qconverse_empty: "qconverse(0) = 0"
by blast

subsection{*The Quine-inspired notion of disjoint sum*}

lemmas qsum_defs = qsum_def QInl_def QInr_def qcase_def

(** Introduction rules for the injections **)

lemma QInlI [intro!]: "a \<in> A ==> QInl(a) \<in> A <+> B"
by (simp add: qsum_defs, blast)

lemma QInrI [intro!]: "b \<in> B ==> QInr(b) \<in> A <+> B"
by (simp add: qsum_defs, blast)

(** Elimination rules **)

lemma qsumE [elim!]:
    "[| u \<in> A <+> B;
        !!x. [| x \<in> A;  u=QInl(x) |] ==> P;
        !!y. [| y \<in> B;  u=QInr(y) |] ==> P
     |] ==> P"
by (simp add: qsum_defs, blast)

(** Injection and freeness equivalences, for rewriting **)

lemma QInl_iff [iff]: "QInl(a)=QInl(b) \<longleftrightarrow> a=b"
by (simp add: qsum_defs )

lemma QInr_iff [iff]: "QInr(a)=QInr(b) \<longleftrightarrow> a=b"
by (simp add: qsum_defs )

lemma QInl_QInr_iff [simp]: "QInl(a)=QInr(b) \<longleftrightarrow> False"
by (simp add: qsum_defs )

lemma QInr_QInl_iff [simp]: "QInr(b)=QInl(a) \<longleftrightarrow> False"
by (simp add: qsum_defs )

lemma qsum_empty [simp]: "0<+>0 = 0"
by (simp add: qsum_defs )

(*Injection and freeness rules*)

lemmas QInl_inject = QInl_iff [THEN iffD1]
lemmas QInr_inject = QInr_iff [THEN iffD1]
lemmas QInl_neq_QInr = QInl_QInr_iff [THEN iffD1, THEN FalseE, elim!]
lemmas QInr_neq_QInl = QInr_QInl_iff [THEN iffD1, THEN FalseE, elim!]

lemma QInlD: "QInl(a): A<+>B ==> a \<in> A"
by blast

lemma QInrD: "QInr(b): A<+>B ==> b \<in> B"
by blast

(** <+> is itself injective... who cares?? **)

lemma qsum_iff:
     "u \<in> A <+> B \<longleftrightarrow> (\<exists>x. x \<in> A & u=QInl(x)) | (\<exists>y. y \<in> B & u=QInr(y))"
by blast

lemma qsum_subset_iff: "A <+> B \<subseteq> C <+> D \<longleftrightarrow> A<=C & B<=D"
by blast

lemma qsum_equal_iff: "A <+> B = C <+> D \<longleftrightarrow> A=C & B=D"
apply (simp (no_asm) add: extension qsum_subset_iff)
apply blast
done

subsubsection{*Eliminator -- qcase*}

lemma qcase_QInl [simp]: "qcase(c, d, QInl(a)) = c(a)"
by (simp add: qsum_defs )

lemma qcase_QInr [simp]: "qcase(c, d, QInr(b)) = d(b)"
by (simp add: qsum_defs )

lemma qcase_type:
    "[| u \<in> A <+> B;
        !!x. x \<in> A ==> c(x): C(QInl(x));
        !!y. y \<in> B ==> d(y): C(QInr(y))
     |] ==> qcase(c,d,u) \<in> C(u)"
by (simp add: qsum_defs, auto)

(** Rules for the Part primitive **)

lemma Part_QInl: "Part(A <+> B,QInl) = {QInl(x). x \<in> A}"
by blast

lemma Part_QInr: "Part(A <+> B,QInr) = {QInr(y). y \<in> B}"
by blast

lemma Part_QInr2: "Part(A <+> B, %x. QInr(h(x))) = {QInr(y). y \<in> Part(B,h)}"
by blast

lemma Part_qsum_equality: "C \<subseteq> A <+> B ==> Part(C,QInl) \<union> Part(C,QInr) = C"
by blast

subsubsection{*Monotonicity*}

lemma QPair_mono: "[| a<=c;  b<=d |] ==> <a;b> \<subseteq> <c;d>"
by (simp add: QPair_def sum_mono)

lemma QSigma_mono [rule_format]:
     "[| A<=C;  \<forall>x\<in>A. B(x) \<subseteq> D(x) |] ==> QSigma(A,B) \<subseteq> QSigma(C,D)"
by blast

lemma QInl_mono: "a<=b ==> QInl(a) \<subseteq> QInl(b)"
by (simp add: QInl_def subset_refl [THEN QPair_mono])

lemma QInr_mono: "a<=b ==> QInr(a) \<subseteq> QInr(b)"
by (simp add: QInr_def subset_refl [THEN QPair_mono])

lemma qsum_mono: "[| A<=C;  B<=D |] ==> A <+> B \<subseteq> C <+> D"
by blast

end