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

Well-order relations as needed by bounded natural functors.
*)

section \<open>Well-Order Relations as Needed by Bounded Natural Functors\<close>

theory BNF_Wellorder_Relation
  imports Order_Relation
begin

text\<open>In this section, we develop basic concepts and results pertaining
to well-order relations.  Note that we consider well-order relations
as {\em non-strict relations},
i.e., as containing the diagonals of their fields.\<close>

locale wo_rel =
  fixes r :: "'a rel"
  assumes WELL: "Well_order r"
begin

text\<open>The following context encompasses all this section. In other words,
for the whole section, we consider a fixed well-order relation \<^term>\<open>r\<close>.\<close>

(* context wo_rel  *)

abbreviation under where "under \<equiv> Order_Relation.under r"
abbreviation underS where "underS \<equiv> Order_Relation.underS r"
abbreviation Under where "Under \<equiv> Order_Relation.Under r"
abbreviation UnderS where "UnderS \<equiv> Order_Relation.UnderS r"
abbreviation above where "above \<equiv> Order_Relation.above r"
abbreviation aboveS where "aboveS \<equiv> Order_Relation.aboveS r"
abbreviation Above where "Above \<equiv> Order_Relation.Above r"
abbreviation AboveS where "AboveS \<equiv> Order_Relation.AboveS r"
abbreviation ofilter where "ofilter \<equiv> Order_Relation.ofilter r"
lemmas ofilter_def = Order_Relation.ofilter_def[of r]

subsection \<open>Auxiliaries\<close>

lemma REFL: "Refl r"
  using WELL order_on_defs[of _ r] by auto

lemma TRANS: "trans r"
  using WELL order_on_defs[of _ r] by auto

lemma ANTISYM: "antisym r"
  using WELL order_on_defs[of _ r] by auto

lemma TOTAL: "Total r"
  using WELL order_on_defs[of _ r] by auto

lemma TOTALS: "\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a,b) \<in> r \<or> (b,a) \<in> r"
  using REFL TOTAL refl_on_def[of _ r] total_on_def[of _ r] by force

lemma LIN: "Linear_order r"
  using WELL well_order_on_def[of _ r] by auto

lemma WF: "wf (r - Id)"
  using WELL well_order_on_def[of _ r] by auto

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

lemma cases_Total3:
  "\<And> phi a b. \<lbrakk>{a,b} \<le> Field r; ((a,b) \<in> r - Id \<or> (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>

text\<open>Here we provide induction and recursion principles specific to {\em non-strict}
well-order relations.
Although minor variations of those for well-founded relations, they will be useful
for doing away with the tediousness of
having to take out the diagonal each time in order to switch to a well-founded relation.\<close>

lemma well_order_induct:
  assumes IND: "\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> P y \<Longrightarrow> P x"
  shows "P a"
proof-
  have "\<And>x. \<forall>y. (y, x) \<in> r - Id \<longrightarrow> P y \<Longrightarrow> P x"
    using IND by blast
  thus "P a" using WF wf_induct[of "r - Id" P a] by blast
qed

definition
  worec :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
  where
    "worec F \<equiv> wfrec (r - Id) F"

definition
  adm_wo :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool"
  where
    "adm_wo H \<equiv> \<forall>f g x. (\<forall>y \<in> underS x. f y = g y) \<longrightarrow> H f x = H g x"

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

subsection \<open>The notions of maximum, minimum, supremum, successor and order filter\<close>

text\<open>
We define the successor {\em of a set}, and not of an element (the latter is of course
a particular case).  Also, we define the maximum {\em of two elements}, \<open>max2\<close>,
and the minimum {\em of a set}, \<open>minim\<close> -- we chose these variants since we
consider them the most useful for well-orders.  The minimum is defined in terms of the
auxiliary relational operator \<open>isMinim\<close>.  Then, supremum and successor are
defined in terms of minimum as expected.
The minimum is only meaningful for non-empty sets, and the successor is only
meaningful for sets for which strict upper bounds exist.
Order filters for well-orders are also known as ``initial segments".\<close>

definition max2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "max2 a b \<equiv> if (a,b) \<in> r then b else a"

definition isMinim :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
  where "isMinim A b \<equiv> b \<in> A \<and> (\<forall>a \<in> A. (b,a) \<in> r)"

definition minim :: "'a set \<Rightarrow> 'a"
  where "minim A \<equiv> THE b. isMinim A b"

definition supr :: "'a set \<Rightarrow> 'a"
  where "supr A \<equiv> minim (Above A)"

definition suc :: "'a set \<Rightarrow> 'a"
  where "suc A \<equiv> minim (AboveS A)"

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

lemma max2_greater_among:
  assumes "a \<in> Field r" and "b \<in> Field r"
  shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r \<and> max2 a b \<in> {a,b}"
proof-
  {assume "(a,b) \<in> r"
    hence ?thesis using max2_def assms REFL refl_on_def
      by (auto simp add: refl_on_def)
  }
  moreover
  {assume "a = b"
    hence "(a,b) \<in> r" using REFL  assms
      by (auto simp add: refl_on_def)
  }
  moreover
  {assume *: "a \<noteq> b \<and> (b,a) \<in> r"
    hence "(a,b) \<notin> r" using ANTISYM
      by (auto simp add: antisym_def)
    hence ?thesis using * max2_def assms REFL refl_on_def
      by (auto simp add: refl_on_def)
  }
  ultimately show ?thesis using assms TOTAL
      total_on_def[of "Field r" r] by blast
qed

lemma max2_greater:
  assumes "a \<in> Field r" and "b \<in> Field r"
  shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r"
  using assms by (auto simp add: max2_greater_among)

lemma max2_among:
  assumes "a \<in> Field r" and "b \<in> Field r"
  shows "max2 a b \<in> {a, b}"
  using assms max2_greater_among[of a b] by simp

lemma max2_equals1:
  assumes "a \<in> Field r" and "b \<in> Field r"
  shows "(max2 a b = a) = ((b,a) \<in> r)"
  using assms ANTISYM unfolding antisym_def using TOTALS
  by(auto simp add: max2_def max2_among)

lemma max2_equals2:
  assumes "a \<in> Field r" and "b \<in> Field r"
  shows "(max2 a b = b) = ((a,b) \<in> r)"
  using assms ANTISYM unfolding antisym_def using TOTALS
  unfolding max2_def by auto

lemma in_notinI:
  assumes "(j,i) \<notin> r \<or> j = i" and "i \<in> Field r" and "j \<in> Field r"
  shows "(i,j) \<in> r" using assms max2_def max2_greater_among by fastforce

subsubsection \<open>Existence and uniqueness for isMinim and well-definedness of minim\<close>

lemma isMinim_unique:
  assumes "isMinim B a" "isMinim B a'"
  shows "a = a'"
  using assms ANTISYM antisym_def[of r] by (auto simp: isMinim_def)

lemma Well_order_isMinim_exists:
  assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
  shows "\<exists>b. isMinim B b"
proof-
  from spec[OF WF[unfolded wf_eq_minimal[of "r - Id"]], of B] NE obtain b where
    *: "b \<in> B \<and> (\<forall>b'. b' \<noteq> b \<and> (b',b) \<in> r \<longrightarrow> b' \<notin> B)" by auto
  have "\<forall>b'. b' \<in> B \<longrightarrow> (b, b') \<in> r"
  proof
    fix b'
    show "b' \<in> B \<longrightarrow> (b, b') \<in> r"
    proof
      assume As: "b' \<in> B"
      hence **: "b \<in> Field r \<and> b' \<in> Field r" using As SUB * by auto
      from As  * have "b' = b \<or> (b',b) \<notin> r" by auto
      moreover have "b' = b \<Longrightarrow> (b, b') \<in> r"
        using ** REFL by (auto simp add: refl_on_def)
      moreover have "b' \<noteq> b \<and> (b',b) \<notin> r \<Longrightarrow> (b,b') \<in> r"
        using ** TOTAL by (auto simp add: total_on_def)
      ultimately show "(b,b') \<in> r" by blast
    qed
  qed
  then show ?thesis
    unfolding isMinim_def using * by auto
qed

lemma minim_isMinim:
  assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
  shows "isMinim B (minim B)"
proof-
  let ?phi = "(\<lambda> b. isMinim B b)"
  from assms Well_order_isMinim_exists
  obtain b where *: "?phi b" by blast
  moreover
  have "\<And> b'. ?phi b' \<Longrightarrow> b' = b"
    using isMinim_unique * by auto
  ultimately show ?thesis
    unfolding minim_def using theI[of ?phi b] by blast
qed

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

lemma minim_in:
  assumes "B \<le> Field r" and "B \<noteq> {}"
  shows "minim B \<in> B"
  using assms minim_isMinim[of B] by (auto simp: isMinim_def)

lemma minim_inField:
  assumes "B \<le> Field r" and "B \<noteq> {}"
  shows "minim B \<in> Field r"
proof-
  have "minim B \<in> B" using assms by (simp add: minim_in)
  thus ?thesis using assms by blast
qed

lemma minim_least:
  assumes  SUB: "B \<le> Field r" and IN: "b \<in> B"
  shows "(minim B, b) \<in> r"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by auto
  thus ?thesis by (auto simp add: isMinim_def IN)
qed

lemma equals_minim:
  assumes SUB: "B \<le> Field r" and IN: "a \<in> B" and
    LEAST: "\<And> b. b \<in> B \<Longrightarrow> (a,b) \<in> r"
  shows "a = minim B"
proof-
  from minim_isMinim[of B] assms
  have "isMinim B (minim B)" by auto
  moreover have "isMinim B a" using IN LEAST isMinim_def by auto
  ultimately show ?thesis
    using isMinim_unique by auto
qed

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

lemma suc_AboveS:
  assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}"
  shows "suc B \<in> AboveS B"
proof(unfold suc_def)
  have "AboveS B \<le> Field r"
    using AboveS_Field[of r] by auto
  thus "minim (AboveS B) \<in> AboveS B"
    using assms by (simp add: minim_in)
qed

lemma suc_greater:
  assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}" and IN: "b \<in> B"
  shows "suc B \<noteq> b \<and> (b,suc B) \<in> r"
  using IN AboveS_def[of r] assms suc_AboveS by auto

lemma suc_least_AboveS:
  assumes ABOVES: "a \<in> AboveS B"
  shows "(suc B,a) \<in> r"
  using assms minim_least AboveS_Field[of r] by (auto simp: suc_def)

lemma suc_inField:
  assumes "B \<le> Field r" and "AboveS B \<noteq> {}"
  shows "suc B \<in> Field r"
  using suc_AboveS assms AboveS_Field[of r] by auto

lemma equals_suc_AboveS:
  assumes "B \<le> Field r" and "a \<in> AboveS B" and "\<And> a'. a' \<in> AboveS B \<Longrightarrow> (a,a') \<in> r"
  shows "a = suc B"
  using assms equals_minim AboveS_Field[of r B] by (auto simp: suc_def)

lemma suc_underS:
  assumes IN: "a \<in> Field r"
  shows "a = suc (underS a)"
proof-
  have "underS a \<le> Field r"
    using underS_Field[of r] by auto
  moreover
  have "a \<in> AboveS (underS a)"
    using in_AboveS_underS IN by fast
  moreover
  have "\<forall>a' \<in> AboveS (underS a). (a,a') \<in> r"
  proof(clarify)
    fix a'
    assume *: "a' \<in> AboveS (underS a)"
    hence **: "a' \<in> Field r"
      using AboveS_Field by fast
    {assume "(a,a') \<notin> r"
      hence "a' = a \<or> (a',a) \<in> r"
        using TOTAL IN ** by (auto simp add: total_on_def)
      moreover
      {assume "a' = a"
        hence "(a,a') \<in> r"
          using REFL IN ** by (auto simp add: refl_on_def)
      }
      moreover
      {assume "a' \<noteq> a \<and> (a',a) \<in> r"
        hence "a' \<in> underS a"
          unfolding underS_def by simp
        hence "a' \<notin> AboveS (underS a)"
          using AboveS_disjoint by fast
        with * have False by simp
      }
      ultimately have "(a,a') \<in> r" by blast
    }
    thus  "(a, a') \<in> r" by blast
  qed
  ultimately show ?thesis
    using equals_suc_AboveS by auto
qed

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

lemma under_ofilter: "ofilter (under a)"
  using TRANS by (auto simp: ofilter_def under_def Field_iff trans_def)

lemma underS_ofilter: "ofilter (underS a)"
  unfolding ofilter_def underS_def under_def
proof safe
  fix b assume "(a, b) \<in> r" "(b, a) \<in> r" and DIFF: "b \<noteq> a"
  thus False
    using ANTISYM antisym_def[of r] by blast
next
  fix b x
  assume "(b,a) \<in> r" "b \<noteq> a" "(x,b) \<in> r"
  thus "(x,a) \<in> r"
    using TRANS trans_def[of r] by blast
next
  fix x
  assume "x \<noteq> a" and "(x, a) \<in> r"
  then show "x \<in> Field r"
    unfolding Field_def
    by auto
qed

lemma Field_ofilter:
  "ofilter (Field r)"
  by(unfold ofilter_def under_def, auto simp add: Field_def)

lemma ofilter_underS_Field:
  "ofilter A = ((\<exists>a \<in> Field r. A = underS a) \<or> (A = Field r))"
proof
  assume "(\<exists>a\<in>Field r. A = underS a) \<or> A = Field r"
  thus "ofilter A"
    by (auto simp: underS_ofilter Field_ofilter)
next
  assume *: "ofilter A"
  let ?One = "(\<exists>a\<in>Field r. A = underS a)"
  let ?Two = "(A = Field r)"
  show "?One \<or> ?Two"
  proof(cases ?Two)
    let ?B = "(Field r) - A"
    let ?a = "minim ?B"
    assume "A \<noteq> Field r"
    moreover have "A \<le> Field r" using * ofilter_def by simp
    ultimately have 1: "?B \<noteq> {}" by blast
    hence 2: "?a \<in> Field r" using minim_inField[of ?B] by blast
    have 3: "?a \<in> ?B" using minim_in[of ?B] 1 by blast
    hence 4: "?a \<notin> A" by blast
    have 5: "A \<le> Field r" using * ofilter_def by auto
        (*  *)
    moreover
    have "A = underS ?a"
    proof
      show "A \<le> underS ?a"
      proof
        fix x assume **: "x \<in> A"
        hence 11: "x \<in> Field r" using 5 by auto
        have 12: "x \<noteq> ?a" using 4 ** by auto
        have 13: "under x \<le> A" using * ofilter_def ** by auto
        {assume "(x,?a) \<notin> r"
          hence "(?a,x) \<in> r"
            using TOTAL total_on_def[of "Field r" r]
              2 4 11 12 by auto
          hence "?a \<in> under x" using under_def[of r] by auto
          hence "?a \<in> A" using ** 13 by blast
          with 4 have False by simp
        }
        then have "(x,?a) \<in> r" by blast
        thus "x \<in> underS ?a"
          unfolding underS_def by (auto simp add: 12)
      qed
    next
      show "underS ?a \<le> A"
      proof
        fix x
        assume **: "x \<in> underS ?a"
        hence 11: "x \<in> Field r"
          using Field_def unfolding underS_def by fastforce
        {assume "x \<notin> A"
          hence "x \<in> ?B" using 11 by auto
          hence "(?a,x) \<in> r" using 3 minim_least[of ?B x] by blast
          hence False
            using ANTISYM antisym_def[of r] ** unfolding underS_def by auto
        }
        thus "x \<in> A" by blast
      qed
    qed
    ultimately have ?One using 2 by blast
    thus ?thesis by simp
  next
    assume "A = Field r"
    then show ?thesis
      by simp
  qed
qed

lemma ofilter_UNION:
  "(\<And> i. i \<in> I \<Longrightarrow> ofilter(A i)) \<Longrightarrow> ofilter (\<Union>i \<in> I. A i)"
  unfolding ofilter_def by blast

lemma ofilter_under_UNION:
  assumes "ofilter A"
  shows "A = (\<Union>a \<in> A. under a)"
proof
  have "\<forall>a \<in> A. under a \<le> A"
    using assms ofilter_def by auto
  thus "(\<Union>a \<in> A. under a) \<le> A" by blast
next
  have "\<forall>a \<in> A. a \<in> under a"
    using REFL Refl_under_in[of r] assms ofilter_def[of A] by blast
  thus "A \<le> (\<Union>a \<in> A. under a)" by blast
qed

subsubsection\<open>Other properties\<close>

lemma ofilter_linord:
  assumes OF1: "ofilter A" and OF2: "ofilter B"
  shows "A \<le> B \<or> B \<le> A"
proof(cases "A = Field r")
  assume Case1: "A = Field r"
  hence "B \<le> A" using OF2 ofilter_def by auto
  thus ?thesis by simp
next
  assume Case2: "A \<noteq> Field r"
  with ofilter_underS_Field OF1 obtain a where
    1: "a \<in> Field r \<and> A = underS a" by auto
  show ?thesis
  proof(cases "B = Field r")
    assume Case21: "B = Field r"
    hence "A \<le> B" using OF1 ofilter_def by auto
    thus ?thesis by simp
  next
    assume Case22: "B \<noteq> Field r"
    with ofilter_underS_Field OF2 obtain b where
      2: "b \<in> Field r \<and> B = underS b" by auto
    have "a = b \<or> (a,b) \<in> r \<or> (b,a) \<in> r"
      using 1 2 TOTAL total_on_def[of _ r] by auto
    moreover
    {assume "a = b" with 1 2 have ?thesis by auto
    }
    moreover
    {assume "(a,b) \<in> r"
      with underS_incr[of r] TRANS ANTISYM 1 2
      have "A \<le> B" by auto
      hence ?thesis by auto
    }
    moreover
    {assume "(b,a) \<in> r"
      with underS_incr[of r] TRANS ANTISYM 1 2
      have "B \<le> A" by auto
      hence ?thesis by auto
    }
    ultimately show ?thesis by blast
  qed
qed

lemma ofilter_AboveS_Field:
  assumes "ofilter A"
  shows "A \<union> (AboveS A) = Field r"
proof
  show "A \<union> (AboveS A) \<le> Field r"
    using assms ofilter_def AboveS_Field[of r] by auto
next
  {fix x assume *: "x \<in> Field r" and **: "x \<notin> A"
    {fix y assume ***: "y \<in> A"
      with ** have 1: "y \<noteq> x" by auto
      {assume "(y,x) \<notin> r"
        moreover
        have "y \<in> Field r" using assms ofilter_def *** by auto
        ultimately have "(x,y) \<in> r"
          using 1 * TOTAL total_on_def[of _ r] by auto
        with *** assms ofilter_def under_def[of r] have "x \<in> A" by auto
        with ** have False by contradiction
      }
      hence "(y,x) \<in> r" by blast
      with 1 have "y \<noteq> x \<and> (y,x) \<in> r" by auto
    }
    with * have "x \<in> AboveS A" unfolding AboveS_def by auto
  }
  thus "Field r \<le> A \<union> (AboveS A)" by blast
qed

lemma suc_ofilter_in:
  assumes OF: "ofilter A" and ABOVE_NE: "AboveS A \<noteq> {}" and
    REL: "(b,suc A) \<in> r" and DIFF: "b \<noteq> suc A"
  shows "b \<in> A"
proof-
  have *: "suc A \<in> Field r \<and> b \<in> Field r"
    using WELL REL well_order_on_domain[of "Field r"] by auto
  {assume **: "b \<notin> A"
    hence "b \<in> AboveS A"
      using OF * ofilter_AboveS_Field by auto
    hence "(suc A, b) \<in> r"
      using suc_least_AboveS by auto
    hence False using REL DIFF ANTISYM *
      by (auto simp add: antisym_def)
  }
  thus ?thesis by blast
qed

end (* context wo_rel *)

end


section"Injectivity for two argument functions"

theory Common_Lemmas
  imports
  "HOL.List"
  "HOL-Library.Tree"
begin

text \<open>This section introduces @{term "inj2_on"} which generalizes @{term "inj_on"} on curried
functions with two arguments and contains subsequent theorems about such functions.\<close>

text"
We could use curried function directly with for example \<open>case_prod\<close>,
but this way the proofs become simpler and easier to read."
definition inj2_on :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool" where
  "inj2_on f A B \<longleftrightarrow> (\<forall>x1\<in>A. \<forall>x2\<in>A. \<forall>y1\<in>B. \<forall>y2\<in>B. f x1 y1 = f x2 y2 \<longrightarrow> x1 = x2 \<and> y1 = y2)"

abbreviation inj2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> bool" where
  "inj2 f \<equiv> inj2_on f UNIV UNIV"

subsection \<open>Correspondence between @{term "inj2_on"} and @{term "inj_on"}\<close>

lemma inj2_curried: "inj2_on (curry f) A B \<longleftrightarrow> inj_on f (A\<times>B)"
  unfolding inj2_on_def inj_on_def by auto

lemma inj2_on_all: "inj2 f \<Longrightarrow> inj2_on f A B"
  unfolding inj2_on_def by simp

lemma inj2_inj_first: "inj2 f \<Longrightarrow> inj f"
  unfolding inj2_on_def inj_on_def by simp

lemma inj2_inj_second: "inj2 f \<Longrightarrow> inj (f x)"
  unfolding inj2_on_def inj_on_def by simp

lemma inj2_inj_second_flipped: "inj2 f \<Longrightarrow> inj (\<lambda>x. f x y)"
  unfolding inj2_on_def inj_on_def by simp

subsection"Proofs with inj2"

text\<open>Already existing for @{term "inj"}:\<close>
thm distinct_map

lemma inj2_on_distinct_map:
  assumes "inj2_on f {x} (set xs)"
  shows "distinct xs = distinct (map (f x) xs)"
  using assms distinct_map by (auto simp: inj2_on_def inj_onI)

lemma inj2_distinct_map:
  assumes "inj2 f"
  shows "distinct xs = distinct (map (f x) xs)"
  using assms inj2_on_distinct_map inj2_on_all by fast

lemma inj2_on_distinct_concat_map:
  assumes "inj2_on f (set xs) (set ys)"
  shows "\<lbrakk>distinct ys; distinct xs\<rbrakk> \<Longrightarrow> distinct [f x y. x \<leftarrow> xs, y \<leftarrow> ys]"
using assms proof(induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then have nin: "x \<notin> set xs"
    by simp

  then have "inj2_on f {x} (set ys)"
    using Cons unfolding inj2_on_def by simp
  then have 1: "distinct (map (f x) ys)"
    using Cons inj2_on_distinct_map by fastforce

  have 2: "distinct (concat (map (\<lambda>x. map (f x) ys) xs))"
    using Cons unfolding inj2_on_def by simp

  have 3: "\<lbrakk>xa \<in> set xs; xb \<in> set ys; f x xb = f xa xc; xc \<in> set ys\<rbrakk> \<Longrightarrow> False " for xa xb xc
    using Cons(4) unfolding inj2_on_def
    using nin by force

  from 1 2 3 show ?case
    by auto
qed

lemma inj2_distinct_concat_map:
  assumes "inj2 f"
  shows "\<lbrakk>distinct ys; distinct xs\<rbrakk> \<Longrightarrow> distinct [f x y. x \<leftarrow> xs, y \<leftarrow> ys]"
  using assms inj2_on_all inj2_on_distinct_concat_map by blast

lemma inj2_distinct_concat_map_function:
  assumes "inj2 f"
  shows"\<lbrakk>\<forall> x \<in> set xs. distinct (g x); distinct xs\<rbrakk> \<Longrightarrow> distinct [f x y. x \<leftarrow> xs, y \<leftarrow> g x]"
proof(induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  have 1: "distinct (map (f x) (g x))"
    using Cons assms inj2_distinct_map by fastforce

  have 2: "distinct (concat (map (\<lambda>x. map (f x) (g x)) xs))"
    using Cons by simp

  have 3: "\<And>xa xb xc. \<lbrakk>xa \<in> set xs; xb \<in> set (g x); f x xb = f xa xc; xc \<in> set (g xa)\<rbrakk>
      \<Longrightarrow> False"
    using Cons assms unfolding inj2_on_def by auto

   show ?case using 1 2 3
    by auto
qed

lemma distinct_concat_Nil: "distinct (concat (map (\<lambda>y. []) xs))"
  by(induct xs) auto

lemma inj2_distinct_concat_map_function_filter:
  assumes "inj2 f"
  shows"\<lbrakk>\<forall> x \<in> set xs. distinct (g x); distinct xs\<rbrakk> \<Longrightarrow> distinct [f x y. x \<leftarrow> xs, y \<leftarrow> g x, h x]"
proof(induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  have 1: "distinct (map (f x) (g x))"
    using Cons assms inj2_distinct_map by fastforce

  have 2: "distinct (concat (map (\<lambda>x. concat (map (\<lambda>y. if h x then [f x y] else []) (g x))) xs))"
    using Cons by simp

  have 3: "\<And>xa xb xc.
       \<lbrakk>h x; xa \<in> set (g x); xb \<in> set xs; f x xa = f xb xc; xc \<in> set (g xb); xc \<in> (if h xb then UNIV else {})\<rbrakk> \<Longrightarrow> False"
    by (metis Cons.prems(2) assms distinct.simps(2) inj2_on_def iso_tuple_UNIV_I)

  then have 4: "distinct (concat (map (\<lambda>y. []) (g x)))"
    using distinct_concat_Nil by auto

  show ?case using 1 2 3 4 by auto
qed

subsection\<open>Specializations of @{term "inj2"}\<close>

subsubsection"Cons"

lemma Cons_inj2: "inj2 (#)"
  unfolding inj2_on_def by simp

lemma Cons_distinct_concat_map: "\<lbrakk>distinct ys; distinct xs\<rbrakk> \<Longrightarrow> distinct [x#y. x \<leftarrow> xs, y \<leftarrow> ys]"
  using inj2_distinct_concat_map Cons_inj2 by auto

lemma Cons_distinct_concat_map_function:
  "\<lbrakk>\<forall> x \<in> set xs. distinct (g x) ; distinct xs\<rbrakk> \<Longrightarrow> distinct [x # y. x \<leftarrow> xs, y \<leftarrow> g x]"
  using inj2_distinct_concat_map_function Cons_inj2 by auto

lemma Cons_distinct_concat_map_function_distinct_on_all:
  "\<lbrakk>\<forall> x. distinct (g x) ; distinct xs\<rbrakk> \<Longrightarrow> distinct [x # y. x \<leftarrow> xs, y \<leftarrow> g x]"
  using Cons_distinct_concat_map_function by (metis (full_types))

subsubsection"Node right"

lemma Node_right_inj2: "inj2 (\<lambda>l r. Node l e r)"
  unfolding inj2_on_def by simp

lemma Node_right_distinct_concat_map:
  "\<lbrakk>distinct ys; distinct xs\<rbrakk> \<Longrightarrow> distinct [Node x e y. x \<leftarrow> xs, y \<leftarrow> ys]"
  using inj2_distinct_concat_map Node_right_inj2 by fast

subsubsection"Node left"

lemma Node_left_inj2: "inj2 (\<lambda>r l. Node l e r)"
  unfolding inj2_on_def by simp

lemma Node_left_distinct_map: "distinct xs = distinct (map (\<lambda>l. \<langle>l, (), r\<rangle>) xs)"
  using inj2_distinct_map Node_left_inj2 by fast

subsubsection"Cons Suc"

lemma Cons_Suc_inj2: "inj2 (\<lambda>x ys. Suc x # ys)"
  unfolding inj2_on_def by simp

lemma Cons_Suc_distinct_concat_map_function:
  "\<lbrakk>\<forall> x \<in> set xs. distinct (g x) ; distinct xs\<rbrakk> \<Longrightarrow> distinct [Suc x # y. x \<leftarrow> xs, y \<leftarrow> g x]"
  using inj2_distinct_concat_map_function Cons_Suc_inj2 by auto

section"Lemmas for cardinality proofs "

lemma length_concat_map: "length [f x r . x \<leftarrow> xs, r \<leftarrow> ys] = length ys * length xs"
  by(induct xs arbitrary: ys) auto

text"An useful extension to \<open>length_concat\<close>"
thm length_concat
lemma length_concat_map_function_sum_list:
  assumes "\<And> x. x \<in> set xs \<Longrightarrow> length (g x) = h x"
  shows "length [f x r . x \<leftarrow> xs, r \<leftarrow> g x] = sum_list (map h xs)"
  using assms by(induct xs) auto

lemma sum_list_extract_last: "(\<Sum>x\<leftarrow>[0..<Suc n]. f x) = (\<Sum>x\<leftarrow>[0..<n]. f x) + f n"
  by(induct n) (auto simp: add.assoc)

lemma leq_sum_to_sum_list: "(\<Sum>x \<le> n. f x) = (\<Sum>x\<leftarrow>[0..<Suc n]. f x)"
  by (metis atMost_upto sum_set_upt_conv_sum_list_nat)

lemma less_sum_to_sum_list: "(\<Sum>x < n. f x) = (\<Sum>x\<leftarrow>[0..< n]. f x)"
  by (simp add: atLeast_upt sum_list_distinct_conv_sum_set)

section"Miscellaneous"

text\<open>Similar to @{thm [source] "length_remove1"}:\<close>
lemma Suc_length_remove1: "x \<in> set xs \<Longrightarrow> Suc (length (remove1 x xs)) = length xs"
  by(induct xs) auto

subsection"\<open>count_list\<close> and replicate"
text"HOL.List doesn't have many lemmas about \<open>count_list\<close> (when not using multisets)"

lemma count_list_replicate: "count_list (replicate x y) y = x"
  by (induct x) auto

lemma count_list_full_elem: "count_list xs y = length xs \<longleftrightarrow> (\<forall>x \<in> set xs. x = y)"
proof(induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons z xs)
  have "\<lbrakk>count_list xs y = Suc (length xs); x \<in> set xs\<rbrakk> \<Longrightarrow> x = y" for x
    by (metis Suc_n_not_le_n count_le_length)
  then show ?case
    using Cons by auto
qed

text\<open>The following lemma verifies the reverse of @{thm [source] "count_notin"}:\<close>
thm count_notin
lemma count_list_zero_not_elem: "count_list xs x = 0 \<longleftrightarrow> x \<notin> set xs"
  by(induct xs) auto

lemma count_list_length_replicate: "count_list xs y = length xs \<longleftrightarrow> xs = replicate (length xs) y"
  by (metis count_list_full_elem count_list_replicate replicate_length_same)

lemma count_list_True_False: "count_list xs True + count_list xs False = length xs"
  by(induct xs) auto

end


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

section\<open>Arithmetic with simplification\<close>

theory ArithSimp
imports Arith
begin

ML_file \<open>~~/src/Provers/Arith/cancel_numerals.ML\<close>
ML_file \<open>~~/src/Provers/Arith/combine_numerals.ML\<close>
ML_file \<open>arith_data.ML\<close>

subsection\<open>Difference\<close>

lemma diff_self_eq_0 [simp]: "m #- m = 0"
apply (subgoal_tac "natify (m) #- natify (m) = 0")
apply (rule_tac [2] natify_in_nat [THEN nat_induct], auto)
done

(**Addition is the inverse of subtraction**)

(*We need m:nat even if we replace the RHS by natify(m), for consider e.g.
  n=2, m=omega; then n + (m-n) = 2 + (0-2) = 2 \<noteq> 0 = natify(m).*)
lemma add_diff_inverse: "[| n \<le> m;  m:nat |] ==> n #+ (m#-n) = m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct, auto)
done

lemma add_diff_inverse2: "[| n \<le> m;  m:nat |] ==> (m#-n) #+ n = m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (simp (no_asm_simp) add: add_commute add_diff_inverse)
done

(*Proof is IDENTICAL to that of add_diff_inverse*)
lemma diff_succ: "[| n \<le> m;  m:nat |] ==> succ(m) #- n = succ(m#-n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp))
done

lemma zero_less_diff [simp]:
     "[| m: nat; n: nat |] ==> 0 < (n #- m)   \<longleftrightarrow>   m<n"
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp))
done

(** Difference distributes over multiplication **)

lemma diff_mult_distrib: "(m #- n) #* k = (m #* k) #- (n #* k)"
apply (subgoal_tac " (natify (m) #- natify (n)) #* natify (k) = (natify (m) #* natify (k)) #- (natify (n) #* natify (k))")
apply (rule_tac [2] m = "natify (m) " and n = "natify (n) " in diff_induct)
apply (simp_all add: diff_cancel)
done

lemma diff_mult_distrib2: "k #* (m #- n) = (k #* m) #- (k #* n)"
apply (simp (no_asm) add: mult_commute [of k] diff_mult_distrib)
done

subsection\<open>Remainder\<close>

(*We need m:nat even with natify*)
lemma div_termination: "[| 0<n;  n \<le> m;  m:nat |] ==> m #- n < m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp) add: diff_le_self)
done

(*for mod and div*)
lemmas div_rls =
    nat_typechecks Ord_transrec_type apply_funtype
    div_termination [THEN ltD]
    nat_into_Ord not_lt_iff_le [THEN iffD1]

lemma raw_mod_type: "[| m:nat;  n:nat |] ==> raw_mod (m, n) \<in> nat"
apply (unfold raw_mod_def)
apply (rule Ord_transrec_type)
apply (auto simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (blast intro: div_rls)
done

lemma mod_type [TC,iff]: "m mod n \<in> nat"
apply (unfold mod_def)
apply (simp (no_asm) add: mod_def raw_mod_type)
done

(** Aribtrary definitions for division by zero.  Useful to simplify
    certain equations **)

lemma DIVISION_BY_ZERO_DIV: "a div 0 = 0"
apply (unfold div_def)
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp))
done  (*NOT for adding to default simpset*)

lemma DIVISION_BY_ZERO_MOD: "a mod 0 = natify(a)"
apply (unfold mod_def)
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp))
done  (*NOT for adding to default simpset*)

lemma raw_mod_less: "m<n ==> raw_mod (m,n) = m"
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD])
done

lemma mod_less [simp]: "[| m<n; n \<in> nat |] ==> m mod n = m"
apply (frule lt_nat_in_nat, assumption)
apply (simp (no_asm_simp) add: mod_def raw_mod_less)
done

lemma raw_mod_geq:
     "[| 0<n; n \<le> m;  m:nat |] ==> raw_mod (m, n) = raw_mod (m#-n, n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD] not_lt_iff_le [THEN iffD2], blast)
done

lemma mod_geq: "[| n \<le> m;  m:nat |] ==> m mod n = (m#-n) mod n"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: mod_def raw_mod_geq nat_into_Ord [THEN Ord_0_lt_iff])
done

subsection\<open>Division\<close>

lemma raw_div_type: "[| m:nat;  n:nat |] ==> raw_div (m, n) \<in> nat"
apply (unfold raw_div_def)
apply (rule Ord_transrec_type)
apply (auto simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (blast intro: div_rls)
done

lemma div_type [TC,iff]: "m div n \<in> nat"
apply (unfold div_def)
apply (simp (no_asm) add: div_def raw_div_type)
done

lemma raw_div_less: "m<n ==> raw_div (m,n) = 0"
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD])
done

lemma div_less [simp]: "[| m<n; n \<in> nat |] ==> m div n = 0"
apply (frule lt_nat_in_nat, assumption)
apply (simp (no_asm_simp) add: div_def raw_div_less)
done

lemma raw_div_geq: "[| 0<n;  n \<le> m;  m:nat |] ==> raw_div(m,n) = succ(raw_div(m#-n, n))"
apply (subgoal_tac "n \<noteq> 0")
prefer 2 apply blast
apply (frule lt_nat_in_nat, erule nat_succI)
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD] not_lt_iff_le [THEN iffD2] )
done

lemma div_geq [simp]:
     "[| 0<n;  n \<le> m;  m:nat |] ==> m div n = succ ((m#-n) div n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (simp (no_asm_simp) add: div_def raw_div_geq)
done

declare div_less [simp] div_geq [simp]

(*A key result*)
lemma mod_div_lemma: "[| m: nat;  n: nat |] ==> (m div n)#*n #+ m mod n = m"
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (erule complete_induct)
apply (case_tac "x<n")
txt\<open>case x<n\<close>
apply (simp (no_asm_simp))
txt\<open>case \<^term>\<open>n \<le> x\<close>\<close>
apply (simp add: not_lt_iff_le add_assoc mod_geq div_termination [THEN ltD] add_diff_inverse)
done

lemma mod_div_equality_natify: "(m div n)#*n #+ m mod n = natify(m)"
apply (subgoal_tac " (natify (m) div natify (n))#*natify (n) #+ natify (m) mod natify (n) = natify (m) ")
apply force
apply (subst mod_div_lemma, auto)
done

lemma mod_div_equality: "m: nat ==> (m div n)#*n #+ m mod n = m"
apply (simp (no_asm_simp) add: mod_div_equality_natify)
done

subsection\<open>Further Facts about Remainder\<close>

text\<open>(mainly for mutilated chess board)\<close>

lemma mod_succ_lemma:
     "[| 0<n;  m:nat;  n:nat |]
      ==> succ(m) mod n = (if succ(m mod n) = n then 0 else succ(m mod n))"
apply (erule complete_induct)
apply (case_tac "succ (x) <n")
txt\<open>case succ(x) < n\<close>
 apply (simp (no_asm_simp) add: nat_le_refl [THEN lt_trans] succ_neq_self)
 apply (simp add: ltD [THEN mem_imp_not_eq])
txt\<open>case \<^term>\<open>n \<le> succ(x)\<close>\<close>
apply (simp add: mod_geq not_lt_iff_le)
apply (erule leE)
 apply (simp (no_asm_simp) add: mod_geq div_termination [THEN ltD] diff_succ)
txt\<open>equality case\<close>
apply (simp add: diff_self_eq_0)
done

lemma mod_succ:
  "n:nat ==> succ(m) mod n = (if succ(m mod n) = n then 0 else succ(m mod n))"
apply (case_tac "n=0")
 apply (simp (no_asm_simp) add: natify_succ DIVISION_BY_ZERO_MOD)
apply (subgoal_tac "natify (succ (m)) mod n = (if succ (natify (m) mod n) = n then 0 else succ (natify (m) mod n))")
 prefer 2
 apply (subst natify_succ)
 apply (rule mod_succ_lemma)
  apply (auto simp del: natify_succ simp add: nat_into_Ord [THEN Ord_0_lt_iff])
done

lemma mod_less_divisor: "[| 0<n;  n:nat |] ==> m mod n < n"
apply (subgoal_tac "natify (m) mod n < n")
apply (rule_tac [2] i = "natify (m) " in complete_induct)
apply (case_tac [3] "x<n", auto)
txt\<open>case \<^term>\<open>n \<le> x\<close>\<close>
apply (simp add: mod_geq not_lt_iff_le div_termination [THEN ltD])
done

lemma mod_1_eq [simp]: "m mod 1 = 0"
by (cut_tac n = 1 in mod_less_divisor, auto)

lemma mod2_cases: "b<2 ==> k mod 2 = b | k mod 2 = (if b=1 then 0 else 1)"
apply (subgoal_tac "k mod 2: 2")
 prefer 2 apply (simp add: mod_less_divisor [THEN ltD])
apply (drule ltD, auto)
done

lemma mod2_succ_succ [simp]: "succ(succ(m)) mod 2 = m mod 2"
apply (subgoal_tac "m mod 2: 2")
 prefer 2 apply (simp add: mod_less_divisor [THEN ltD])
apply (auto simp add: mod_succ)
done

lemma mod2_add_more [simp]: "(m#+m#+n) mod 2 = n mod 2"
apply (subgoal_tac " (natify (m) #+natify (m) #+n) mod 2 = n mod 2")
apply (rule_tac [2] n = "natify (m) " in nat_induct)
apply auto
done

lemma mod2_add_self [simp]: "(m#+m) mod 2 = 0"
by (cut_tac n = 0 in mod2_add_more, auto)

subsection\<open>Additional theorems about \<open>\<le>\<close>\<close>

lemma add_le_self: "m:nat ==> m \<le> (m #+ n)"
apply (simp (no_asm_simp))
done

lemma add_le_self2: "m:nat ==> m \<le> (n #+ m)"
apply (simp (no_asm_simp))
done

(*** Monotonicity of Multiplication ***)

lemma mult_le_mono1: "[| i \<le> j; j:nat |] ==> (i#*k) \<le> (j#*k)"
apply (subgoal_tac "natify (i) #*natify (k) \<le> j#*natify (k) ")
apply (frule_tac [2] lt_nat_in_nat)
apply (rule_tac [3] n = "natify (k) " in nat_induct)
apply (simp_all add: add_le_mono)
done

(* @{text"\<le>"} monotonicity, BOTH arguments*)
lemma mult_le_mono: "[| i \<le> j; k \<le> l; j:nat; l:nat |] ==> i#*k \<le> j#*l"
apply (rule mult_le_mono1 [THEN le_trans], assumption+)
apply (subst mult_commute, subst mult_commute, rule mult_le_mono1, assumption+)
done

(*strict, in 1st argument; proof is by induction on k>0.
  I can't see how to relax the typing conditions.*)
lemma mult_lt_mono2: "[| i<j; 0<k; j:nat; k:nat |] ==> k#*i < k#*j"
apply (erule zero_lt_natE)
apply (frule_tac [2] lt_nat_in_nat)
apply (simp_all (no_asm_simp))
apply (induct_tac "x")
apply (simp_all (no_asm_simp) add: add_lt_mono)
done

lemma mult_lt_mono1: "[| i<j; 0<k; j:nat; k:nat |] ==> i#*k < j#*k"
apply (simp (no_asm_simp) add: mult_lt_mono2 mult_commute [of _ k])
done

lemma add_eq_0_iff [iff]: "m#+n = 0 \<longleftrightarrow> natify(m)=0 & natify(n)=0"
apply (subgoal_tac "natify (m) #+ natify (n) = 0 \<longleftrightarrow> natify (m) =0 & natify (n) =0")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
apply auto
done

lemma zero_lt_mult_iff [iff]: "0 < m#*n \<longleftrightarrow> 0 < natify(m) & 0 < natify(n)"
apply (subgoal_tac "0 < natify (m) #*natify (n) \<longleftrightarrow> 0 < natify (m) & 0 < natify (n) ")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
  apply (rule_tac [3] n = "natify (n) " in natE)
apply auto
done

lemma mult_eq_1_iff [iff]: "m#*n = 1 \<longleftrightarrow> natify(m)=1 & natify(n)=1"
apply (subgoal_tac "natify (m) #* natify (n) = 1 \<longleftrightarrow> natify (m) =1 & natify (n) =1")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
apply auto
done

lemma mult_is_zero: "[|m: nat; n: nat|] ==> (m #* n = 0) \<longleftrightarrow> (m = 0 | n = 0)"
apply auto
apply (erule natE)
apply (erule_tac [2] natE, auto)
done

lemma mult_is_zero_natify [iff]:
     "(m #* n = 0) \<longleftrightarrow> (natify(m) = 0 | natify(n) = 0)"
apply (cut_tac m = "natify (m) " and n = "natify (n) " in mult_is_zero)
apply auto
done

subsection\<open>Cancellation Laws for Common Factors in Comparisons\<close>

lemma mult_less_cancel_lemma:
     "[| k: nat; m: nat; n: nat |] ==> (m#*k < n#*k) \<longleftrightarrow> (0<k & m<n)"
apply (safe intro!: mult_lt_mono1)
apply (erule natE, auto)
apply (rule not_le_iff_lt [THEN iffD1])
apply (drule_tac [3] not_le_iff_lt [THEN [2] rev_iffD2])
prefer 5 apply (blast intro: mult_le_mono1, auto)
done

lemma mult_less_cancel2 [simp]:
     "(m#*k < n#*k) \<longleftrightarrow> (0 < natify(k) & natify(m) < natify(n))"
apply (rule iff_trans)
apply (rule_tac [2] mult_less_cancel_lemma, auto)
done

lemma mult_less_cancel1 [simp]:
     "(k#*m < k#*n) \<longleftrightarrow> (0 < natify(k) & natify(m) < natify(n))"
apply (simp (no_asm) add: mult_less_cancel2 mult_commute [of k])
done

lemma mult_le_cancel2 [simp]: "(m#*k \<le> n#*k) \<longleftrightarrow> (0 < natify(k) \<longrightarrow> natify(m) \<le> natify(n))"
apply (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])
apply auto
done

lemma mult_le_cancel1 [simp]: "(k#*m \<le> k#*n) \<longleftrightarrow> (0 < natify(k) \<longrightarrow> natify(m) \<le> natify(n))"
apply (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])
apply auto
done

lemma mult_le_cancel_le1: "k \<in> nat ==> k #* m \<le> k \<longleftrightarrow> (0 < k \<longrightarrow> natify(m) \<le> 1)"
by (cut_tac k = k and m = m and n = 1 in mult_le_cancel1, auto)

lemma Ord_eq_iff_le: "[| Ord(m); Ord(n) |] ==> m=n \<longleftrightarrow> (m \<le> n & n \<le> m)"
by (blast intro: le_anti_sym)

lemma mult_cancel2_lemma:
     "[| k: nat; m: nat; n: nat |] ==> (m#*k = n#*k) \<longleftrightarrow> (m=n | k=0)"
apply (simp (no_asm_simp) add: Ord_eq_iff_le [of "m#*k"] Ord_eq_iff_le [of m])
apply (auto simp add: Ord_0_lt_iff)
done

lemma mult_cancel2 [simp]:
     "(m#*k = n#*k) \<longleftrightarrow> (natify(m) = natify(n) | natify(k) = 0)"
apply (rule iff_trans)
apply (rule_tac [2] mult_cancel2_lemma, auto)
done

lemma mult_cancel1 [simp]:
     "(k#*m = k#*n) \<longleftrightarrow> (natify(m) = natify(n) | natify(k) = 0)"
apply (simp (no_asm) add: mult_cancel2 mult_commute [of k])
done

(** Cancellation law for division **)

lemma div_cancel_raw:
     "[| 0<n; 0<k; k:nat; m:nat; n:nat |] ==> (k#*m) div (k#*n) = m div n"
apply (erule_tac i = m in complete_induct)
apply (case_tac "x<n")
 apply (simp add: div_less zero_lt_mult_iff mult_lt_mono2)
apply (simp add: not_lt_iff_le zero_lt_mult_iff le_refl [THEN mult_le_mono]
          div_geq diff_mult_distrib2 [symmetric] div_termination [THEN ltD])
done

lemma div_cancel:
     "[| 0 < natify(n);  0 < natify(k) |] ==> (k#*m) div (k#*n) = m div n"
apply (cut_tac k = "natify (k) " and m = "natify (m)" and n = "natify (n)"
       in div_cancel_raw)
apply auto
done

subsection\<open>More Lemmas about Remainder\<close>

lemma mult_mod_distrib_raw:
     "[| k:nat; m:nat; n:nat |] ==> (k#*m) mod (k#*n) = k #* (m mod n)"
apply (case_tac "k=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (erule_tac i = m in complete_induct)
apply (case_tac "x<n")
 apply (simp (no_asm_simp) add: mod_less zero_lt_mult_iff mult_lt_mono2)
apply (simp add: not_lt_iff_le zero_lt_mult_iff le_refl [THEN mult_le_mono]
         mod_geq diff_mult_distrib2 [symmetric] div_termination [THEN ltD])
done

lemma mod_mult_distrib2: "k #* (m mod n) = (k#*m) mod (k#*n)"
apply (cut_tac k = "natify (k) " and m = "natify (m)" and n = "natify (n)"
       in mult_mod_distrib_raw)
apply auto
done

lemma mult_mod_distrib: "(m mod n) #* k = (m#*k) mod (n#*k)"
apply (simp (no_asm) add: mult_commute mod_mult_distrib2)
done

lemma mod_add_self2_raw: "n \<in> nat ==> (m #+ n) mod n = m mod n"
apply (subgoal_tac " (n #+ m) mod n = (n #+ m #- n) mod n")
apply (simp add: add_commute)
apply (subst mod_geq [symmetric], auto)
done

lemma mod_add_self2 [simp]: "(m #+ n) mod n = m mod n"
apply (cut_tac n = "natify (n) " in mod_add_self2_raw)
apply auto
done

lemma mod_add_self1 [simp]: "(n#+m) mod n = m mod n"
apply (simp (no_asm_simp) add: add_commute mod_add_self2)
done

lemma mod_mult_self1_raw: "k \<in> nat ==> (m #+ k#*n) mod n = m mod n"
apply (erule nat_induct)
apply (simp_all (no_asm_simp) add: add_left_commute [of _ n])
done

lemma mod_mult_self1 [simp]: "(m #+ k#*n) mod n = m mod n"
apply (cut_tac k = "natify (k) " in mod_mult_self1_raw)
apply auto
done

lemma mod_mult_self2 [simp]: "(m #+ n#*k) mod n = m mod n"
apply (simp (no_asm) add: mult_commute mod_mult_self1)
done

(*Lemma for gcd*)
lemma mult_eq_self_implies_10: "m = m#*n ==> natify(n)=1 | m=0"
apply (subgoal_tac "m: nat")
 prefer 2
 apply (erule ssubst)
 apply simp
apply (rule disjCI)
apply (drule sym)
apply (rule Ord_linear_lt [of "natify(n)" 1])
apply simp_all
 apply (subgoal_tac "m #* n = 0", simp)
 apply (subst mult_natify2 [symmetric])
 apply (simp del: mult_natify2)
apply (drule nat_into_Ord [THEN Ord_0_lt, THEN [2] mult_lt_mono2], auto)
done

lemma less_imp_succ_add [rule_format]:
     "[| m<n; n: nat |] ==> \<exists>k\<in>nat. n = succ(m#+k)"
apply (frule lt_nat_in_nat, assumption)
apply (erule rev_mp)
apply (induct_tac "n")
apply (simp_all (no_asm) add: le_iff)
apply (blast elim!: leE intro!: add_0_right [symmetric] add_succ_right [symmetric])
done

lemma less_iff_succ_add:
     "[| m: nat; n: nat |] ==> (m<n) \<longleftrightarrow> (\<exists>k\<in>nat. n = succ(m#+k))"
by (auto intro: less_imp_succ_add)

lemma add_lt_elim2:
     "\<lbrakk>a #+ d = b #+ c; a < b; b \<in> nat; c \<in> nat; d \<in> nat\<rbrakk> \<Longrightarrow> c < d"
by (drule less_imp_succ_add, auto)

lemma add_le_elim2:
     "\<lbrakk>a #+ d = b #+ c; a \<le> b; b \<in> nat; c \<in> nat; d \<in> nat\<rbrakk> \<Longrightarrow> c \<le> d"
by (drule less_imp_succ_add, auto)

subsubsection\<open>More Lemmas About Difference\<close>

lemma diff_is_0_lemma:
     "[| m: nat; n: nat |] ==> m #- n = 0 \<longleftrightarrow> m \<le> n"
apply (rule_tac m = m and n = n in diff_induct, simp_all)
done

lemma diff_is_0_iff: "m #- n = 0 \<longleftrightarrow> natify(m) \<le> natify(n)"
by (simp add: diff_is_0_lemma [symmetric])

lemma nat_lt_imp_diff_eq_0:
     "[| a:nat; b:nat; a<b |] ==> a #- b = 0"
by (simp add: diff_is_0_iff le_iff)

lemma raw_nat_diff_split:
     "[| a:nat; b:nat |] ==>
      (P(a #- b)) \<longleftrightarrow> ((a < b \<longrightarrow>P(0)) & (\<forall>d\<in>nat. a = b #+ d \<longrightarrow> P(d)))"
apply (case_tac "a < b")
 apply (force simp add: nat_lt_imp_diff_eq_0)
apply (rule iffI, force, simp)
apply (drule_tac x="a#-b" in bspec)
apply (simp_all add: Ordinal.not_lt_iff_le add_diff_inverse)
done

lemma nat_diff_split:
   "(P(a #- b)) \<longleftrightarrow>
    (natify(a) < natify(b) \<longrightarrow>P(0)) & (\<forall>d\<in>nat. natify(a) = b #+ d \<longrightarrow> P(d))"
apply (cut_tac P=P and a="natify(a)" and b="natify(b)" in raw_nat_diff_split)
apply simp_all
done

text\<open>Difference and less-than\<close>

lemma diff_lt_imp_lt: "[|(k#-i) < (k#-j); i\<in>nat; j\<in>nat; k\<in>nat|] ==> j<i"
apply (erule rev_mp)
apply (simp split: nat_diff_split, auto)
 apply (blast intro: add_le_self lt_trans1)
apply (rule not_le_iff_lt [THEN iffD1], auto)
apply (subgoal_tac "i #+ da < j #+ d", force)
apply (blast intro: add_le_lt_mono)
done

lemma lt_imp_diff_lt: "[|j<i; i\<le>k; k\<in>nat|] ==> (k#-i) < (k#-j)"
apply (frule le_in_nat, assumption)
apply (frule lt_nat_in_nat, assumption)
apply (simp split: nat_diff_split, auto)
  apply (blast intro: lt_asym lt_trans2)
 apply (blast intro: lt_irrefl lt_trans2)
apply (rule not_le_iff_lt [THEN iffD1], auto)
apply (subgoal_tac "j #+ d < i #+ da", force)
apply (blast intro: add_lt_le_mono)
done

lemma diff_lt_iff_lt: "[|i\<le>k; j\<in>nat; k\<in>nat|] ==> (k#-i) < (k#-j) \<longleftrightarrow> j<i"
apply (frule le_in_nat, assumption)
apply (blast intro: lt_imp_diff_lt diff_lt_imp_lt)
done

end


(*
  File: Coverings.thy
  Author: Bohua Zhan

  Covering by sets and partitions.
*)

theory Coverings
  imports Functions
begin

section \<open>Coverings\<close>  (* Bourbaki II.4.6 *)

definition is_covering :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "is_covering(E,X) \<longleftrightarrow> (\<forall>x\<in>E. \<exists>a\<in>source(X). x \<in> X`a)"

(* Y is finer than X *)
definition finer_covering :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "finer_covering(Y,X) \<longleftrightarrow> (\<forall>b\<in>source(Y). \<exists>a\<in>source(X). Y`b \<subseteq> X`a)"

lemma finer_covering_trans:
  "finer_covering(Z,Y) \<Longrightarrow> finer_covering(Y,X) \<Longrightarrow> finer_covering(Z,X)" by auto2

lemma subset_covering:
  "is_function(X) \<Longrightarrow> is_covering(E,X) \<Longrightarrow> J \<subseteq> source(X) \<Longrightarrow> E \<subseteq> (\<Union>a\<in>J. X`a) \<Longrightarrow>
   is_covering(E, func_restrict(X,J))" by auto2

lemma subset_is_finer:
  "is_function(X) \<Longrightarrow> J \<subseteq> source(X) \<Longrightarrow> finer_covering(func_restrict(X,J),X)" by auto2

definition join_covering :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "join_covering(X,Y) = Fun(source(X)\<times>source(Y), target(X), \<lambda>p. X`fst(p) \<inter> Y`snd(p))"
setup {* register_wellform_data ("join_covering(X,Y)", ["target(X) = target(Y)"]) *}

lemma join_covering_is_fun [typing]:
  "is_function(X) \<Longrightarrow> is_function(Y) \<Longrightarrow> target(X) = target(Y) \<Longrightarrow> target(X) = Pow(E) \<Longrightarrow>
   join_covering(X,Y) \<in> source(X)\<times>source(Y) \<rightarrow> target(X)" by auto2

lemma join_covering_eval [rewrite]:
  "is_function(X) \<Longrightarrow> is_function(Y) \<Longrightarrow> target(X) = target(Y) \<Longrightarrow> p \<in> source(join_covering(X,Y)) \<Longrightarrow>
   target(X) = Pow(E) \<Longrightarrow> join_covering(X,Y)`p = X`fst(p) \<inter> Y`snd(p)" by auto2
setup {* del_prfstep_thm @{thm join_covering_def} *}

lemma join_is_covering:
  "X \<in> I \<rightarrow> Pow(E) \<Longrightarrow> Y \<in> K \<rightarrow> Pow(E) \<Longrightarrow> is_covering(E,X) \<Longrightarrow>
   is_covering(E,Y) \<Longrightarrow> is_covering(E, join_covering(X,Y))" by auto2

lemma join_is_finer:
  "X \<in> I \<rightarrow> Pow(E) \<Longrightarrow> Y \<in> K \<rightarrow> Pow(E) \<Longrightarrow>
   finer_covering(join_covering(X,Y),X) \<and> finer_covering(join_covering(X,Y),Y)" by auto2

lemma join_is_finer_maximal:
  "X \<in> I \<rightarrow> Pow(E) \<Longrightarrow> Y \<in> K \<rightarrow> Pow(E) \<Longrightarrow> Z \<in> L \<rightarrow> Pow(E) \<Longrightarrow>
   finer_covering(Z,X) \<Longrightarrow> finer_covering(Z,Y) \<Longrightarrow> finer_covering(Z,join_covering(X,Y))" by auto2

lemma image_covering:
  "surjective(f) \<Longrightarrow> f \<in> A \<rightarrow> B \<Longrightarrow> X \<in> I \<rightarrow> Pow(A) \<Longrightarrow> is_covering(A,X) \<Longrightarrow>
   Y = Fun(I, Pow(B), \<lambda>a. f``(X`a)) \<Longrightarrow> is_covering(B,Y)"
@proof
  @have "\<forall>x\<in>B. \<exists>p\<in>I. x \<in> Y ` p" @with
    @obtain "a\<in>A" where "f`a = x"
  @end
@qed

lemma vImage_covering:
  "g \<in> C \<rightarrow> A \<Longrightarrow> X \<in> I \<rightarrow> Pow(A) \<Longrightarrow> is_covering(A,X) \<Longrightarrow>
   Y = Fun(I, Pow(C), \<lambda>a. g -`` (X`a)) \<Longrightarrow> is_covering(C,Y)"
@proof
  @have "\<forall>x\<in>C. \<exists>p\<in>I. x \<in> Y ` p" @with
    @contradiction
    @obtain "a\<in>I" where "g`x \<in> a"
  @end
@qed

lemma product_covering: "X \<in> I \<rightarrow> Pow(A) \<Longrightarrow> Y \<in> K \<rightarrow> Pow(B) \<Longrightarrow>
  is_covering(A,X) \<Longrightarrow> is_covering(B,Y) \<Longrightarrow>
  is_covering(A\<times>B, Fun(I\<times>K, Pow(A\<times>B), \<lambda>p. X`fst(p) \<times> Y`snd(p)))" by auto2

lemma glue_fun_on_covering [backward1]: "is_function(X) \<Longrightarrow> I = source(X) \<Longrightarrow> \<forall>a\<in>I. F(a) \<in> X`a \<rightarrow> D \<Longrightarrow>
  \<forall>a\<in>I. \<forall>b\<in>I. func_coincide(F(a), F(b), X`a \<inter> X`b) \<Longrightarrow>
  \<exists>!f. f\<in>(\<Union>a\<in>I. X`a)\<rightarrow>D \<and> (\<forall>a\<in>I. \<forall>b\<in>X`a. f`b = F(a)`b)"
@proof
  @have "\<exists>f\<in>(\<Union>a\<in>I. X`a)\<rightarrow>D. (\<forall>a\<in>I. \<forall>b\<in>X`a. f`b = F(a)`b)" @with
    @let "f = Fun(\<Union>a\<in>I. X`a, D, \<lambda>x. F(SOME a\<in>I. x\<in>X`a) ` x)"
    @have "f \<in> (\<Union>a\<in>I. X`a)\<rightarrow>D"
    @have "\<forall>a\<in>I. \<forall>b\<in>X`a. f`b = F(a)`b" @with
      @have (@rule) "\<forall>b'\<in>I. func_coincide(F(a),F(b'), X`a \<inter> X`b')"
    @end
  @end
@qed

section \<open>Partitions\<close>  (* Bourbaki II.4.7 *)

lemma singleton_disjoint [backward]: "a \<noteq> b \<Longrightarrow> {a} \<inter> {b} = \<emptyset>" by auto2

definition mutually_disjoint :: "i \<Rightarrow> o" where [rewrite]:
  "mutually_disjoint(X) \<longleftrightarrow> (\<forall>a\<in>source(X). \<forall>b\<in>source(X). a \<noteq> b \<longrightarrow> X`a \<inter> X`b = \<emptyset>)"

lemma mutually_disjointD:
  "mutually_disjoint(X) \<Longrightarrow> a \<in> source(X) \<Longrightarrow> b \<in> source(X) \<Longrightarrow> a \<noteq> b \<Longrightarrow> X`a \<inter> X`b = \<emptyset>" by auto2
setup {* add_forward_prfstep_cond @{thm mutually_disjointD} [with_term "?X`?a", with_term "?X`?b", with_cond "?a \<noteq> ?b"] *}
setup {* del_prfstep_thm_eqforward @{thm mutually_disjoint_def} *}

lemma vImage_set_disjoint [backward2]:
  "f \<in> A \<rightarrow> B \<Longrightarrow> X \<subseteq> B \<Longrightarrow> Y \<subseteq> B \<Longrightarrow> X \<inter> Y = \<emptyset> \<Longrightarrow> f -`` X \<inter> f -`` Y = \<emptyset>"
@proof
  @contradiction
  @obtain "b \<in> (f -`` X) \<inter> (f -`` Y)" @have "f ` b \<in> X \<inter> Y"
@qed

lemma vImage_mutually_disjoint [backward2]:
  "is_function(f) \<Longrightarrow> Y \<in> I \<rightarrow> Pow(target(f)) \<Longrightarrow> mutually_disjoint(Y) \<Longrightarrow>
   mutually_disjoint(Fun(I,Pow(source(f)),\<lambda>a. f -`` (Y`a)))" by auto2

lemma glue_fun_on_mut_disj [backward1]:
  "is_function(X) \<Longrightarrow> I = source(X) \<Longrightarrow> \<forall>a\<in>I. F(a) \<in> X`a \<rightarrow> D \<Longrightarrow>
  mutually_disjoint(X) \<Longrightarrow> \<exists>!f. f\<in>(\<Union>a\<in>I. X`a)\<rightarrow>D \<and> (\<forall>a\<in>I. \<forall>b\<in>X`a. f`b = F(a)`b)"
@proof
  @have "\<forall>a\<in>I. \<forall>b\<in>I. func_coincide(F(a), F(b), X`a \<inter> X`b)" @with @case "a = b" @end
@qed

(* For partitions, usually definition in terms of sets is more convenient *)
definition mutually_disjoint_sets :: "i \<Rightarrow> o" where [rewrite]:
  "mutually_disjoint_sets(X) \<longleftrightarrow> (\<forall>a\<in>X. \<forall>b\<in>X. a \<noteq> b \<longrightarrow> a \<inter> b = \<emptyset>)"

definition is_partition_sets :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "is_partition_sets(E,X) \<longleftrightarrow> (E = \<Union>X \<and> mutually_disjoint_sets(X))"

lemma singletons_is_partition: "is_partition_sets(E, {{x}. x\<in>E})"
@proof @have "\<forall>x\<in>E. x \<in> \<Union>{{x}. x \<in> E}" @with @have "x \<in> {x}" @end @qed

(* Version for a family of sets *)
definition is_partition :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "is_partition(E,X) \<longleftrightarrow> (E = (\<Union>a\<in>source(X). X`a) \<and> mutually_disjoint(X))"

lemma glue_fun_on_partition [backward1]:
  "is_function(X) \<Longrightarrow> \<forall>a\<in>source(X). F(a) \<in> X`a \<rightarrow> D \<Longrightarrow> is_partition(E,X) \<Longrightarrow>
   \<exists>!f. f\<in>E\<rightarrow>D \<and> (\<forall>a\<in>source(X). \<forall>b\<in>X`a. f`b = F(a)`b)" by auto2

(* X is a partition of E, indexed by I. F is a meta-family of functions indexed
   by I, where each F(a) is a function X(a)\<rightarrow>D. Get the glued map E\<rightarrow>D. *)
definition glue_partition_fun :: "[i, i, i, i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "glue_partition_fun(E,X,D,F) = (THE f. f\<in>E\<rightarrow>D \<and> (\<forall>a\<in>source(X). \<forall>b\<in>X`a. f`b = F(a)`b))"

lemma glue_partition_fun_prop:
  "is_function(X) \<Longrightarrow> \<forall>a\<in>source(X). F(a) \<in> X`a \<rightarrow> D \<Longrightarrow> is_partition(E,X) \<Longrightarrow>
   glue_partition_fun(E,X,D,F) \<in> E\<rightarrow>D \<and>
   (\<forall>a\<in>source(X). \<forall>b\<in>X`a. glue_partition_fun(E,X,D,F)`b = F(a)`b)" by auto2
setup {* add_forward_prfstep_cond @{thm glue_partition_fun_prop} [with_term "glue_partition_fun(?E,?X,?D,?F)"] *}
setup {* add_prfstep_check_req ("glue_partition_fun(E,X,D,F)", "\<forall>a\<in>source(X). F(a) \<in> X`a \<rightarrow> D") *}
setup {* del_prfstep_thm @{thm glue_partition_fun_def} *}

section \<open>Sum of a family of sets\<close>  (* Bourbaki II.4.8 *)

(* Version of Sigma for object functions *)
definition Sigma' :: "i \<Rightarrow> i" where [rewrite]:
  "Sigma'(X) = Sigma(source(X), \<lambda>a. X`a)"

lemma Sigma'_iff [rewrite]:
  "is_function(X) \<Longrightarrow> \<langle>a,b\<rangle> \<in> Sigma'(X) \<longleftrightarrow> (a \<in> source(X) \<and> b \<in> X`a)" by auto2

lemma Sigma'I: "is_function(X) \<Longrightarrow> a \<in> source(X) \<Longrightarrow> \<forall>b \<in> X`a. \<langle>a,b\<rangle> \<in> Sigma'(X)" by auto2
setup {* add_forward_prfstep_cond @{thm Sigma'I} [with_term "Sigma'(?X)"] *}

lemma Sigma'_split: "p \<in> Sigma'(X) \<Longrightarrow> p = \<langle>fst(p), snd(p)\<rangle>" by auto2
setup {* add_forward_prfstep_cond @{thm Sigma'_split} [with_cond "?p \<noteq> \<langle>?a, ?b\<rangle>"] *}
setup {* del_prfstep_thm @{thm Sigma'_def} *}

definition union_to_sum_fun :: "i \<Rightarrow> i" where [rewrite]:
  "union_to_sum_fun(X) = Fun(Sigma'(X), \<Union>a\<in>source(X). X`a, \<lambda>p. snd(p))"

lemma union_to_sum_is_function [typing]:
  "is_function(X) \<Longrightarrow> union_to_sum_fun(X) \<in> Sigma'(X) \<rightarrow> (\<Union>a\<in>source(X). X`a)" by auto2

lemma union_to_sum_is_surj [forward]:
  "is_function(X) \<Longrightarrow> surjective(union_to_sum_fun(X))" by auto2

lemma union_to_sum_is_bij:
  "mutually_disjoint(X) \<Longrightarrow> is_function(X) \<Longrightarrow>
   union_to_sum_fun(X) \<in> Sigma'(X) \<cong> (\<Union>a\<in>source(X). X`a)" by auto2

end


section\<open>Poincar\'e disc model types\<close>

text \<open>In this section we introduce datatypes that represent objects in the Poincar\'e disc model.
The types are defined as subtypes (e.g., the h-points are defined as elements of $\mathbb{C}P^1$
that lie within the unit disc). The functions on those types are defined by lifting the functions
defined on the carrier type (e.g., h-distance is defined by lifting the distance function defined
for elements of $\mathbb{C}P^1$).\<close>

theory Poincare
imports Poincare_Lines Poincare_Between Poincare_Distance Poincare_Circles
begin

(* ------------------------------------------------------------------ *)
subsection \<open>H-points\<close>
(* ------------------------------------------------------------------ *)

typedef p_point = "{z. z \<in> unit_disc}"
  using zero_in_unit_disc
  by (rule_tac x="0\<^sub>h" in exI, simp)

setup_lifting type_definition_p_point

text \<open>Point zero\<close>
lift_definition p_zero :: "p_point" is "0\<^sub>h"
  by (rule zero_in_unit_disc)

text \<open>Constructing h-points from complex numbers\<close>
lift_definition p_of_complex :: "complex \<Rightarrow> p_point" is "\<lambda> z. if cmod z < 1 then of_complex z else 0\<^sub>h"
  by auto

(* ------------------------------------------------------------------ *)
subsection \<open>H-lines\<close>
(* ------------------------------------------------------------------ *)

typedef p_line = "{H. is_poincare_line H}"
  by (rule_tac x="x_axis" in exI, simp)

setup_lifting type_definition_p_line

lift_definition p_incident :: "p_line \<Rightarrow> p_point \<Rightarrow> bool" is on_circline
  done

text \<open>Set of h-points on an h-line\<close>
definition p_points :: "p_line \<Rightarrow> p_point set" where
  "p_points l = {p. p_incident l p}"

text \<open>x-axis is an example of an h-line\<close>
lift_definition p_x_axis :: "p_line" is x_axis
  by simp

text \<open>Constructing the unique h-line from two h-points\<close>
lift_definition p_line :: "p_point \<Rightarrow> p_point \<Rightarrow> p_line" is poincare_line
proof-
  fix u v
  show "is_poincare_line (poincare_line u v)"
  proof (cases "u \<noteq> v")
    case True
    thus ?thesis
      by simp
  next
    text\<open>This branch must work only for formal reasons.\<close>
    case False
    thus ?thesis
      by (transfer, transfer, auto simp add: hermitean_def mat_adj_def mat_cnj_def split: if_split_asm)
  qed
qed

text \<open>Next we show how to lift some lemmas. This could be done for all the lemmas that we have
proved earlier, but we do not do that.\<close>

text \<open>If points are different then the constructed line contains the starting points\<close>
lemma p_on_line:
  assumes "z \<noteq> w"
  shows "p_incident (p_line z w) z"
        "p_incident (p_line z w) w"
  using assms
  by (transfer, simp)+

text \<open>There is a unique h-line passing trough the two different given h-points\<close>
lemma
  assumes "u \<noteq> v"
  shows "\<exists>! l. {u, v} \<subseteq> p_points l"
  using assms
  apply (rule_tac a="p_line u v" in ex1I, auto simp add: p_points_def p_on_line)
  apply (transfer, simp add: unique_poincare_line)
  done

text \<open>The unique h-line trough zero and a non-zero h-point on the x-axis is the x-axis\<close>
lemma
  assumes "p_zero \<in> p_points l" "u \<in> p_points l" "u \<noteq> p_zero" "u \<in> p_points p_x_axis"
  shows "l = p_x_axis"
  using assms
  unfolding p_points_def
  apply simp
  apply transfer
  using is_poincare_line_0_real_is_x_axis inf_notin_unit_disc
  unfolding circline_set_def
  by blast

(* ------------------------------------------------------------------ *)
subsection \<open>H-collinearity\<close>
(* ------------------------------------------------------------------ *)

lift_definition p_collinear :: "p_point set \<Rightarrow> bool" is poincare_collinear
  done

(* ------------------------------------------------------------------ *)
subsection \<open>H-isometries\<close>
(* ------------------------------------------------------------------ *)

text \<open>H-isometries are functions that map the unit disc onto itself\<close>
typedef p_isometry = "{f. unit_disc_fix_f f}"
  by (rule_tac x="id" in exI, simp add: unit_disc_fix_f_def, rule_tac x="id_moebius" in exI, simp)

setup_lifting type_definition_p_isometry

text \<open>Action of an h-isometry on an h-point\<close>
lift_definition p_isometry_pt :: "p_isometry \<Rightarrow> p_point \<Rightarrow> p_point" is "\<lambda> f p. f p"
  using unit_disc_fix_f_unit_disc
  by auto

text \<open>Action of an h-isometry on an h-line\<close>
lift_definition p_isometry_line :: "p_isometry \<Rightarrow> p_line \<Rightarrow> p_line" is "\<lambda> f l. unit_disc_fix_f_circline f l"
proof-
  fix f H
  assume "unit_disc_fix_f f" "is_poincare_line H"
  then obtain M where "unit_disc_fix M" and *: "f = moebius_pt M \<or> f = moebius_pt M \<circ> conjugate"
    unfolding unit_disc_fix_f_def
    by auto
  show "is_poincare_line (unit_disc_fix_f_circline f H)"
    using *
  proof
    assume "f = moebius_pt M"
    thus ?thesis
      using \<open>unit_disc_fix M\<close> \<open>is_poincare_line H\<close>
      using unit_disc_fix_f_circline_direct[of M f H]
      by auto
  next
    assume "f = moebius_pt M \<circ> conjugate"
    thus ?thesis
      using \<open>unit_disc_fix M\<close> \<open>is_poincare_line H\<close>
      using unit_disc_fix_f_circline_indirect[of M f H]
      by auto
  qed
qed

text \<open>An example lemma about h-isometries.\<close>

text \<open>H-isometries preserve h-collinearity\<close>
lemma p_collinear_p_isometry_pt [simp]:
  shows "p_collinear (p_isometry_pt M ` A) \<longleftrightarrow> p_collinear A"
proof-
  have *: "\<forall> M A.  ((\<lambda>x. moebius_pt M (conjugate x)) ` A = moebius_pt M ` (conjugate ` A))"
    by auto
  show ?thesis
    by transfer (auto simp add: unit_disc_fix_f_def *)
qed

(* ------------------------------------------------------------------ *)
subsection \<open>H-distance and h-congruence\<close>
(* ------------------------------------------------------------------ *)

lift_definition p_dist :: "p_point \<Rightarrow> p_point \<Rightarrow> real" is poincare_distance
  done

definition p_congruent :: "p_point \<Rightarrow> p_point \<Rightarrow> p_point \<Rightarrow> p_point \<Rightarrow> bool" where
  [simp]: "p_congruent u v u' v' \<longleftrightarrow> p_dist u v = p_dist u' v'"

lemma
  assumes "p_dist u v = p_dist u' v'"
  assumes "p_dist v w = p_dist v' w'"
  assumes "p_dist u w = p_dist u' w'"
  shows "\<exists> f. p_isometry_pt f u = u' \<and> p_isometry_pt f v = v' \<and> p_isometry_pt f w = w'"
  using assms
  apply transfer
  using unit_disc_fix_f_congruent_triangles
  by auto

text\<open>We prove that unit disc equipped with Poincar\'e distance is a metric space, i.e. an
instantiation of @{term metric_space} locale.\<close>

instantiation p_point :: metric_space
begin
definition "dist_p_point = p_dist"
definition "(uniformity_p_point :: (p_point \<times> p_point) filter) = (INF e\<in>{0<..}. principal {(x, y). dist_class.dist x y < e})"
definition "open_p_point (U :: p_point set) = (\<forall> x \<in> U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"
instance
proof
  fix x y :: p_point
  show "(dist_class.dist x y = 0) = (x = y)"
    unfolding dist_p_point_def
    by (transfer, simp add: poincare_distance_eq_0_iff)
next
  fix x y z :: p_point
  show "dist_class.dist x y \<le> dist_class.dist x z + dist_class.dist y z"
    unfolding dist_p_point_def
    apply transfer
    using poincare_distance_triangle_inequality poincare_distance_sym
    by metis
qed (simp_all add: open_p_point_def uniformity_p_point_def)
end

(* ------------------------------------------------------------------ *)
subsection \<open>H-betweennes\<close>
(* ------------------------------------------------------------------ *)

lift_definition p_between :: "p_point \<Rightarrow> p_point \<Rightarrow> p_point \<Rightarrow> bool" is poincare_between
  done

end


theory Fun_Graph
  imports "Extras"
begin

text \<open>Pair digraph of a function\<close>
definition Gr :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a pair_pre_digraph" where
"Gr S f = \<lparr>pverts = S, parcs = {(a, f a) | a. a \<in> S}\<rparr>"

lemma Gr_pverts [simp]: "pverts (Gr S f) = S"
  by (simp add: Fun_Graph.Gr_def)

lemma Gr_parcs [simp]: "parcs (Gr S f) = {(a, f a) | a. a \<in> S}"
  by (simp add: Fun_Graph.Gr_def)

lemma Gr_verts [simp]: "verts (with_proj (Gr S f)) = S"
  by simp

lemma Gr_arcs [simp]: "arcs (with_proj (Gr S f)) = {(a, f a) | a. a \<in> S}"
  by (simp add: Fun_Graph.Gr_def)

lemma Gr_eq: "a\<rightarrow>\<^bsub>Gr S f\<^esub> b \<longleftrightarrow> a \<in> S \<and> f a = b"
  unfolding Gr_def by auto

lemma Gr_wf:
  assumes "\<forall>a \<in> S. f a \<in> S"
  shows "pair_wf_digraph (Gr S f)"
  by (simp add: Fun_Graph.Gr_def assms pair_wf_digraph_def)

corollary Gr_wf_perm: "(p :: 'a perm) permutes S \<Longrightarrow> pair_wf_digraph (Gr S p)"
  by (simp add: Gr_wf permutes_in_image)

lemma Gr_finite:
  assumes "finite S" "wf_digraph (Gr S f)"
  shows "fin_digraph (Gr S f)"
  apply (intro_locales)
  unfolding fin_digraph_axioms_def using assms by auto

lemma funpow_in_rtrancl:
  assumes "a \<in> S" "\<forall> x \<in> S. f x \<in> S"
  shows "a\<rightarrow>\<^sup>*\<^bsub>Gr S f\<^esub>(f ^^ n) a"
proof (induct n)
  case 0
  then show ?case using assms by (simp add: Fun_Graph.Gr_def reachable_def)
next
  case (Suc n)
  then have "(f ^^ n) a \<rightarrow>\<^bsub>Gr S f\<^esub> (f ^^ (Suc n)) a"
    by (metis Gr_eq Gr_verts funpow_simp_l reachable_in_vertsE)
  then show ?case
    by (meson Gr_wf Suc.hyps assms(2) wf_digraph.reachable_adj_trans wf_digraph_wp_iff)
qed

lemma reach_iff_funpow:
  assumes "a \<in> S" "\<forall>x \<in> S. f x \<in> S"
  shows "a\<rightarrow>\<^sup>*\<^bsub>Gr S f\<^esub>b \<longleftrightarrow> (\<exists>n. (f ^^ n) a = b)"
proof
  interpret wf_digraph "Gr S f"
    by (simp add: Gr_wf assms(2) wf_digraph_wp_iff)
  assume "a\<rightarrow>\<^sup>*\<^bsub>Gr S f\<^esub>b" then show "(\<exists>n. (f ^^ n) a = b)"
  proof (induct rule: reachable_induct)
    case base
    then show ?case by (meson funpow_0)
  next
    case (step x y)
    then obtain n where "(f ^^ n) a = x"
      by auto
    also have "f x = y"
      by (metis Gr_eq step.hyps(2) with_proj_simps(3))
    ultimately show ?case
      by (metis funpow_simp_l)
  qed
next
  assume *: "(\<exists>n. (f ^^ n) a = b)"
  then obtain n where "(f ^^ n) a = b" by auto
  then show "a\<rightarrow>\<^sup>*\<^bsub>Gr S f\<^esub>b"
    using assms funpow_in_rtrancl by meson
qed

section \<open>Graph of a permutation\<close>
context perm_on
begin

interpretation Gr: pair_wf_digraph "Gr S p"
  by (simp add: Fun_Graph.Gr_def pair_wf_digraph_def permutes_p permutes_in_image)

lemma reach_iff_funpow_perm:
  assumes "a \<in> S"
  shows "a\<rightarrow>\<^sup>*\<^bsub>Gr S p\<^esub>b \<longleftrightarrow> (\<exists>n. ((\<langle>$\<rangle>) p ^^ n) a = b)"
  by (simp add: assms permutes_in_image permutes_p reach_iff_funpow)

lemma perm_cycles_iff_reach:
  assumes "x \<noteq> y"
  shows "y \<in> set_cycle (perm_orbit p x) \<longleftrightarrow> x\<rightarrow>\<^sup>*\<^bsub>Gr S p\<^esub>y" (is "?L \<longleftrightarrow> ?R")
proof
  assume *: ?L
  then obtain n where "(apply_perm p ^^ n) y = x"
     using cycles_funpow by fast
   then show ?R
     by (smt (verit, del_insts) * perm_on.permutes_p perm_on_axioms reach_iff_funpow_perm
         Permutations.permutes_not_in apply_perm_power funpow_apply_cycle_perm_orbit
         funpow_apply_perm_in_perm_orbit_iff set_cycle_ex_funpow start_in_perm_orbit_iff)
next
  assume *: ?R
  then obtain n where "(apply_perm p ^^ n) x = y"
    by (metis (no_types, lifting) Fun_Graph.Gr_def reach_iff_funpow_perm pair_pre_digraph.simps(1)
        Gr.reachable_in_verts(1))
  then show ?L
    by (metis assms funpow_cycles perm_orbit_set_comm)
qed

lemma perm_connect_sym: "Gr.connect_sym"
proof (auto simp: Gr.connect_sym_def)
  fix a b assume *: "a \<rightarrow>\<^sup>*\<^bsub>Gr S p\<^esub> b"
  then have "a = b \<Longrightarrow> b \<rightarrow>\<^sup>*\<^bsub>Gr S p\<^esub> a"
    by blast
  also have "a \<noteq> b \<Longrightarrow> b \<in> set_cycle (perm_orbit p a)"
    by (simp add: "*" perm_cycles_iff_reach)
  then have "a \<noteq> b \<Longrightarrow> a \<in> set_cycle (perm_orbit p b)"
    by (meson perm_orbit_set_comm)
  ultimately show "b \<rightarrow>\<^sup>*\<^bsub>Gr S p\<^esub> a"
    by (metis perm_cycles_iff_reach)
qed
end

section \<open>Graph of a cycle\<close>
lemma wf_digraph_cycle: "wf_digraph (Gr (set_cycle c) (apply_cycle c))"
  by (simp add: Gr_wf wf_digraph_wp_iff)

lemma strongly_connected_cycle:
 "c \<noteq> id_cycle \<Longrightarrow> strongly_connected (Gr (set_cycle c) (apply_cycle c))"
proof
  let ?G = "(Gr (set_cycle c) (apply_cycle c))"
  assume "c \<noteq> id_cycle"
  then show "verts ?G \<noteq> {}"
    by simp
  fix u v assume "u \<in> verts ?G" "v \<in> verts ?G"
  then show "u \<rightarrow>\<^sup>*\<^bsub>?G\<^esub> v"
    by (metis Gr_verts apply_cycle_in_set_iff funpow_in_rtrancl set_cycle_ex_funpow)
qed

context perm_on begin

lemma perm_orbit_subgraph:
  assumes "orb \<in> cycles_of_perm p"
  shows "subgraph (with_proj (Gr (set_cycle orb) (apply_cycle orb))) (with_proj (Gr S p))"
proof (auto simp: subgraph_def)
  show "x \<in> S" if "x \<in> set_cycle orb" for x
    using assms set_cycle_of_perm_subset set_perm_subset that by blast
  then show "apply_cycle orb x = p \<langle>$\<rangle> x" "x \<in> S" if "x \<in> set_cycle orb" for x
    by (simp_all add: assms that)
  show "wf_digraph (with_proj (Gr S p))"
    by (simp add: Gr_wf_perm permutes_p wf_digraph_wp_iff)
  show "wf_digraph (with_proj (Gr (set_cycle orb) (apply_cycle orb)))"
    by (simp add: wf_digraph_cycle)
qed

lemma perm_orbit_induced_subgraph:
  assumes "orb \<in> cycles_of_perm p"
  shows "induced_subgraph (with_proj (Gr (set_cycle orb) (apply_cycle orb))) (with_proj (Gr S p))"
    (is "induced_subgraph ?orbit ?G")
proof (auto simp add: induced_subgraph_def)
  show subgraph: "subgraph ?orbit ?G"
    by (simp add: assms perm_orbit_subgraph)
  fix a assume *: "a \<in> set_cycle orb"
  then show "apply_cycle orb a = p \<langle>$\<rangle> a" "a \<in> S"
    apply (simp_all add: assms)
    using subgraph by fastforce
  from * show "p \<langle>$\<rangle> a = apply_cycle orb a"
    by (simp add: \<open>apply_cycle orb a = p \<langle>$\<rangle> a\<close>)
qed

lemma perm_id_subgraph:
  assumes "c \<notin> set_perm p" "c \<in> S"
  shows "subgraph (with_proj (Gr {c} id)) (with_proj (Gr S p))"
  by (auto simp: subgraph_def assms apply_perm_eq_same_iff(2) Gr_wf  Gr_wf_perm
      permutes_p wf_digraph_wp_iff)

lemma perm_id_induced_subgraph:
  assumes "c \<notin> set_perm p" "c \<in> S"
  shows "induced_subgraph (with_proj (Gr {c} id)) (with_proj (Gr S p))"
  by (auto simp: assms induced_subgraph_def perm_id_subgraph apply_perm_eq_same_iff(2))

subsection \<open>Connected components of a permutation\<close>

interpretation Gr: pair_wf_digraph "Gr S p"
  by (simp add: Fun_Graph.Gr_def pair_wf_digraph_def permutes_p permutes_in_image)

lemma sccs_perm:
  "Gr.sccs = (\<lambda>c. with_proj (Gr (set_cycle c) (cycle_perm c))) ` (cycles_of_perm p)
                 \<union> (\<lambda>c. with_proj (Gr {c} id)) ` {x \<in> S. p x = x}" (is "Gr.sccs = ?C \<union> ?Id")
proof (rule subset_antisym; rule subsetI)
  fix x assume "x \<in> Gr.sccs"
  then have x_scc: "induced_subgraph x (Gr S p)" "strongly_connected x"
    "\<not> (\<exists>d. induced_subgraph d (Gr S p) \<and> strongly_connected d \<and> verts x \<subset> verts d)"
    by auto
  then obtain v where "v \<in> verts x"
    by (meson all_not_in_conv x_scc strongly_connected_def)
  then show "x \<in> ?C \<union> ?Id"
  proof (cases "p v = v")
    case True
    then have "verts x = {v}"
    proof -
      have "False" if "u \<in> verts x" "u \<noteq> v" for u
          by (metis Gr.reachable_mono True \<open>v \<in> verts x\<close> emptyE id_cycle_eq_perm_orbit_iff
              induced_imp_subgraph perm_on.perm_cycles_iff_reach perm_on_axioms set_cycle_id
              strongly_connected_def x_scc(1,2) that)
      then show "verts x = {v}"
        using \<open>v \<in> verts x\<close> by blast
    qed
    then have "x \<in> ?Id"
      by (smt (verit, ccfv_SIG) Gr.induce_eq_iff_induced Gr_verts True \<open>v \<in> verts x\<close>
          apply_perm_neq_idI image_iff in_mono induced_imp_subgraph mem_Collect_eq
          perm_on.perm_id_induced_subgraph perm_on_axioms subgraph_imp_subverts x_scc(1))
    then show "x \<in> ?C \<union> ?Id"
      by simp
  next
    case False
    then have "v \<in> set_perm p"
      by auto
    define cycle_v where "cycle_v \<equiv> perm_orbit p v"
    then have "cycle_v \<in> cycles_of_perm p"
    using perm_orbit_in_cycles_of_perm \<open>v \<in> set_perm p\<close> by blast
    also have "x = with_proj (Gr (set_cycle cycle_v) (apply_cycle cycle_v))"
    by (smt (verit) x_scc \<open>v \<in> verts x\<close> Gr.induce_eq_iff_induced Gr_pverts apply_cycle_perm_orbit'
        apply_cycle_same_iff calculation cycle_v_def id_cycle_eq_perm_orbit_iff
        induced_imp_subgraph perm_on.perm_cycles_iff_reach perm_on_axioms
        perm_orbit_in_cycles_of_perm_iff perm_orbit_induced_subgraph pre_digraph.reachable_mono
        psubsetI strongly_connected_cycle strongly_connected_def subset_iff with_proj_simps(1))
  ultimately show "x \<in> ?C \<union> ?Id"
    by simp
  qed
  next
  fix G assume "G \<in> ?C \<union> ?Id"
  then consider (cycle) "G \<in> ?C" | (id) "G \<in> ?Id"
    by auto
  then show "G \<in> Gr.sccs"
  proof (cases)
    case cycle
    assume G_in:"G \<in> (\<lambda>c. with_proj (Gr (set_cycle c) ((\<langle>$\<rangle>) (cycle_perm c)))) ` cycles_of_perm p"
    then obtain x
      where x_cycle: "x \<in> cycles_of_perm p" "G = with_proj (Gr (set_cycle x) (apply_cycle x))"
      by force
  {
    fix H assume *: "induced_subgraph H (Gr S p)" "strongly_connected H" "verts G \<subset> verts H"
    then have "False"
    proof -
      from *(3) obtain v where "v \<in> verts H \<and> v \<notin> verts G"
        by auto
      also obtain u where "u \<in> verts G"
        using cycle by fastforce
      then have "\<exists>n. (((\<langle>$\<rangle>) p) ^^ n) v = u"
        by (metis (no_types, hide_lams) * Gr.reachable_mono Gr_pverts calculation
            perm_on.reach_iff_funpow_perm perm_on_axioms strongly_connected_def
            subgraph_imp_subverts subsetD with_proj_simps(1) induced_imp_subgraph psubsetE)
      then show "False"
        by (smt (verit, ccfv_threshold) cycle Gr_verts \<open>u \<in> verts G\<close>
            calculation cycles_of_perm_def funpow_apply_perm_in_perm_orbit_iff image_iff )
    qed
  }
  then show "G \<in> Gr.sccs"
    apply (auto simp: Gr.sccs_def G_in)
    apply (simp add: x_cycle G_in perm_orbit_induced_subgraph perm_on_axioms)
    apply (metis x_cycle id_cycle_not_in_cycles_of_perm strongly_connected_cycle)
    done
  next
    case id
    then obtain c where c_def: "c \<in> S" "p c = c" "G \<equiv> with_proj (Gr {c} id)"
      by auto
    then have "wf_digraph G"
      by (simp add: Gr_wf wf_digraph_wp_iff)
  {
    fix H assume *: "induced_subgraph H (Gr S p)" "strongly_connected H" "verts G \<subset> verts H"
    then have "False"
    proof -
      from *(3) obtain v where "v \<in> verts H" "v \<notin> verts G"
        by auto
      then have "\<exists>n. (((\<langle>$\<rangle>) p) ^^ n) v = c"
        by (metis (mono_tags, lifting) * c_def(3) Gr.reachable_mono Gr_verts \<open>p \<langle>$\<rangle> c = c\<close>
            induced_imp_subgraph insertCI perm_on.perm_cycles_iff_reach perm_on_axioms
            perm_orbit_eq_id_cycle_iff psubsetE set_cycle_id strongly_connectedE subsetD)
      then show "False"
        by (metis \<open>v \<notin> verts G\<close> \<open>p c = c\<close> c_def(3) Gr_verts apply_inj_eq_iff apply_perm_power
            id_funpow_id insert_iff)
    qed
  }
  then show "G \<in> Gr.sccs"
    apply (auto simp: Gr.sccs_def c_def(3))
    apply (meson apply_perm_neq_idI c_def(1) c_def(2) perm_id_induced_subgraph)
    unfolding strongly_connected_def using \<open>wf_digraph G\<close>
    apply (simp add: wf_digraph.reachable_refl Fun_Graph.Gr_def c_def(3))
    done
  qed
qed

lemma count_cycles_card_sccs: "finite S \<Longrightarrow> card Gr.sccs = count_cycles_on S p"
proof (simp add: count_cycles_on_def perm_type_on_def sccs_perm)
  assume *: "finite S"
  let ?cycle_graphs = "(\<lambda>x. with_proj (Gr (set_cycle x) (apply_cycle x))) ` cycles_of_perm p"
  let ?id_graphs = "(\<lambda>c. with_proj (Gr {c} id)) ` {x \<in> S. p \<langle>$\<rangle> x = x}"

  have "(S - set_perm p) = {x \<in> S. p \<langle>$\<rangle> x = x}"
    by blast
  also have "inj (\<lambda>c. with_proj (Gr {c} id))"
    by (metis (no_types, lifting) Gr_pverts inj_onI singleton_inject with_proj_simps(1))
  then have "card ?id_graphs = card {x \<in> S. p \<langle>$\<rangle> x = x}"
    by (smt (verit, ccfv_SIG) Gr_pverts card_image inj_onI singleton_inject with_proj_simps(1))
  ultimately have card_id: "card (S - set_perm p) = card ?id_graphs"
    by presburger

  have "size (perm_type p) = card (cycles_of_perm p)"
    by (simp add: size_perm_type_eq_card)
  also have "disjoint (set_cycle ` cycles_of_perm p)"
    by (meson disjoint_cycles_cycles_of_perms disjoint_cycles_def disjoint_family_on_disjoint_image)
  then have "inj_on set_cycle (cycles_of_perm p)"
    by (smt (verit) disjnt_def disjnt_iff disjoint_cycles_cycles_of_perms disjoint_cycles_def
        disjoint_family_onD empty_subsetI equalityI inj_on_def set_cycle_empty_iff subset_iff)
  then have "inj_on (\<lambda>c. with_proj (Gr (set_cycle c) ((\<langle>$\<rangle>) (cycle_perm c)))) (cycles_of_perm p)"
    by (metis (mono_tags, lifting) Gr_verts inj_on_def)
  then have "card (cycles_of_perm p) = card ?cycle_graphs"
    using card_image by fastforce
  ultimately have card_cycles: "size (perm_type p) = card ?cycle_graphs"
    by presburger

  have "card (?cycle_graphs \<union> ?id_graphs) = card ?cycle_graphs + card ?id_graphs"
    apply (rule card_Un_disjoint)
      apply (simp_all add: * finite_cycles_of_perm)
      by (smt (verit, ccfv_SIG) Gr_verts apply_cycle_perm_orbit apply_cycle_same_iff
        cycles_of_perm_def disjoint_iff imageE mem_Collect_eq singletonI)
  then show "card (?cycle_graphs \<union> ?id_graphs) = size (perm_type p) + card (S - set_perm p)"
    using card_cycles card_id by presburger
qed

lemma sccs_set_perm:
  assumes "S = set_perm p"
  shows "Gr.sccs = (\<lambda>c. with_proj (Gr (set_cycle c) (cycle_perm c))) ` (cycles_of_perm p)"
proof -
  from assms have "{x \<in> S. p x = x} = {}"
    by blast
  then show ?thesis
    using sccs_perm by auto
qed

lemma scc_of_orbit:
  assumes "x \<in> S"
  shows "Gr.scc_of x = (if p \<langle>$\<rangle> x = x then {x} else set_cycle (perm_orbit p x))"
proof (cases "p \<langle>$\<rangle> x = x")
  case True
  {
    assume "Gr.scc_of x \<noteq> {x}"
    then obtain y where "y \<noteq> x" "x\<rightarrow>\<^sup>*\<^bsub>Gr S p\<^esub>y"
      using Gr.scc_of_def Collect_cong Gr.in_scc_of_self Gr_pverts assms by fastforce
    then have "x = y"
      by (metis True assms funpow_apply_perm_in_perm_orbit_iff perm_on.perm_cycles_iff_reach
          perm_on.reach_iff_funpow_perm perm_on_axioms start_in_perm_orbit_iff)
    then have "False" using \<open>y \<noteq> x\<close> by auto
  }
  then show ?thesis using True by auto
next
  case False
  have "Gr.scc_of x = set_cycle (perm_orbit p x)"
  proof (rule subset_antisym; rule subsetI)
    fix y assume "y \<in> Gr.scc_of x"
    then have "x \<rightarrow>\<^sup>*\<^bsub>Gr S p\<^esub> y"
      using Gr.in_scc_of_self Gr.in_sccs_verts_conv_reachable Gr.scc_of_in_sccs_verts assms by auto
    then show "y \<in> set_cycle (perm_orbit p x)"
      by (metis False perm_cycles_iff_reach start_in_perm_orbit)
  next
    fix y assume "y \<in> set_cycle (perm_orbit p x)"
    then show "y \<in> Gr.scc_of x"
      by (metis (full_types, lifting) Gr.connect_sym_def Gr.scc_of_def Gr.wf_digraph_axioms
          Gr_pverts assms mem_Collect_eq perm_cycles_iff_reach perm_connect_sym
          wf_digraph.reachable_refl with_proj_simps(1))
  qed
  then show ?thesis
    using False by presburger
qed

lemma Gr_reverse_eq_inv: "(Gr S p)\<^sup>R = Gr S (inv p)"
proof (simp add: Gr_def reverse_def; rule; rule)
  fix x assume *: "x \<in> {(a, p \<langle>$\<rangle> a) |a. a \<in> S}\<inverse>"
  then obtain a b where "(a,b) = x" by auto
  then have "a = p b" using * converseI by auto
  then have "b = (inv p) a" by (metis permutes_inverses(2) permutes_p)
  then show "x \<in> {(a, inv ((\<langle>$\<rangle>) p) a) |a. a \<in> S}"
    using * \<open>(a,b) = x\<close> bij_betwE permutes_imp_bij permutes_p by fastforce
next
  fix x assume *: "x \<in> {(a, inv ((\<langle>$\<rangle>) p) a) |a. a \<in> S}"
  then obtain a b where "(a,b) = x" by auto
  then have "a = p b"
    by (smt (verit, del_insts) * Pair_inject mem_Collect_eq permutes_inv_eq permutes_p)
  then have "(b,a) \<in> {(a, p \<langle>$\<rangle> a) |a. a \<in> S}"
    using * \<open>(a,b) = x\<close> permutes_not_in permutes_p by fastforce
  then show "x \<in> {(a, p \<langle>$\<rangle> a) |a. a \<in> S}\<inverse>"
    using \<open>(a,b) = x\<close> by auto
qed
end
end


theory Chapter9_1
imports "~~/src/HOL/IMP/Types"
begin

text{*
\section*{Chapter 9}

\exercise
Reformulate the inductive predicates \ @{prop"\<Gamma> \<turnstile> a : \<tau>"},
\ @{prop"\<Gamma> \<turnstile> (b::bexp)"} \
and \ \mbox{@{prop"\<Gamma> \<turnstile> (c::com)"}} \ as three recursive functions
*}

fun atype :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty option" where
(* your definition/proof here *)

fun bok :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" where
(* your definition/proof here *)

fun cok :: "tyenv \<Rightarrow> com \<Rightarrow> bool" where
(* your definition/proof here *)

text{* and prove *}

lemma atyping_atype: "(\<Gamma> \<turnstile> a : \<tau>) = (atype \<Gamma> a = Some \<tau>)"
(* your definition/proof here *)

lemma btyping_bok: "(\<Gamma> \<turnstile> b) = bok \<Gamma> b"
(* your definition/proof here *)

lemma ctyping_cok: "(\<Gamma> \<turnstile> c) = cok \<Gamma> c"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Modify the evaluation and typing of @{typ aexp} by allowing @{typ int}s to be coerced
to @{typ real}s with the predefined coercion function
\noquotes{@{term[source] "real_of_int :: int \<Rightarrow> real"}} where necessary.
Now every @{typ aexp} has a value. Define an evaluation function:
*}

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
(* your definition/proof here *)

text{*
Similarly, every @{typ aexp} has a type.
Define a function that computes the type of an @{typ aexp}
*}

fun atyp :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty" where
(* your definition/proof here *)

text{* and prove that it computes the correct type: *}

lemma  "\<Gamma> \<turnstile> s \<Longrightarrow>  atyp \<Gamma> a = type (aval a s)"
(* your definition/proof here *)

text{*
Note that Isabelle inserts the coercion @{typ real} automatically.
For example, if you write @{term "Rv(i+r)"} where @{text"i :: int"} and
@{text "r :: real"} then it becomes @{term "Rv(real i + x)"}.
\endexercise
\bigskip

For the following two exercises copy theory @{theory Types} and modify it as required.

\begin{exercise}
Add a @{text REPEAT} loop (see Exercise~\ref{exe:IMP:REPEAT}) to the typed version of IMP
and update the type soundness proof.
\end{exercise}

\begin{exercise}
Modify the typed version of IMP as follows. Values are now either integers or booleans.
Thus variables can have boolean values too. Merge the two expressions types
@{typ aexp} and @{typ bexp} into one new type @{text exp} of expressions
that has the constructors of both types (of course without real constants).
Combine @{const taval} and @{const tbval} into one evaluation predicate
@{text "eval :: exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"}. Similarly combine the two typing predicates
into one: @{text "\<Gamma> \<turnstile> e : \<tau>"} where @{text "e :: exp"} and the IMP-type @{text \<tau>} can
be one of @{text Ity} or @{text Bty}.
Adjust the small-step semantics and the type soundness proof.
\end{exercise}
*}

end


(*  Title:      The Second Isomorphism Theorem for Groups
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory SndIsomorphismGrp
imports
    "~~/src/HOL/Algebra/Coset"
    "../Secondary_Sylow/SubgroupConjugation"
begin

section {* The Second Isomorphism Theorem for Groups *}

subsection {* Preliminaries *}

lemma (in group) triv_subgroup:
  shows "subgroup {\<one>} G"
unfolding subgroup_def by auto

lemma (in group) triv_normal_subgroup:
  shows "{\<one>} \<lhd> G"
unfolding normal_def normal_axioms_def l_coset_def r_coset_def
using is_group triv_subgroup by auto

lemma (in group) normal_restrict_supergroup:
  assumes SsubG:"subgroup S G"
  assumes Nnormal:"N \<lhd> G"
  assumes "N \<subseteq> S"
  shows "N \<lhd> (G\<lparr>carrier := S\<rparr>)"
proof -
  interpret Sgrp: group "G\<lparr>carrier := S\<rparr>" using SsubG by (rule subgroup_imp_group)
  show ?thesis
  proof(rule Sgrp.normalI)
    show "subgroup N (G\<lparr>carrier := S\<rparr>)" using assms is_group by (metis subgroup.subgroup_of_subset normal_inv_iff)
  next
    from SsubG have "S \<subseteq> carrier G" by (rule subgroup_imp_subset)
    thus "\<forall>x\<in>carrier (G\<lparr>carrier := S\<rparr>). N #>\<^bsub>G\<lparr>carrier := S\<rparr>\<^esub> x = x <#\<^bsub>G\<lparr>carrier := S\<rparr>\<^esub> N"
      using Nnormal unfolding normal_def normal_axioms_def l_coset_def r_coset_def by fastforce
  qed
qed

text {* As this is maybe the best place this fits in: Factorizing by the trivial subgroup
is an isomorphism. *}

lemma (in group) trivial_factor_iso:
  shows "the_elem \<in> (G Mod {\<one>}) \<cong> G"
proof -
  have "group_hom G G (\<lambda>x. x)" unfolding group_hom_def group_hom_axioms_def hom_def using is_group by simp
  moreover have "(\<lambda>x. x) ` carrier G = carrier G" by simp
  moreover have "kernel G G (\<lambda>x. x) = {\<one>}" unfolding kernel_def by auto
  ultimately show ?thesis using group_hom.FactGroup_iso by force
qed

text {* And the dual theorem to the previous one: Factorizing by the group itself gives the trivial group *}

lemma (in group) self_factor_iso:
  shows "(\<lambda>X. the_elem ((\<lambda>x. \<one>) ` X)) \<in> (G Mod (carrier G)) \<cong> G\<lparr> carrier := {\<one>} \<rparr>"
proof -
  have "group (G\<lparr>carrier := {\<one>}\<rparr>)" by (metis subgroup_imp_group triv_subgroup)
  hence "group_hom G (G\<lparr>carrier := {\<one>}\<rparr>) (\<lambda>x. \<one>)" unfolding group_hom_def group_hom_axioms_def hom_def using is_group by auto
  moreover have "(\<lambda>x. \<one>) ` carrier G = carrier (G\<lparr>carrier := {\<one>}\<rparr>)" by auto
  moreover have "kernel G (G\<lparr>carrier := {\<one>}\<rparr>) (\<lambda>x. \<one>) = carrier G" unfolding kernel_def by auto
  ultimately show ?thesis using group_hom.FactGroup_iso by force
qed

text {* This theory provides a proof of the second isomorphism theorems for groups.
The theorems consist of several facts about normal subgroups. *}

text {* The first lemma states that whenever we have a subgroup @{term S} and
a normal subgroup @{term H} of a group @{term G}, their intersection is normal
in @{term G} *}

locale second_isomorphism_grp = normal +
  fixes S::"'a set"
  assumes subgrpS:"subgroup S G"

context second_isomorphism_grp
begin

interpretation groupS: group "G\<lparr>carrier := S\<rparr>"
using subgrpS by (metis subgroup_imp_group)

lemma normal_subgrp_intersection_normal:
  shows "S \<inter> H \<lhd> (G\<lparr>carrier := S\<rparr>)"
proof(auto simp: groupS.normal_inv_iff)
  from subgrpS is_subgroup have "\<And>x. x \<in> {S, H} \<Longrightarrow> subgroup x G" by auto
  hence "subgroup (\<Inter> {S, H}) G" using subgroups_Inter by blast
  hence "subgroup (S \<inter> H) G" by auto
  moreover have "S \<inter> H \<subseteq> S" by simp
  ultimately show "subgroup (S \<inter> H) (G\<lparr>carrier := S\<rparr>)" using is_group subgroup.subgroup_of_subset subgrpS by metis
next
  fix g h
  assume g:"g \<in> S" and hH:"h \<in> H" and hS:"h \<in> S" {
    from g hH subgrpS show "g \<otimes> h \<otimes> inv\<^bsub>G\<lparr>carrier := S\<rparr>\<^esub> g \<in> H" by (metis inv_op_closed2 subgroup.mem_carrier subgroup_inv_equality)
  } {
    from g hS subgrpS show "g \<otimes> h \<otimes> inv\<^bsub>G\<lparr>carrier := S\<rparr>\<^esub> g \<in> S" by (metis subgroup.m_closed subgroup.m_inv_closed subgroup_inv_equality)
  }
qed

lemma normal_set_mult_subgroup:
  shows "subgroup (H <#> S) G"
proof(rule subgroupI)
  show "H <#> S \<subseteq> carrier G" by (metis setmult_subset_G subgroup_imp_subset subgrpS subset)
next
  have "\<one> \<in> H" "\<one> \<in> S" using is_subgroup subgrpS subgroup.one_closed by auto
  hence "\<one> \<otimes> \<one> \<in> H <#> S" unfolding set_mult_def by blast
  thus "H <#> S \<noteq> {}" by auto
next
  fix g
  assume g:"g \<in> H <#> S"
  then obtain h s where h:"h \<in> H" and s:"s \<in> S" and ghs:"g = h \<otimes> s" unfolding set_mult_def by auto
  hence "s \<in> carrier G" by (metis subgroup.mem_carrier subgrpS)
  with h ghs obtain h' where h':"h' \<in> H" and "g = s \<otimes> h'" using coset_eq unfolding r_coset_def l_coset_def by auto
  with s have "inv g = (inv h') \<otimes> (inv s)" by (metis inv_mult_group mem_carrier subgroup.mem_carrier subgrpS)
  moreover from h' s subgrpS have "inv h' \<in> H" "inv s \<in> S" using subgroup.m_inv_closed m_inv_closed by auto
  ultimately show "inv g \<in> H <#> S" unfolding set_mult_def by auto
next
  fix g g'
  assume g:"g \<in> H <#> S" and h:"g' \<in> H <#> S"
  then obtain h h' s s' where hh'ss':"h \<in> H" "h' \<in> H" "s \<in> S" "s' \<in> S" and "g = h \<otimes> s" and "g' = h' \<otimes> s'" unfolding set_mult_def by auto
  hence "g \<otimes> g' = (h \<otimes> s) \<otimes> (h' \<otimes> s')" by metis
  also from hh'ss' have inG:"h \<in> carrier G" "h' \<in> carrier G" "s \<in> carrier G" "s' \<in> carrier G" using subgrpS mem_carrier subgroup.mem_carrier by force+
  hence "(h \<otimes> s) \<otimes> (h' \<otimes> s') = h \<otimes> (s \<otimes> h') \<otimes> s'" using m_assoc by auto
  also from hh'ss' inG obtain h'' where h'':"h'' \<in> H" and "s \<otimes> h' = h'' \<otimes> s"using coset_eq unfolding r_coset_def l_coset_def by fastforce
  hence "h \<otimes> (s \<otimes> h') \<otimes> s' = h \<otimes> (h'' \<otimes> s) \<otimes> s'" by simp
  also from h'' inG have "... = (h \<otimes> h'') \<otimes> (s \<otimes> s')" using m_assoc mem_carrier by auto
  finally have "g \<otimes> g' = h \<otimes> h'' \<otimes> (s \<otimes> s')".
  moreover with h'' hh'ss' have "... \<in> H <#> S" unfolding set_mult_def using subgrpS subgroup.m_closed by fastforce
  ultimately show "g \<otimes> g' \<in> H <#> S" by simp
qed

lemma oneH:"\<one> \<in> H" by (metis is_subgroup subgroup.one_closed)

lemma H_contained_in_set_mult:
  shows "H \<subseteq> H <#> S"
proof auto
  have "\<one> \<in> S" by (metis subgroup.one_closed subgrpS)
  fix x
  assume x:"x \<in> H"
  with `\<one> \<in> S` have "x \<otimes> \<one> \<in> H <#> S" unfolding set_mult_def by force
  with x show  "x \<in> H <#> S" by (metis mem_carrier r_one)
qed

lemma S_contained_in_set_mult:
  shows "S \<subseteq> H <#> S"
proof auto
  fix s
  assume s:"s \<in> S"
  with oneH have "\<one> \<otimes> s \<in> H <#> S" unfolding set_mult_def by force
  with s show "s \<in> H <#> S" using subgrpS subgroup.mem_carrier l_one by force
qed

lemma normal_intersection_hom:
  shows "group_hom (G\<lparr>carrier := S\<rparr>) ((G\<lparr>carrier := H <#> S\<rparr>) Mod H) (\<lambda>g. H #> g)"
proof (auto del: equalityI simp: group_hom_def group_hom_axioms_def hom_def groupS.is_group)
  have  gr:"group (G\<lparr>carrier := H <#> S\<rparr>)" by (metis normal_set_mult_subgroup subgroup_imp_group)
  moreover have "H \<subseteq> H <#> S" by (rule H_contained_in_set_mult)
  moreover have "subgroup (H <#> S) G" by (metis normal_set_mult_subgroup)
  ultimately have "H \<lhd> (G\<lparr>carrier := H <#> S\<rparr>)" using normal_restrict_supergroup by (metis inv_op_closed2 is_subgroup normal_inv_iff)
  with gr show "group ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)" by (metis normal.factorgroup_is_group)
next
  fix g
  assume g:"g \<in> S"
  with subgrpS have "\<one> \<otimes> g \<in> H <#> S" unfolding set_mult_def by fastforce
  with g have "g \<in> H <#> S" by (metis l_one subgroup.mem_carrier subgrpS)
  thus "H #> g \<in> carrier ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
next
  fix g g' xa
  assume g:"g \<in> S" and g':"g' \<in> S"
  hence "(H #> g) <#> (H #> g') = H #> (g \<otimes> g')" by (metis rcos_sum subgroup.mem_carrier subgrpS)
  thus "H #> (g \<otimes> g') = (H #> g) <#>\<^bsub>G\<lparr>carrier := H <#> S\<rparr>\<^esub> (H #> g')" unfolding set_mult_def by auto
qed

lemma normal_intersection_hom_kernel:
  shows "kernel (G\<lparr>carrier := S\<rparr>) ((G\<lparr>carrier := H <#> S\<rparr>) Mod H) (\<lambda>g. H #> g) = H \<inter> S"
proof -
  have "kernel (G\<lparr>carrier := S\<rparr>) ((G\<lparr>carrier := H <#> S\<rparr>) Mod H) (\<lambda>g. H #> g)
                 = {g \<in> S. H #> g = \<one>\<^bsub>(G\<lparr>carrier := H <#> S\<rparr>) Mod H\<^esub>}" unfolding kernel_def by auto
  also have "... = {g \<in> S. H #> g = H}" unfolding FactGroup_def by auto
  also have "... = {g \<in> S. g \<in> H}" by (metis coset_eq is_subgroup lcoset_join2 rcos_self subgroup.mem_carrier subgrpS)
  also have "... = H \<inter> S" by auto
  finally show ?thesis.
qed

lemma normal_intersection_hom_surj:
  shows "(\<lambda>g. H #> g) ` carrier (G\<lparr>carrier := S\<rparr>) = carrier ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)"
proof auto
  fix g
  assume "g \<in> S"
  hence "g \<in> H <#> S" using S_contained_in_set_mult by auto
  thus "H #> g \<in> carrier ((G\<lparr>carrier := H <#> S\<rparr>) Mod H)" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
next
  fix x
  assume "x \<in> carrier (G\<lparr>carrier := H <#> S\<rparr> Mod H)"
  then obtain h s where h:"h \<in> H" and s:"s \<in> S" and "x = H #> (h \<otimes> s)"
    unfolding FactGroup_def RCOSETS_def r_coset_def set_mult_def by auto
  hence "x = (H #> h) #> s" by (metis h s coset_mult_assoc mem_carrier subgroup.mem_carrier subgrpS subset)
  also have "... = H #> s" by (metis h is_group rcos_const)
  finally have "x = H #> s".
  with s show "x \<in> op #> H ` S" by simp
qed

text {* Finally we can prove the actual isomorphism theorem: *}

theorem normal_intersection_quotient_isom:
  shows "(\<lambda>X. the_elem ((\<lambda>g. H #> g) ` X)) \<in> ((G\<lparr>carrier := S\<rparr>) Mod (H \<inter> S)) \<cong> (((G\<lparr>carrier := H <#> S\<rparr>)) Mod H)"
using normal_intersection_hom_kernel[symmetric] normal_intersection_hom normal_intersection_hom_surj
by (metis group_hom.FactGroup_iso)

end

end