(*  Title:      HOL/Hilbert_Choice.thy
    Author:     Lawrence C Paulson, Tobias Nipkow
    Copyright   2001  University of Cambridge
*)

section {* Hilbert's Epsilon-Operator and the Axiom of Choice *}

theory Hilbert_Choice
imports Nat Wellfounded
keywords "specification" :: thy_goal
begin

subsection {* Hilbert's epsilon *}

axiomatization Eps :: "('a => bool) => 'a" where
  someI: "P x ==> P (Eps P)"

syntax (epsilon)
  "_Eps"        :: "[pttrn, bool] => 'a"    ("(3\<some>_./ _)" [0, 10] 10)
syntax (HOL)
  "_Eps"        :: "[pttrn, bool] => 'a"    ("(3@ _./ _)" [0, 10] 10)
syntax
  "_Eps"        :: "[pttrn, bool] => 'a"    ("(3SOME _./ _)" [0, 10] 10)
translations
  "SOME x. P" == "CONST Eps (%x. P)"

print_translation {*
  [(@{const_syntax Eps}, fn _ => fn [Abs abs] =>
      let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
      in Syntax.const @{syntax_const "_Eps"} $ x $ t end)]
*} -- {* to avoid eta-contraction of body *}

definition inv_into :: "'a set => ('a => 'b) => ('b => 'a)" where
"inv_into A f == %x. SOME y. y : A & f y = x"

abbreviation inv :: "('a => 'b) => ('b => 'a)" where
"inv == inv_into UNIV"

subsection {*Hilbert's Epsilon-operator*}

text{*Easier to apply than @{text someI} if the witness comes from an
existential formula*}
lemma someI_ex [elim?]: "\<exists>x. P x ==> P (SOME x. P x)"
apply (erule exE)
apply (erule someI)
done

text{*Easier to apply than @{text someI} because the conclusion has only one
occurrence of @{term P}.*}
lemma someI2: "[| P a;  !!x. P x ==> Q x |] ==> Q (SOME x. P x)"
by (blast intro: someI)

text{*Easier to apply than @{text someI2} if the witness comes from an
existential formula*}
lemma someI2_ex: "[| \<exists>a. P a; !!x. P x ==> Q x |] ==> Q (SOME x. P x)"
by (blast intro: someI2)

lemma some_equality [intro]:
     "[| P a;  !!x. P x ==> x=a |] ==> (SOME x. P x) = a"
by (blast intro: someI2)

lemma some1_equality: "[| EX!x. P x; P a |] ==> (SOME x. P x) = a"
by blast

lemma some_eq_ex: "P (SOME x. P x) =  (\<exists>x. P x)"
by (blast intro: someI)

lemma some_in_eq: "(SOME x. x \<in> A) \<in> A \<longleftrightarrow> A \<noteq> {}"
  unfolding ex_in_conv[symmetric] by (rule some_eq_ex)

lemma some_eq_trivial [simp]: "(SOME y. y=x) = x"
apply (rule some_equality)
apply (rule refl, assumption)
done

lemma some_sym_eq_trivial [simp]: "(SOME y. x=y) = x"
apply (rule some_equality)
apply (rule refl)
apply (erule sym)
done

subsection{*Axiom of Choice, Proved Using the Description Operator*}

lemma choice: "\<forall>x. \<exists>y. Q x y ==> \<exists>f. \<forall>x. Q x (f x)"
by (fast elim: someI)

lemma bchoice: "\<forall>x\<in>S. \<exists>y. Q x y ==> \<exists>f. \<forall>x\<in>S. Q x (f x)"
by (fast elim: someI)

lemma choice_iff: "(\<forall>x. \<exists>y. Q x y) \<longleftrightarrow> (\<exists>f. \<forall>x. Q x (f x))"
by (fast elim: someI)

lemma choice_iff': "(\<forall>x. P x \<longrightarrow> (\<exists>y. Q x y)) \<longleftrightarrow> (\<exists>f. \<forall>x. P x \<longrightarrow> Q x (f x))"
by (fast elim: someI)

lemma bchoice_iff: "(\<forall>x\<in>S. \<exists>y. Q x y) \<longleftrightarrow> (\<exists>f. \<forall>x\<in>S. Q x (f x))"
by (fast elim: someI)

lemma bchoice_iff': "(\<forall>x\<in>S. P x \<longrightarrow> (\<exists>y. Q x y)) \<longleftrightarrow> (\<exists>f. \<forall>x\<in>S. P x \<longrightarrow> Q x (f x))"
by (fast elim: someI)

lemma dependent_nat_choice:
  assumes  1: "\<exists>x. P 0 x" and
           2: "\<And>x n. P n x \<Longrightarrow> \<exists>y. P (Suc n) y \<and> Q n x y"
  shows "\<exists>f. \<forall>n. P n (f n) \<and> Q n (f n) (f (Suc n))"
proof (intro exI allI conjI)
  fix n def f \<equiv> "rec_nat (SOME x. P 0 x) (\<lambda>n x. SOME y. P (Suc n) y \<and> Q n x y)"
  have "P 0 (f 0)" "\<And>n. P n (f n) \<Longrightarrow> P (Suc n) (f (Suc n)) \<and> Q n (f n) (f (Suc n))"
    using someI_ex[OF 1] someI_ex[OF 2] by (simp_all add: f_def)
  then show "P n (f n)" "Q n (f n) (f (Suc n))"
    by (induct n) auto
qed

subsection {*Function Inverse*}

lemma inv_def: "inv f = (%y. SOME x. f x = y)"
by(simp add: inv_into_def)

lemma inv_into_into: "x : f ` A ==> inv_into A f x : A"
apply (simp add: inv_into_def)
apply (fast intro: someI2)
done

lemma inv_id [simp]: "inv id = id"
by (simp add: inv_into_def id_def)

lemma inv_into_f_f [simp]:
  "[| inj_on f A;  x : A |] ==> inv_into A f (f x) = x"
apply (simp add: inv_into_def inj_on_def)
apply (blast intro: someI2)
done

lemma inv_f_f: "inj f ==> inv f (f x) = x"
by simp

lemma f_inv_into_f: "y : f`A  ==> f (inv_into A f y) = y"
apply (simp add: inv_into_def)
apply (fast intro: someI2)
done

lemma inv_into_f_eq: "[| inj_on f A; x : A; f x = y |] ==> inv_into A f y = x"
apply (erule subst)
apply (fast intro: inv_into_f_f)
done

lemma inv_f_eq: "[| inj f; f x = y |] ==> inv f y = x"
by (simp add:inv_into_f_eq)

lemma inj_imp_inv_eq: "[| inj f; ALL x. f(g x) = x |] ==> inv f = g"
  by (blast intro: inv_into_f_eq)

text{*But is it useful?*}
lemma inj_transfer:
  assumes injf: "inj f" and minor: "!!y. y \<in> range(f) ==> P(inv f y)"
  shows "P x"
proof -
  have "f x \<in> range f" by auto
  hence "P(inv f (f x))" by (rule minor)
  thus "P x" by (simp add: inv_into_f_f [OF injf])
qed

lemma inj_iff: "(inj f) = (inv f o f = id)"
apply (simp add: o_def fun_eq_iff)
apply (blast intro: inj_on_inverseI inv_into_f_f)
done

lemma inv_o_cancel[simp]: "inj f ==> inv f o f = id"
by (simp add: inj_iff)

lemma o_inv_o_cancel[simp]: "inj f ==> g o inv f o f = g"
by (simp add: comp_assoc)

lemma inv_into_image_cancel[simp]:
  "inj_on f A ==> S <= A ==> inv_into A f ` f ` S = S"
by(fastforce simp: image_def)

lemma inj_imp_surj_inv: "inj f ==> surj (inv f)"
by (blast intro!: surjI inv_into_f_f)

lemma surj_f_inv_f: "surj f ==> f(inv f y) = y"
by (simp add: f_inv_into_f)

lemma inv_into_injective:
  assumes eq: "inv_into A f x = inv_into A f y"
      and x: "x: f`A"
      and y: "y: f`A"
  shows "x=y"
proof -
  have "f (inv_into A f x) = f (inv_into A f y)" using eq by simp
  thus ?thesis by (simp add: f_inv_into_f x y)
qed

lemma inj_on_inv_into: "B <= f`A ==> inj_on (inv_into A f) B"
by (blast intro: inj_onI dest: inv_into_injective injD)

lemma bij_betw_inv_into: "bij_betw f A B ==> bij_betw (inv_into A f) B A"
by (auto simp add: bij_betw_def inj_on_inv_into)

lemma surj_imp_inj_inv: "surj f ==> inj (inv f)"
by (simp add: inj_on_inv_into)

lemma surj_iff: "(surj f) = (f o inv f = id)"
by (auto intro!: surjI simp: surj_f_inv_f fun_eq_iff[where 'b='a])

lemma surj_iff_all: "surj f \<longleftrightarrow> (\<forall>x. f (inv f x) = x)"
  unfolding surj_iff by (simp add: o_def fun_eq_iff)

lemma surj_imp_inv_eq: "[| surj f; \<forall>x. g(f x) = x |] ==> inv f = g"
apply (rule ext)
apply (drule_tac x = "inv f x" in spec)
apply (simp add: surj_f_inv_f)
done

lemma bij_imp_bij_inv: "bij f ==> bij (inv f)"
by (simp add: bij_def inj_imp_surj_inv surj_imp_inj_inv)

lemma inv_equality: "[| !!x. g (f x) = x;  !!y. f (g y) = y |] ==> inv f = g"
apply (rule ext)
apply (auto simp add: inv_into_def)
done

lemma inv_inv_eq: "bij f ==> inv (inv f) = f"
apply (rule inv_equality)
apply (auto simp add: bij_def surj_f_inv_f)
done

(** bij(inv f) implies little about f.  Consider f::bool=>bool such that
    f(True)=f(False)=True.  Then it's consistent with axiom someI that
    inv f could be any function at all, including the identity function.
    If inv f=id then inv f is a bijection, but inj f, surj(f) and
    inv(inv f)=f all fail.
**)

lemma inv_into_comp:
  "[| inj_on f (g ` A); inj_on g A; x : f ` g ` A |] ==>
  inv_into A (f o g) x = (inv_into A g o inv_into (g ` A) f) x"
apply (rule inv_into_f_eq)
  apply (fast intro: comp_inj_on)
 apply (simp add: inv_into_into)
apply (simp add: f_inv_into_f inv_into_into)
done

lemma o_inv_distrib: "[| bij f; bij g |] ==> inv (f o g) = inv g o inv f"
apply (rule inv_equality)
apply (auto simp add: bij_def surj_f_inv_f)
done

lemma image_surj_f_inv_f: "surj f ==> f ` (inv f ` A) = A"
by (simp add: image_eq_UN surj_f_inv_f)

lemma image_inv_f_f: "inj f ==> inv f ` (f ` A) = A"
  by (simp add: image_eq_UN)

lemma inv_image_comp: "inj f ==> inv f ` (f ` X) = X"
  by (fact image_inv_f_f)

lemma bij_image_Collect_eq: "bij f ==> f ` Collect P = {y. P (inv f y)}"
apply auto
apply (force simp add: bij_is_inj)
apply (blast intro: bij_is_surj [THEN surj_f_inv_f, symmetric])
done

lemma bij_vimage_eq_inv_image: "bij f ==> f -` A = inv f ` A"
apply (auto simp add: bij_is_surj [THEN surj_f_inv_f])
apply (blast intro: bij_is_inj [THEN inv_into_f_f, symmetric])
done

lemma finite_fun_UNIVD1:
  assumes fin: "finite (UNIV :: ('a \<Rightarrow> 'b) set)"
  and card: "card (UNIV :: 'b set) \<noteq> Suc 0"
  shows "finite (UNIV :: 'a set)"
proof -
  from fin have finb: "finite (UNIV :: 'b set)" by (rule finite_fun_UNIVD2)
  with card have "card (UNIV :: 'b set) \<ge> Suc (Suc 0)"
    by (cases "card (UNIV :: 'b set)") (auto simp add: card_eq_0_iff)
  then obtain n where "card (UNIV :: 'b set) = Suc (Suc n)" "n = card (UNIV :: 'b set) - Suc (Suc 0)" by auto
  then obtain b1 b2 where b1b2: "(b1 :: 'b) \<noteq> (b2 :: 'b)" by (auto simp add: card_Suc_eq)
  from fin have "finite (range (\<lambda>f :: 'a \<Rightarrow> 'b. inv f b1))" by (rule finite_imageI)
  moreover have "UNIV = range (\<lambda>f :: 'a \<Rightarrow> 'b. inv f b1)"
  proof (rule UNIV_eq_I)
    fix x :: 'a
    from b1b2 have "x = inv (\<lambda>y. if y = x then b1 else b2) b1" by (simp add: inv_into_def)
    thus "x \<in> range (\<lambda>f\<Colon>'a \<Rightarrow> 'b. inv f b1)" by blast
  qed
  ultimately show "finite (UNIV :: 'a set)" by simp
qed

text {*
  Every infinite set contains a countable subset. More precisely we
  show that a set @{text S} is infinite if and only if there exists an
  injective function from the naturals into @{text S}.

  The ``only if'' direction is harder because it requires the
  construction of a sequence of pairwise different elements of an
  infinite set @{text S}. The idea is to construct a sequence of
  non-empty and infinite subsets of @{text S} obtained by successively
  removing elements of @{text S}.
*}

lemma infinite_countable_subset:
  assumes inf: "\<not> finite (S::'a set)"
  shows "\<exists>f. inj (f::nat \<Rightarrow> 'a) \<and> range f \<subseteq> S"
  -- {* Courtesy of Stephan Merz *}
proof -
  def Sseq \<equiv> "rec_nat S (\<lambda>n T. T - {SOME e. e \<in> T})"
  def pick \<equiv> "\<lambda>n. (SOME e. e \<in> Sseq n)"
  { fix n have "Sseq n \<subseteq> S" "\<not> finite (Sseq n)" by (induct n) (auto simp add: Sseq_def inf) }
  moreover then have *: "\<And>n. pick n \<in> Sseq n"
    unfolding pick_def by (subst (asm) finite.simps) (auto simp add: ex_in_conv intro: someI_ex)
  ultimately have "range pick \<subseteq> S" by auto
  moreover
  { fix n m
    have "pick n \<notin> Sseq (n + Suc m)" by (induct m) (auto simp add: Sseq_def pick_def)
    with * have "pick n \<noteq> pick (n + Suc m)" by auto
  }
  then have "inj pick" by (intro linorder_injI) (auto simp add: less_iff_Suc_add)
  ultimately show ?thesis by blast
qed

lemma infinite_iff_countable_subset: "\<not> finite S \<longleftrightarrow> (\<exists>f. inj (f::nat \<Rightarrow> 'a) \<and> range f \<subseteq> S)"
  -- {* Courtesy of Stephan Merz *}
  using finite_imageD finite_subset infinite_UNIV_char_0 infinite_countable_subset by auto

lemma image_inv_into_cancel:
  assumes SURJ: "f`A=A'" and SUB: "B' \<le> A'"
  shows "f `((inv_into A f)`B') = B'"
  using assms
proof (auto simp add: f_inv_into_f)
  let ?f' = "(inv_into A f)"
  fix a' assume *: "a' \<in> B'"
  then have "a' \<in> A'" using SUB by auto
  then have "a' = f (?f' a')"
    using SURJ by (auto simp add: f_inv_into_f)
  then show "a' \<in> f ` (?f' ` B')" using * by blast
qed

lemma inv_into_inv_into_eq:
  assumes "bij_betw f A A'" "a \<in> A"
  shows "inv_into A' (inv_into A f) a = f a"
proof -
  let ?f' = "inv_into A f"   let ?f'' = "inv_into A' ?f'"
  have 1: "bij_betw ?f' A' A" using assms
  by (auto simp add: bij_betw_inv_into)
  obtain a' where 2: "a' \<in> A'" and 3: "?f' a' = a"
    using 1 `a \<in> A` unfolding bij_betw_def by force
  hence "?f'' a = a'"
    using `a \<in> A` 1 3 by (auto simp add: f_inv_into_f bij_betw_def)
  moreover have "f a = a'" using assms 2 3
    by (auto simp add: bij_betw_def)
  ultimately show "?f'' a = f a" by simp
qed

lemma inj_on_iff_surj:
  assumes "A \<noteq> {}"
  shows "(\<exists>f. inj_on f A \<and> f ` A \<le> A') \<longleftrightarrow> (\<exists>g. g ` A' = A)"
proof safe
  fix f assume INJ: "inj_on f A" and INCL: "f ` A \<le> A'"
  let ?phi = "\<lambda>a' a. a \<in> A \<and> f a = a'"  let ?csi = "\<lambda>a. a \<in> A"
  let ?g = "\<lambda>a'. if a' \<in> f ` A then (SOME a. ?phi a' a) else (SOME a. ?csi a)"
  have "?g ` A' = A"
  proof
    show "?g ` A' \<le> A"
    proof clarify
      fix a' assume *: "a' \<in> A'"
      show "?g a' \<in> A"
      proof cases
        assume Case1: "a' \<in> f ` A"
        then obtain a where "?phi a' a" by blast
        hence "?phi a' (SOME a. ?phi a' a)" using someI[of "?phi a'" a] by blast
        with Case1 show ?thesis by auto
      next
        assume Case2: "a' \<notin> f ` A"
        hence "?csi (SOME a. ?csi a)" using assms someI_ex[of ?csi] by blast
        with Case2 show ?thesis by auto
      qed
    qed
  next
    show "A \<le> ?g ` A'"
    proof-
      {fix a assume *: "a \<in> A"
       let ?b = "SOME aa. ?phi (f a) aa"
       have "?phi (f a) a" using * by auto
       hence 1: "?phi (f a) ?b" using someI[of "?phi(f a)" a] by blast
       hence "?g(f a) = ?b" using * by auto
       moreover have "a = ?b" using 1 INJ * by (auto simp add: inj_on_def)
       ultimately have "?g(f a) = a" by simp
       with INCL * have "?g(f a) = a \<and> f a \<in> A'" by auto
      }
      thus ?thesis by force
    qed
  qed
  thus "\<exists>g. g ` A' = A" by blast
next
  fix g  let ?f = "inv_into A' g"
  have "inj_on ?f (g ` A')"
    by (auto simp add: inj_on_inv_into)
  moreover
  {fix a' assume *: "a' \<in> A'"
   let ?phi = "\<lambda> b'. b' \<in> A' \<and> g b' = g a'"
   have "?phi a'" using * by auto
   hence "?phi(SOME b'. ?phi b')" using someI[of ?phi] by blast
   hence "?f(g a') \<in> A'" unfolding inv_into_def by auto
  }
  ultimately show "\<exists>f. inj_on f (g ` A') \<and> f ` g ` A' \<subseteq> A'" by auto
qed

lemma Ex_inj_on_UNION_Sigma:
  "\<exists>f. (inj_on f (\<Union> i \<in> I. A i) \<and> f ` (\<Union> i \<in> I. A i) \<le> (SIGMA i : I. A i))"
proof
  let ?phi = "\<lambda> a i. i \<in> I \<and> a \<in> A i"
  let ?sm = "\<lambda> a. SOME i. ?phi a i"
  let ?f = "\<lambda>a. (?sm a, a)"
  have "inj_on ?f (\<Union> i \<in> I. A i)" unfolding inj_on_def by auto
  moreover
  { { fix i a assume "i \<in> I" and "a \<in> A i"
      hence "?sm a \<in> I \<and> a \<in> A(?sm a)" using someI[of "?phi a" i] by auto
    }
    hence "?f ` (\<Union> i \<in> I. A i) \<le> (SIGMA i : I. A i)" by auto
  }
  ultimately
  show "inj_on ?f (\<Union> i \<in> I. A i) \<and> ?f ` (\<Union> i \<in> I. A i) \<le> (SIGMA i : I. A i)"
  by auto
qed

lemma inv_unique_comp:
  assumes fg: "f \<circ> g = id"
    and gf: "g \<circ> f = id"
  shows "inv f = g"
  using fg gf inv_equality[of g f] by (auto simp add: fun_eq_iff)

subsection {* The Cantor-Bernstein Theorem *}

lemma Cantor_Bernstein_aux:
  shows "\<exists>A' h. A' \<le> A \<and>
                (\<forall>a \<in> A'. a \<notin> g`(B - f ` A')) \<and>
                (\<forall>a \<in> A'. h a = f a) \<and>
                (\<forall>a \<in> A - A'. h a \<in> B - (f ` A') \<and> a = g(h a))"
proof-
  obtain H where H_def: "H = (\<lambda> A'. A - (g`(B - (f ` A'))))" by blast
  have 0: "mono H" unfolding mono_def H_def by blast
  then obtain A' where 1: "H A' = A'" using lfp_unfold by blast
  hence 2: "A' = A - (g`(B - (f ` A')))" unfolding H_def by simp
  hence 3: "A' \<le> A" by blast
  have 4: "\<forall>a \<in> A'.  a \<notin> g`(B - f ` A')"
  using 2 by blast
  have 5: "\<forall>a \<in> A - A'. \<exists>b \<in> B - (f ` A'). a = g b"
  using 2 by blast
  (*  *)
  obtain h where h_def:
  "h = (\<lambda> a. if a \<in> A' then f a else (SOME b. b \<in> B - (f ` A') \<and> a = g b))" by blast
  hence "\<forall>a \<in> A'. h a = f a" by auto
  moreover
  have "\<forall>a \<in> A - A'. h a \<in> B - (f ` A') \<and> a = g(h a)"
  proof
    fix a assume *: "a \<in> A - A'"
    let ?phi = "\<lambda> b. b \<in> B - (f ` A') \<and> a = g b"
    have "h a = (SOME b. ?phi b)" using h_def * by auto
    moreover have "\<exists>b. ?phi b" using 5 *  by auto
    ultimately show  "?phi (h a)" using someI_ex[of ?phi] by auto
  qed
  ultimately show ?thesis using 3 4 by blast
qed

theorem Cantor_Bernstein:
  assumes INJ1: "inj_on f A" and SUB1: "f ` A \<le> B" and
          INJ2: "inj_on g B" and SUB2: "g ` B \<le> A"
  shows "\<exists>h. bij_betw h A B"
proof-
  obtain A' and h where 0: "A' \<le> A" and
  1: "\<forall>a \<in> A'. a \<notin> g`(B - f ` A')" and
  2: "\<forall>a \<in> A'. h a = f a" and
  3: "\<forall>a \<in> A - A'. h a \<in> B - (f ` A') \<and> a = g(h a)"
  using Cantor_Bernstein_aux[of A g B f] by blast
  have "inj_on h A"
  proof (intro inj_onI)
    fix a1 a2
    assume 4: "a1 \<in> A" and 5: "a2 \<in> A" and 6: "h a1 = h a2"
    show "a1 = a2"
    proof(cases "a1 \<in> A'")
      assume Case1: "a1 \<in> A'"
      show ?thesis
      proof(cases "a2 \<in> A'")
        assume Case11: "a2 \<in> A'"
        hence "f a1 = f a2" using Case1 2 6 by auto
        thus ?thesis using INJ1 Case1 Case11 0
        unfolding inj_on_def by blast
      next
        assume Case12: "a2 \<notin> A'"
        hence False using 3 5 2 6 Case1 by force
        thus ?thesis by simp
      qed
    next
    assume Case2: "a1 \<notin> A'"
      show ?thesis
      proof(cases "a2 \<in> A'")
        assume Case21: "a2 \<in> A'"
        hence False using 3 4 2 6 Case2 by auto
        thus ?thesis by simp
      next
        assume Case22: "a2 \<notin> A'"
        hence "a1 = g(h a1) \<and> a2 = g(h a2)" using Case2 4 5 3 by auto
        thus ?thesis using 6 by simp
      qed
    qed
  qed
  (*  *)
  moreover
  have "h ` A = B"
  proof safe
    fix a assume "a \<in> A"
    thus "h a \<in> B" using SUB1 2 3 by (cases "a \<in> A'") auto
  next
    fix b assume *: "b \<in> B"
    show "b \<in> h ` A"
    proof(cases "b \<in> f ` A'")
      assume Case1: "b \<in> f ` A'"
      then obtain a where "a \<in> A' \<and> b = f a" by blast
      thus ?thesis using 2 0 by force
    next
      assume Case2: "b \<notin> f ` A'"
      hence "g b \<notin> A'" using 1 * by auto
      hence 4: "g b \<in> A - A'" using * SUB2 by auto
      hence "h(g b) \<in> B \<and> g(h(g b)) = g b"
      using 3 by auto
      hence "h(g b) = b" using * INJ2 unfolding inj_on_def by auto
      thus ?thesis using 4 by force
    qed
  qed
  (*  *)
  ultimately show ?thesis unfolding bij_betw_def by auto
qed

subsection {*Other Consequences of Hilbert's Epsilon*}

text {*Hilbert's Epsilon and the @{term split} Operator*}

text{*Looping simprule*}
lemma split_paired_Eps: "(SOME x. P x) = (SOME (a,b). P(a,b))"
  by simp

lemma Eps_split: "Eps (split P) = (SOME xy. P (fst xy) (snd xy))"
  by (simp add: split_def)

lemma Eps_split_eq [simp]: "(@(x',y'). x = x' & y = y') = (x,y)"
  by blast

text{*A relation is wellfounded iff it has no infinite descending chain*}
lemma wf_iff_no_infinite_down_chain:
  "wf r = (~(\<exists>f. \<forall>i. (f(Suc i),f i) \<in> r))"
apply (simp only: wf_eq_minimal)
apply (rule iffI)
 apply (rule notI)
 apply (erule exE)
 apply (erule_tac x = "{w. \<exists>i. w=f i}" in allE, blast)
apply (erule contrapos_np, simp, clarify)
apply (subgoal_tac "\<forall>n. rec_nat x (%i y. @z. z:Q & (z,y) :r) n \<in> Q")
 apply (rule_tac x = "rec_nat x (%i y. @z. z:Q & (z,y) :r)" in exI)
 apply (rule allI, simp)
 apply (rule someI2_ex, blast, blast)
apply (rule allI)
apply (induct_tac "n", simp_all)
apply (rule someI2_ex, blast+)
done

lemma wf_no_infinite_down_chainE:
  assumes "wf r" obtains k where "(f (Suc k), f k) \<notin> r"
using `wf r` wf_iff_no_infinite_down_chain[of r] by blast

text{*A dynamically-scoped fact for TFL *}
lemma tfl_some: "\<forall>P x. P x --> P (Eps P)"
  by (blast intro: someI)

subsection {* Least value operator *}

definition
  LeastM :: "['a => 'b::ord, 'a => bool] => 'a" where
  "LeastM m P == SOME x. P x & (\<forall>y. P y --> m x <= m y)"

syntax
  "_LeastM" :: "[pttrn, 'a => 'b::ord, bool] => 'a"    ("LEAST _ WRT _. _" [0, 4, 10] 10)
translations
  "LEAST x WRT m. P" == "CONST LeastM m (%x. P)"

lemma LeastMI2:
  "P x ==> (!!y. P y ==> m x <= m y)
    ==> (!!x. P x ==> \<forall>y. P y --> m x \<le> m y ==> Q x)
    ==> Q (LeastM m P)"
  apply (simp add: LeastM_def)
  apply (rule someI2_ex, blast, blast)
  done

lemma LeastM_equality:
  "P k ==> (!!x. P x ==> m k <= m x)
    ==> m (LEAST x WRT m. P x) = (m k::'a::order)"
  apply (rule LeastMI2, assumption, blast)
  apply (blast intro!: order_antisym)
  done

lemma wf_linord_ex_has_least:
  "wf r ==> \<forall>x y. ((x,y):r^+) = ((y,x)~:r^*) ==> P k
    ==> \<exists>x. P x & (!y. P y --> (m x,m y):r^*)"
  apply (drule wf_trancl [THEN wf_eq_minimal [THEN iffD1]])
  apply (drule_tac x = "m`Collect P" in spec, force)
  done

lemma ex_has_least_nat:
    "P k ==> \<exists>x. P x & (\<forall>y. P y --> m x <= (m y::nat))"
  apply (simp only: pred_nat_trancl_eq_le [symmetric])
  apply (rule wf_pred_nat [THEN wf_linord_ex_has_least])
   apply (simp add: less_eq linorder_not_le pred_nat_trancl_eq_le, assumption)
  done

lemma LeastM_nat_lemma:
    "P k ==> P (LeastM m P) & (\<forall>y. P y --> m (LeastM m P) <= (m y::nat))"
  apply (simp add: LeastM_def)
  apply (rule someI_ex)
  apply (erule ex_has_least_nat)
  done

lemmas LeastM_natI = LeastM_nat_lemma [THEN conjunct1]

lemma LeastM_nat_le: "P x ==> m (LeastM m P) <= (m x::nat)"
by (rule LeastM_nat_lemma [THEN conjunct2, THEN spec, THEN mp], assumption, assumption)

subsection {* Greatest value operator *}

definition
  GreatestM :: "['a => 'b::ord, 'a => bool] => 'a" where
  "GreatestM m P == SOME x. P x & (\<forall>y. P y --> m y <= m x)"

definition
  Greatest :: "('a::ord => bool) => 'a" (binder "GREATEST " 10) where
  "Greatest == GreatestM (%x. x)"

syntax
  "_GreatestM" :: "[pttrn, 'a => 'b::ord, bool] => 'a"
      ("GREATEST _ WRT _. _" [0, 4, 10] 10)
translations
  "GREATEST x WRT m. P" == "CONST GreatestM m (%x. P)"

lemma GreatestMI2:
  "P x ==> (!!y. P y ==> m y <= m x)
    ==> (!!x. P x ==> \<forall>y. P y --> m y \<le> m x ==> Q x)
    ==> Q (GreatestM m P)"
  apply (simp add: GreatestM_def)
  apply (rule someI2_ex, blast, blast)
  done

lemma GreatestM_equality:
 "P k ==> (!!x. P x ==> m x <= m k)
    ==> m (GREATEST x WRT m. P x) = (m k::'a::order)"
  apply (rule_tac m = m in GreatestMI2, assumption, blast)
  apply (blast intro!: order_antisym)
  done

lemma Greatest_equality:
  "P (k::'a::order) ==> (!!x. P x ==> x <= k) ==> (GREATEST x. P x) = k"
  apply (simp add: Greatest_def)
  apply (erule GreatestM_equality, blast)
  done

lemma ex_has_greatest_nat_lemma:
  "P k ==> \<forall>x. P x --> (\<exists>y. P y & ~ ((m y::nat) <= m x))
    ==> \<exists>y. P y & ~ (m y < m k + n)"
  apply (induct n, force)
  apply (force simp add: le_Suc_eq)
  done

lemma ex_has_greatest_nat:
  "P k ==> \<forall>y. P y --> m y < b
    ==> \<exists>x. P x & (\<forall>y. P y --> (m y::nat) <= m x)"
  apply (rule ccontr)
  apply (cut_tac P = P and n = "b - m k" in ex_has_greatest_nat_lemma)
    apply (subgoal_tac [3] "m k <= b", auto)
  done

lemma GreatestM_nat_lemma:
  "P k ==> \<forall>y. P y --> m y < b
    ==> P (GreatestM m P) & (\<forall>y. P y --> (m y::nat) <= m (GreatestM m P))"
  apply (simp add: GreatestM_def)
  apply (rule someI_ex)
  apply (erule ex_has_greatest_nat, assumption)
  done

lemmas GreatestM_natI = GreatestM_nat_lemma [THEN conjunct1]

lemma GreatestM_nat_le:
  "P x ==> \<forall>y. P y --> m y < b
    ==> (m x::nat) <= m (GreatestM m P)"
  apply (blast dest: GreatestM_nat_lemma [THEN conjunct2, THEN spec, of P])
  done

text {* \medskip Specialization to @{text GREATEST}. *}

lemma GreatestI: "P (k::nat) ==> \<forall>y. P y --> y < b ==> P (GREATEST x. P x)"
  apply (simp add: Greatest_def)
  apply (rule GreatestM_natI, auto)
  done

lemma Greatest_le:
    "P x ==> \<forall>y. P y --> y < b ==> (x::nat) <= (GREATEST x. P x)"
  apply (simp add: Greatest_def)
  apply (rule GreatestM_nat_le, auto)
  done

subsection {* An aside: bounded accessible part *}

text {* Finite monotone eventually stable sequences *}

lemma finite_mono_remains_stable_implies_strict_prefix:
  fixes f :: "nat \<Rightarrow> 'a::order"
  assumes S: "finite (range f)" "mono f" and eq: "\<forall>n. f n = f (Suc n) \<longrightarrow> f (Suc n) = f (Suc (Suc n))"
  shows "\<exists>N. (\<forall>n\<le>N. \<forall>m\<le>N. m < n \<longrightarrow> f m < f n) \<and> (\<forall>n\<ge>N. f N = f n)"
  using assms
proof -
  have "\<exists>n. f n = f (Suc n)"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "\<And>n. f n \<noteq> f (Suc n)" by auto
    then have "\<And>n. f n < f (Suc n)"
      using  `mono f` by (auto simp: le_less mono_iff_le_Suc)
    with lift_Suc_mono_less_iff[of f]
    have *: "\<And>n m. n < m \<Longrightarrow> f n < f m" by auto
    have "inj f"
    proof (intro injI)
      fix x y
      assume "f x = f y"
      then show "x = y" by (cases x y rule: linorder_cases) (auto dest: *)
    qed
    with `finite (range f)` have "finite (UNIV::nat set)"
      by (rule finite_imageD)
    then show False by simp
  qed
  then obtain n where n: "f n = f (Suc n)" ..
  def N \<equiv> "LEAST n. f n = f (Suc n)"
  have N: "f N = f (Suc N)"
    unfolding N_def using n by (rule LeastI)
  show ?thesis
  proof (intro exI[of _ N] conjI allI impI)
    fix n assume "N \<le> n"
    then have "\<And>m. N \<le> m \<Longrightarrow> m \<le> n \<Longrightarrow> f m = f N"
    proof (induct rule: dec_induct)
      case (step n) then show ?case
        using eq[rule_format, of "n - 1"] N
        by (cases n) (auto simp add: le_Suc_eq)
    qed simp
    from this[of n] `N \<le> n` show "f N = f n" by auto
  next
    fix n m :: nat assume "m < n" "n \<le> N"
    then show "f m < f n"
    proof (induct rule: less_Suc_induct[consumes 1])
      case (1 i)
      then have "i < N" by simp
      then have "f i \<noteq> f (Suc i)"
        unfolding N_def by (rule not_less_Least)
      with `mono f` show ?case by (simp add: mono_iff_le_Suc less_le)
    qed auto
  qed
qed

lemma finite_mono_strict_prefix_implies_finite_fixpoint:
  fixes f :: "nat \<Rightarrow> 'a set"
  assumes S: "\<And>i. f i \<subseteq> S" "finite S"
    and inj: "\<exists>N. (\<forall>n\<le>N. \<forall>m\<le>N. m < n \<longrightarrow> f m \<subset> f n) \<and> (\<forall>n\<ge>N. f N = f n)"
  shows "f (card S) = (\<Union>n. f n)"
proof -
  from inj obtain N where inj: "(\<forall>n\<le>N. \<forall>m\<le>N. m < n \<longrightarrow> f m \<subset> f n)" and eq: "(\<forall>n\<ge>N. f N = f n)" by auto

  { fix i have "i \<le> N \<Longrightarrow> i \<le> card (f i)"
    proof (induct i)
      case 0 then show ?case by simp
    next
      case (Suc i)
      with inj[rule_format, of "Suc i" i]
      have "(f i) \<subset> (f (Suc i))" by auto
      moreover have "finite (f (Suc i))" using S by (rule finite_subset)
      ultimately have "card (f i) < card (f (Suc i))" by (intro psubset_card_mono)
      with Suc show ?case using inj by auto
    qed
  }
  then have "N \<le> card (f N)" by simp
  also have "\<dots> \<le> card S" using S by (intro card_mono)
  finally have "f (card S) = f N" using eq by auto
  then show ?thesis using eq inj[rule_format, of N]
    apply auto
    apply (case_tac "n < N")
    apply (auto simp: not_less)
    done
qed

subsection {* More on injections, bijections, and inverses *}

lemma infinite_imp_bij_betw:
assumes INF: "\<not> finite A"
shows "\<exists>h. bij_betw h A (A - {a})"
proof(cases "a \<in> A")
  assume Case1: "a \<notin> A"  hence "A - {a} = A" by blast
  thus ?thesis using bij_betw_id[of A] by auto
next
  assume Case2: "a \<in> A"
  have "\<not> finite (A - {a})" using INF by auto
  with infinite_iff_countable_subset[of "A - {a}"] obtain f::"nat \<Rightarrow> 'a"
  where 1: "inj f" and 2: "f ` UNIV \<le> A - {a}" by blast
  obtain g where g_def: "g = (\<lambda> n. if n = 0 then a else f (Suc n))" by blast
  obtain A' where A'_def: "A' = g ` UNIV" by blast
  have temp: "\<forall>y. f y \<noteq> a" using 2 by blast
  have 3: "inj_on g UNIV \<and> g ` UNIV \<le> A \<and> a \<in> g ` UNIV"
  proof(auto simp add: Case2 g_def, unfold inj_on_def, intro ballI impI,
        case_tac "x = 0", auto simp add: 2)
    fix y  assume "a = (if y = 0 then a else f (Suc y))"
    thus "y = 0" using temp by (case_tac "y = 0", auto)
  next
    fix x y
    assume "f (Suc x) = (if y = 0 then a else f (Suc y))"
    thus "x = y" using 1 temp unfolding inj_on_def by (case_tac "y = 0", auto)
  next
    fix n show "f (Suc n) \<in> A" using 2 by blast
  qed
  hence 4: "bij_betw g UNIV A' \<and> a \<in> A' \<and> A' \<le> A"
  using inj_on_imp_bij_betw[of g] unfolding A'_def by auto
  hence 5: "bij_betw (inv g) A' UNIV"
  by (auto simp add: bij_betw_inv_into)
  (*  *)
  obtain n where "g n = a" using 3 by auto
  hence 6: "bij_betw g (UNIV - {n}) (A' - {a})"
  using 3 4 unfolding A'_def
  by clarify (rule bij_betw_subset, auto simp: image_set_diff)
  (*  *)
  obtain v where v_def: "v = (\<lambda> m. if m < n then m else Suc m)" by blast
  have 7: "bij_betw v UNIV (UNIV - {n})"
  proof(unfold bij_betw_def inj_on_def, intro conjI, clarify)
    fix m1 m2 assume "v m1 = v m2"
    thus "m1 = m2"
    by(case_tac "m1 < n", case_tac "m2 < n",
       auto simp add: inj_on_def v_def, case_tac "m2 < n", auto)
  next
    show "v ` UNIV = UNIV - {n}"
    proof(auto simp add: v_def)
      fix m assume *: "m \<noteq> n" and **: "m \<notin> Suc ` {m'. \<not> m' < n}"
      {assume "n \<le> m" with * have 71: "Suc n \<le> m" by auto
       then obtain m' where 72: "m = Suc m'" using Suc_le_D by auto
       with 71 have "n \<le> m'" by auto
       with 72 ** have False by auto
      }
      thus "m < n" by force
    qed
  qed
  (*  *)
  obtain h' where h'_def: "h' = g o v o (inv g)" by blast
  hence 8: "bij_betw h' A' (A' - {a})" using 5 7 6
  by (auto simp add: bij_betw_trans)
  (*  *)
  obtain h where h_def: "h = (\<lambda> b. if b \<in> A' then h' b else b)" by blast
  have "\<forall>b \<in> A'. h b = h' b" unfolding h_def by auto
  hence "bij_betw h  A' (A' - {a})" using 8 bij_betw_cong[of A' h] by auto
  moreover
  {have "\<forall>b \<in> A - A'. h b = b" unfolding h_def by auto
   hence "bij_betw h  (A - A') (A - A')"
   using bij_betw_cong[of "A - A'" h id] bij_betw_id[of "A - A'"] by auto
  }
  moreover
  have "(A' Int (A - A') = {} \<and> A' \<union> (A - A') = A) \<and>
        ((A' - {a}) Int (A - A') = {} \<and> (A' - {a}) \<union> (A - A') = A - {a})"
  using 4 by blast
  ultimately have "bij_betw h A (A - {a})"
  using bij_betw_combine[of h A' "A' - {a}" "A - A'" "A - A'"] by simp
  thus ?thesis by blast
qed

lemma infinite_imp_bij_betw2:
assumes INF: "\<not> finite A"
shows "\<exists>h. bij_betw h A (A \<union> {a})"
proof(cases "a \<in> A")
  assume Case1: "a \<in> A"  hence "A \<union> {a} = A" by blast
  thus ?thesis using bij_betw_id[of A] by auto
next
  let ?A' = "A \<union> {a}"
  assume Case2: "a \<notin> A" hence "A = ?A' - {a}" by blast
  moreover have "\<not> finite ?A'" using INF by auto
  ultimately obtain f where "bij_betw f ?A' A"
  using infinite_imp_bij_betw[of ?A' a] by auto
  hence "bij_betw(inv_into ?A' f) A ?A'" using bij_betw_inv_into by blast
  thus ?thesis by auto
qed

lemma bij_betw_inv_into_left:
assumes BIJ: "bij_betw f A A'" and IN: "a \<in> A"
shows "(inv_into A f) (f a) = a"
using assms unfolding bij_betw_def
by clarify (rule inv_into_f_f)

lemma bij_betw_inv_into_right:
assumes "bij_betw f A A'" "a' \<in> A'"
shows "f(inv_into A f a') = a'"
using assms unfolding bij_betw_def using f_inv_into_f by force

lemma bij_betw_inv_into_subset:
assumes BIJ: "bij_betw f A A'" and
        SUB: "B \<le> A" and IM: "f ` B = B'"
shows "bij_betw (inv_into A f) B' B"
using assms unfolding bij_betw_def
by (auto intro: inj_on_inv_into)

subsection {* Specification package -- Hilbertized version *}

lemma exE_some: "[| Ex P ; c == Eps P |] ==> P c"
  by (simp only: someI_ex)

ML_file "Tools/choice_specification.ML"

end


(*<*)theory Pairs imports Main begin(*>*)

section{*Pairs and Tuples*}

text{*\label{sec:products}
Ordered pairs were already introduced in \S\ref{sec:pairs}, but only with a minimal
repertoire of operations: pairing and the two projections @{term fst} and
@{term snd}. In any non-trivial application of pairs you will find that this
quickly leads to unreadable nests of projections. This
section introduces syntactic sugar to overcome this
problem: pattern matching with tuples.
*}

subsection{*Pattern Matching with Tuples*}

text{*
Tuples may be used as patterns in $\lambda$-abstractions,
for example @{text"\<lambda>(x,y,z).x+y+z"} and @{text"\<lambda>((x,y),z).x+y+z"}. In fact,
tuple patterns can be used in most variable binding constructs,
and they can be nested. Here are
some typical examples:
\begin{quote}
@{term"let (x,y) = f z in (y,x)"}\\
@{term"case xs of [] => (0::nat) | (x,y)#zs => x+y"}\\
@{text"\<forall>(x,y)\<in>A. x=y"}\\
@{text"{(x,y,z). x=z}"}\\
@{term"\<Union>(x,y)\<in>A. {x+y}"}
\end{quote}
The intuitive meanings of these expressions should be obvious.
Unfortunately, we need to know in more detail what the notation really stands
for once we have to reason about it.  Abstraction
over pairs and tuples is merely a convenient shorthand for a more complex
internal representation.  Thus the internal and external form of a term may
differ, which can affect proofs. If you want to avoid this complication,
stick to @{term fst} and @{term snd} and write @{term"%p. fst p + snd p"}
instead of @{text"\<lambda>(x,y). x+y"}.  These terms are distinct even though they
denote the same function.

Internally, @{term"%(x,y). t"} becomes @{text"split (\<lambda>x y. t)"}, where
\cdx{split} is the uncurrying function of type @{text"('a \<Rightarrow> 'b
\<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c"} defined as
\begin{center}
@{thm split_def}
\hfill(@{thm[source]split_def})
\end{center}
Pattern matching in
other variable binding constructs is translated similarly. Thus we need to
understand how to reason about such constructs.
*}

subsection{*Theorem Proving*}

text{*
The most obvious approach is the brute force expansion of @{term split}:
*}

lemma "(\<lambda>(x,y).x) p = fst p"
by(simp add: split_def)

text{* \noindent
This works well if rewriting with @{thm[source]split_def} finishes the
proof, as it does above.  But if it does not, you end up with exactly what
we are trying to avoid: nests of @{term fst} and @{term snd}. Thus this
approach is neither elegant nor very practical in large examples, although it
can be effective in small ones.

If we consider why this lemma presents a problem,
we realize that we need to replace variable~@{term
p} by some pair @{term"(a,b)"}.  Then both sides of the
equation would simplify to @{term a} by the simplification rules
@{thm split_conv[no_vars]} and @{thm fst_conv[no_vars]}.
To reason about tuple patterns requires some way of
converting a variable of product type into a pair.
In case of a subterm of the form @{term"split f p"} this is easy: the split
rule @{thm[source]split_split} replaces @{term p} by a pair:%
\index{*split (method)}
*}

lemma "(\<lambda>(x,y).y) p = snd p"
apply(split split_split)

txt{*
@{subgoals[display,indent=0]}
This subgoal is easily proved by simplification. Thus we could have combined
simplification and splitting in one command that proves the goal outright:
*}
(*<*)
by simp
lemma "(\<lambda>(x,y).y) p = snd p"(*>*)
by(simp split: split_split)

text{*
Let us look at a second example:
*}

lemma "let (x,y) = p in fst p = x"
apply(simp only: Let_def)

txt{*
@{subgoals[display,indent=0]}
A paired @{text let} reduces to a paired $\lambda$-abstraction, which
can be split as above. The same is true for paired set comprehension:
*}

(*<*)by(simp split: split_split)(*>*)
lemma "p \<in> {(x,y). x=y} \<longrightarrow> fst p = snd p"
apply simp

txt{*
@{subgoals[display,indent=0]}
Again, simplification produces a term suitable for @{thm[source]split_split}
as above. If you are worried about the strange form of the premise:
@{text"split (op =)"} is short for @{term"\<lambda>(x,y). x=y"}.
The same proof procedure works for
*}

(*<*)by(simp split: split_split)(*>*)
lemma "p \<in> {(x,y). x=y} \<Longrightarrow> fst p = snd p"

txt{*\noindent
except that we now have to use @{thm[source]split_split_asm}, because
@{term split} occurs in the assumptions.

However, splitting @{term split} is not always a solution, as no @{term split}
may be present in the goal. Consider the following function:
*}

(*<*)by(simp split: split_split_asm)(*>*)
primrec swap :: "'a \<times> 'b \<Rightarrow> 'b \<times> 'a" where "swap (x,y) = (y,x)"

text{*\noindent
Note that the above \isacommand{primrec} definition is admissible
because @{text"\<times>"} is a datatype. When we now try to prove
*}

lemma "swap(swap p) = p"

txt{*\noindent
simplification will do nothing, because the defining equation for
@{const[source] swap} expects a pair. Again, we need to turn @{term p}
into a pair first, but this time there is no @{term split} in sight.
The only thing we can do is to split the term by hand:
*}
apply(case_tac p)

txt{*\noindent
@{subgoals[display,indent=0]}
Again, \methdx{case_tac} is applicable because @{text"\<times>"} is a datatype.
The subgoal is easily proved by @{text simp}.

Splitting by @{text case_tac} also solves the previous examples and may thus
appear preferable to the more arcane methods introduced first. However, see
the warning about @{text case_tac} in \S\ref{sec:struct-ind-case}.

Alternatively, you can split \emph{all} @{text"\<And>"}-quantified variables
in a goal with the rewrite rule @{thm[source]split_paired_all}:
*}

(*<*)by simp(*>*)
lemma "\<And>p q. swap(swap p) = q \<longrightarrow> p = q"
apply(simp only: split_paired_all)

txt{*\noindent
@{subgoals[display,indent=0,margin=70]}
*}

apply simp
done

text{*\noindent
Note that we have intentionally included only @{thm[source]split_paired_all}
in the first simplification step, and then we simplify again.
This time the reason was not merely
pedagogical:
@{thm[source]split_paired_all} may interfere with other functions
of the simplifier.
The following command could fail (here it does not)
where two separate \isa{simp} applications succeed.
*}

(*<*)
lemma "\<And>p q. swap(swap p) = q \<longrightarrow> p = q"
(*>*)
apply(simp add: split_paired_all)
(*<*)done(*>*)
text{*\noindent
Finally, the simplifier automatically splits all @{text"\<forall>"} and
@{text"\<exists>"}-quantified variables:
*}

lemma "\<forall>p. \<exists>q. swap p = swap q"
by simp

text{*\noindent
To turn off this automatic splitting, disable the
responsible simplification rules:
\begin{center}
@{thm split_paired_All[no_vars]}
\hfill
(@{thm[source]split_paired_All})\\
@{thm split_paired_Ex[no_vars]}
\hfill
(@{thm[source]split_paired_Ex})
\end{center}
*}
(*<*)
end
(*>*)


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

section \<open>Algebraic deflations are a bifinite domain\<close>

theory Defl_Bifinite
imports HOLCF "HOL-Library.Infinite_Set"
begin

subsection \<open>Lemmas about MOST\<close>

default_sort type

subsection \<open>Eventually constant sequences\<close>

definition
  eventually_constant :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "eventually_constant S = (\<exists>x. MOST i. S i = x)"

lemma eventually_constant_MOST_MOST:
  "eventually_constant S \<longleftrightarrow> (MOST m. MOST n. S n = S m)"
unfolding eventually_constant_def MOST_nat
apply safe
apply (rule_tac x=m in exI, clarify)
apply (rule_tac x=m in exI, clarify)
apply simp
apply fast
done

lemma eventually_constantI: "MOST i. S i = x \<Longrightarrow> eventually_constant S"
unfolding eventually_constant_def by fast

lemma eventually_constant_comp:
  "eventually_constant (\<lambda>i. S i) \<Longrightarrow> eventually_constant (\<lambda>i. f (S i))"
unfolding eventually_constant_def
apply (erule exE, rule_tac x="f x" in exI)
apply (erule MOST_mono, simp)
done

lemma eventually_constant_Suc_iff:
  "eventually_constant (\<lambda>i. S (Suc i)) \<longleftrightarrow> eventually_constant (\<lambda>i. S i)"
unfolding eventually_constant_def
by (subst MOST_Suc_iff, rule refl)

lemma eventually_constant_SucD:
  "eventually_constant (\<lambda>i. S (Suc i)) \<Longrightarrow> eventually_constant (\<lambda>i. S i)"
by (rule eventually_constant_Suc_iff [THEN iffD1])

subsection \<open>Limits of eventually constant sequences\<close>

definition
  eventual :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
  "eventual S = (THE x. MOST i. S i = x)"

lemma eventual_eqI: "MOST i. S i = x \<Longrightarrow> eventual S = x"
unfolding eventual_def
apply (rule the_equality, assumption)
apply (rename_tac y)
apply (subgoal_tac "MOST i::nat. y = x", simp)
apply (erule MOST_rev_mp)
apply (erule MOST_rev_mp)
apply simp
done

lemma MOST_eq_eventual:
  "eventually_constant S \<Longrightarrow> MOST i. S i = eventual S"
unfolding eventually_constant_def
by (erule exE, simp add: eventual_eqI)

lemma eventual_mem_range:
  "eventually_constant S \<Longrightarrow> eventual S \<in> range S"
apply (drule MOST_eq_eventual)
apply (simp only: MOST_nat_le, clarify)
apply (drule spec, drule mp, rule order_refl)
apply (erule range_eqI [OF sym])
done

lemma eventually_constant_MOST_iff:
  assumes S: "eventually_constant S"
  shows "(MOST n. P (S n)) \<longleftrightarrow> P (eventual S)"
apply (subgoal_tac "(MOST n. P (S n)) \<longleftrightarrow> (MOST n::nat. P (eventual S))")
apply simp
apply (rule iffI)
apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
apply (erule MOST_mono, force)
apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
apply (erule MOST_mono, simp)
done

lemma MOST_eventual:
  "\<lbrakk>eventually_constant S; MOST n. P (S n)\<rbrakk> \<Longrightarrow> P (eventual S)"
proof -
  assume "eventually_constant S"
  hence "MOST n. S n = eventual S"
    by (rule MOST_eq_eventual)
  moreover assume "MOST n. P (S n)"
  ultimately have "MOST n. S n = eventual S \<and> P (S n)"
    by (rule MOST_conj_distrib [THEN iffD2, OF conjI])
  hence "MOST n::nat. P (eventual S)"
    by (rule MOST_mono) auto
  thus ?thesis by simp
qed

lemma eventually_constant_MOST_Suc_eq:
  "eventually_constant S \<Longrightarrow> MOST n. S (Suc n) = S n"
apply (drule MOST_eq_eventual)
apply (frule MOST_Suc_iff [THEN iffD2])
apply (erule MOST_rev_mp)
apply (erule MOST_rev_mp)
apply simp
done

lemma eventual_comp:
  "eventually_constant S \<Longrightarrow> eventual (\<lambda>i. f (S i)) = f (eventual (\<lambda>i. S i))"
apply (rule eventual_eqI)
apply (rule MOST_mono)
apply (erule MOST_eq_eventual)
apply simp
done

subsection \<open>Constructing finite deflations by iteration\<close>

default_sort cpo

lemma le_Suc_induct:
  assumes le: "i \<le> j"
  assumes step: "\<And>i. P i (Suc i)"
  assumes refl: "\<And>i. P i i"
  assumes trans: "\<And>i j k. \<lbrakk>P i j; P j k\<rbrakk> \<Longrightarrow> P i k"
  shows "P i j"
proof (cases "i = j")
  assume "i = j"
  thus "P i j" by (simp add: refl)
next
  assume "i \<noteq> j"
  with le have "i < j" by simp
  thus "P i j" using step trans by (rule less_Suc_induct)
qed

definition
  eventual_iterate :: "('a \<rightarrow> 'a::cpo) \<Rightarrow> ('a \<rightarrow> 'a)"
where
  "eventual_iterate f = eventual (\<lambda>n. iterate n\<cdot>f)"

text \<open>A pre-deflation is like a deflation, but not idempotent.\<close>

locale pre_deflation =
  fixes f :: "'a \<rightarrow> 'a::cpo"
  assumes below: "\<And>x. f\<cdot>x \<sqsubseteq> x"
  assumes finite_range: "finite (range (\<lambda>x. f\<cdot>x))"
begin

lemma iterate_below: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
by (induct i, simp_all add: below_trans [OF below])

lemma iterate_fixed: "f\<cdot>x = x \<Longrightarrow> iterate i\<cdot>f\<cdot>x = x"
by (induct i, simp_all)

lemma antichain_iterate_app: "i \<le> j \<Longrightarrow> iterate j\<cdot>f\<cdot>x \<sqsubseteq> iterate i\<cdot>f\<cdot>x"
apply (erule le_Suc_induct)
apply (simp add: below)
apply (rule below_refl)
apply (erule (1) below_trans)
done

lemma finite_range_iterate_app: "finite (range (\<lambda>i. iterate i\<cdot>f\<cdot>x))"
proof (rule finite_subset)
  show "range (\<lambda>i. iterate i\<cdot>f\<cdot>x) \<subseteq> insert x (range (\<lambda>x. f\<cdot>x))"
    by (clarify, case_tac i, simp_all)
  show "finite (insert x (range (\<lambda>x. f\<cdot>x)))"
    by (simp add: finite_range)
qed

lemma eventually_constant_iterate_app:
  "eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>x)"
unfolding eventually_constant_def MOST_nat_le
proof -
  let ?Y = "\<lambda>i. iterate i\<cdot>f\<cdot>x"
  have "\<exists>j. \<forall>k. ?Y j \<sqsubseteq> ?Y k"
    apply (rule finite_range_has_max)
    apply (erule antichain_iterate_app)
    apply (rule finite_range_iterate_app)
    done
  then obtain j where j: "\<And>k. ?Y j \<sqsubseteq> ?Y k" by fast
  show "\<exists>z m. \<forall>n\<ge>m. ?Y n = z"
  proof (intro exI allI impI)
    fix k
    assume "j \<le> k"
    hence "?Y k \<sqsubseteq> ?Y j" by (rule antichain_iterate_app)
    also have "?Y j \<sqsubseteq> ?Y k" by (rule j)
    finally show "?Y k = ?Y j" .
  qed
qed

lemma eventually_constant_iterate:
  "eventually_constant (\<lambda>n. iterate n\<cdot>f)"
proof -
  have "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>y)"
    by (simp add: eventually_constant_iterate_app)
  hence "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). MOST i. MOST j. iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
    unfolding eventually_constant_MOST_MOST .
  hence "MOST i. MOST j. \<forall>y\<in>range (\<lambda>x. f\<cdot>x). iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
    by (simp only: MOST_finite_Ball_distrib [OF finite_range])
  hence "MOST i. MOST j. \<forall>x. iterate j\<cdot>f\<cdot>(f\<cdot>x) = iterate i\<cdot>f\<cdot>(f\<cdot>x)"
    by simp
  hence "MOST i. MOST j. \<forall>x. iterate (Suc j)\<cdot>f\<cdot>x = iterate (Suc i)\<cdot>f\<cdot>x"
    by (simp only: iterate_Suc2)
  hence "MOST i. MOST j. iterate (Suc j)\<cdot>f = iterate (Suc i)\<cdot>f"
    by (simp only: cfun_eq_iff)
  hence "eventually_constant (\<lambda>i. iterate (Suc i)\<cdot>f)"
    unfolding eventually_constant_MOST_MOST .
  thus "eventually_constant (\<lambda>i. iterate i\<cdot>f)"
    by (rule eventually_constant_SucD)
qed

abbreviation
  d :: "'a \<rightarrow> 'a"
where
  "d \<equiv> eventual_iterate f"

lemma MOST_d: "MOST n. P (iterate n\<cdot>f) \<Longrightarrow> P d"
unfolding eventual_iterate_def
using eventually_constant_iterate by (rule MOST_eventual)

lemma f_d: "f\<cdot>(d\<cdot>x) = d\<cdot>x"
apply (rule MOST_d)
apply (subst iterate_Suc [symmetric])
apply (rule eventually_constant_MOST_Suc_eq)
apply (rule eventually_constant_iterate_app)
done

lemma d_fixed_iff: "d\<cdot>x = x \<longleftrightarrow> f\<cdot>x = x"
proof
  assume "d\<cdot>x = x"
  with f_d [where x=x]
  show "f\<cdot>x = x" by simp
next
  assume f: "f\<cdot>x = x"
  have "\<forall>n. iterate n\<cdot>f\<cdot>x = x"
    by (rule allI, rule nat.induct, simp, simp add: f)
  hence "MOST n. iterate n\<cdot>f\<cdot>x = x"
    by (rule ALL_MOST)
  thus "d\<cdot>x = x"
    by (rule MOST_d)
qed

lemma finite_deflation_d: "finite_deflation d"
proof
  fix x :: 'a
  have "d \<in> range (\<lambda>n. iterate n\<cdot>f)"
    unfolding eventual_iterate_def
    using eventually_constant_iterate
    by (rule eventual_mem_range)
  then obtain n where n: "d = iterate n\<cdot>f" ..
  have "iterate n\<cdot>f\<cdot>(d\<cdot>x) = d\<cdot>x"
    using f_d by (rule iterate_fixed)
  thus "d\<cdot>(d\<cdot>x) = d\<cdot>x"
    by (simp add: n)
next
  fix x :: 'a
  show "d\<cdot>x \<sqsubseteq> x"
    by (rule MOST_d, simp add: iterate_below)
next
  from finite_range
  have "finite {x. f\<cdot>x = x}"
    by (rule finite_range_imp_finite_fixes)
  thus "finite {x. d\<cdot>x = x}"
    by (simp add: d_fixed_iff)
qed

lemma deflation_d: "deflation d"
using finite_deflation_d
by (rule finite_deflation_imp_deflation)

end

lemma finite_deflation_eventual_iterate:
  "pre_deflation d \<Longrightarrow> finite_deflation (eventual_iterate d)"
by (rule pre_deflation.finite_deflation_d)

lemma pre_deflation_oo:
  assumes "finite_deflation d"
  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
  shows "pre_deflation (d oo f)"
proof
  interpret d: finite_deflation d by fact
  fix x
  show "\<And>x. (d oo f)\<cdot>x \<sqsubseteq> x"
    by (simp, rule below_trans [OF d.below f])
  show "finite (range (\<lambda>x. (d oo f)\<cdot>x))"
    by (rule finite_subset [OF _ d.finite_range], auto)
qed

lemma eventual_iterate_oo_fixed_iff:
  assumes "finite_deflation d"
  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
  shows "eventual_iterate (d oo f)\<cdot>x = x \<longleftrightarrow> d\<cdot>x = x \<and> f\<cdot>x = x"
proof -
  interpret d: finite_deflation d by fact
  let ?e = "d oo f"
  interpret e: pre_deflation "d oo f"
    using \<open>finite_deflation d\<close> f
    by (rule pre_deflation_oo)
  let ?g = "eventual (\<lambda>n. iterate n\<cdot>?e)"
  show ?thesis
    apply (subst e.d_fixed_iff)
    apply simp
    apply safe
    apply (erule subst)
    apply (rule d.idem)
    apply (rule below_antisym)
    apply (rule f)
    apply (erule subst, rule d.below)
    apply simp
    done
qed

lemma eventual_mono:
  assumes A: "eventually_constant A"
  assumes B: "eventually_constant B"
  assumes below: "\<And>n. A n \<sqsubseteq> B n"
  shows "eventual A \<sqsubseteq> eventual B"
proof -
  from A have "MOST n. A n = eventual A"
    by (rule MOST_eq_eventual)
  then have "MOST n. eventual A \<sqsubseteq> B n"
    by (rule MOST_mono) (erule subst, rule below)
  with B show "eventual A \<sqsubseteq> eventual B"
    by (rule MOST_eventual)
qed

lemma eventual_iterate_mono:
  assumes f: "pre_deflation f" and g: "pre_deflation g" and "f \<sqsubseteq> g"
  shows "eventual_iterate f \<sqsubseteq> eventual_iterate g"
unfolding eventual_iterate_def
apply (rule eventual_mono)
apply (rule pre_deflation.eventually_constant_iterate [OF f])
apply (rule pre_deflation.eventually_constant_iterate [OF g])
apply (rule monofun_cfun_arg [OF \<open>f \<sqsubseteq> g\<close>])
done

lemma cont2cont_eventual_iterate_oo:
  assumes d: "finite_deflation d"
  assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
  shows "cont (\<lambda>x. eventual_iterate (d oo f x))"
    (is "cont ?e")
proof (rule contI2)
  show "monofun ?e"
    apply (rule monofunI)
    apply (rule eventual_iterate_mono)
    apply (rule pre_deflation_oo [OF d below])
    apply (rule pre_deflation_oo [OF d below])
    apply (rule monofun_cfun_arg)
    apply (erule cont2monofunE [OF cont])
    done
next
  fix Y :: "nat \<Rightarrow> 'b"
  assume Y: "chain Y"
  with cont have fY: "chain (\<lambda>i. f (Y i))"
    by (rule ch2ch_cont)
  assume eY: "chain (\<lambda>i. ?e (Y i))"
  have lub_below: "\<And>x. f (\<Squnion>i. Y i)\<cdot>x \<sqsubseteq> x"
    by (rule admD [OF _ Y], simp add: cont, rule below)
  have "deflation (?e (\<Squnion>i. Y i))"
    apply (rule pre_deflation.deflation_d)
    apply (rule pre_deflation_oo [OF d lub_below])
    done
  then show "?e (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. ?e (Y i))"
  proof (rule deflation.belowI)
    fix x :: 'a
    assume "?e (\<Squnion>i. Y i)\<cdot>x = x"
    hence "d\<cdot>x = x" and "f (\<Squnion>i. Y i)\<cdot>x = x"
      by (simp_all add: eventual_iterate_oo_fixed_iff [OF d lub_below])
    hence "(\<Squnion>i. f (Y i)\<cdot>x) = x"
      apply (simp only: cont2contlubE [OF cont Y])
      apply (simp only: contlub_cfun_fun [OF fY])
      done
    have "compact (d\<cdot>x)"
      using d by (rule finite_deflation.compact)
    then have "compact x"
      using \<open>d\<cdot>x = x\<close> by simp
    then have "compact (\<Squnion>i. f (Y i)\<cdot>x)"
      using \<open>(\<Squnion>i. f (Y i)\<cdot>x) = x\<close> by simp
    then have "\<exists>n. max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)"
      by - (rule compact_imp_max_in_chain, simp add: fY, assumption)
    then obtain n where n: "max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)" ..
    then have "f (Y n)\<cdot>x = x"
      using \<open>(\<Squnion>i. f (Y i)\<cdot>x) = x\<close> fY by (simp add: maxinch_is_thelub)
    with \<open>d\<cdot>x = x\<close> have "?e (Y n)\<cdot>x = x"
      by (simp add: eventual_iterate_oo_fixed_iff [OF d below])
    moreover have "?e (Y n)\<cdot>x \<sqsubseteq> (\<Squnion>i. ?e (Y i)\<cdot>x)"
      by (rule is_ub_thelub, simp add: eY)
    ultimately have "x \<sqsubseteq> (\<Squnion>i. ?e (Y i))\<cdot>x"
      by (simp add: contlub_cfun_fun eY)
    also have "(\<Squnion>i. ?e (Y i))\<cdot>x \<sqsubseteq> x"
      apply (rule deflation.below)
      apply (rule admD [OF adm_deflation eY])
      apply (rule pre_deflation.deflation_d)
      apply (rule pre_deflation_oo [OF d below])
      done
    finally show "(\<Squnion>i. ?e (Y i))\<cdot>x = x" ..
  qed
qed

subsection \<open>Intersection of algebraic deflations\<close>

default_sort bifinite

definition meet_fin_defl :: "'a fin_defl \<Rightarrow> 'a fin_defl \<Rightarrow> 'a fin_defl"
  where "meet_fin_defl a b =
    Abs_fin_defl (eventual_iterate (Rep_fin_defl a oo Rep_fin_defl b))"

lemma Rep_meet_fin_defl:
  "Rep_fin_defl (meet_fin_defl a b) =
    eventual_iterate (Rep_fin_defl a oo Rep_fin_defl b)"
unfolding meet_fin_defl_def
apply (rule Abs_fin_defl_inverse [simplified])
apply (rule finite_deflation_eventual_iterate)
apply (rule pre_deflation_oo)
apply (rule finite_deflation_Rep_fin_defl)
apply (rule Rep_fin_defl.below)
done

lemma Rep_meet_fin_defl_fixed_iff:
  "Rep_fin_defl (meet_fin_defl a b)\<cdot>x = x \<longleftrightarrow>
    Rep_fin_defl a\<cdot>x = x \<and> Rep_fin_defl b\<cdot>x = x"
unfolding Rep_meet_fin_defl
apply (rule eventual_iterate_oo_fixed_iff)
apply (rule finite_deflation_Rep_fin_defl)
apply (rule Rep_fin_defl.below)
done

lemma meet_fin_defl_mono:
  "\<lbrakk>a \<sqsubseteq> b; c \<sqsubseteq> d\<rbrakk> \<Longrightarrow> meet_fin_defl a c \<sqsubseteq> meet_fin_defl b d"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

lemma meet_fin_defl_below1: "meet_fin_defl a b \<sqsubseteq> a"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

lemma meet_fin_defl_below2: "meet_fin_defl a b \<sqsubseteq> b"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

lemma meet_fin_defl_greatest: "\<lbrakk>a \<sqsubseteq> b; a \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> meet_fin_defl b c"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

definition meet_defl :: "'a defl \<rightarrow> 'a defl \<rightarrow> 'a defl"
  where "meet_defl = defl.extension (\<lambda>a. defl.extension (\<lambda>b.
    defl_principal (meet_fin_defl a b)))"

lemma meet_defl_principal:
  "meet_defl\<cdot>(defl_principal a)\<cdot>(defl_principal b) =
    defl_principal (meet_fin_defl a b)"
unfolding meet_defl_def
by (simp add: defl.extension_principal defl.extension_mono meet_fin_defl_mono)

lemma meet_defl_below1: "meet_defl\<cdot>a\<cdot>b \<sqsubseteq> a"
apply (induct a rule: defl.principal_induct, simp)
apply (induct b rule: defl.principal_induct, simp)
apply (simp add: meet_defl_principal meet_fin_defl_below1)
done

lemma meet_defl_below2: "meet_defl\<cdot>a\<cdot>b \<sqsubseteq> b"
apply (induct a rule: defl.principal_induct, simp)
apply (induct b rule: defl.principal_induct, simp)
apply (simp add: meet_defl_principal meet_fin_defl_below2)
done

lemma meet_defl_greatest: "\<lbrakk>a \<sqsubseteq> b; a \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> meet_defl\<cdot>b\<cdot>c"
apply (induct a rule: defl.principal_induct, simp)
apply (induct b rule: defl.principal_induct, simp)
apply (induct c rule: defl.principal_induct, simp)
apply (simp add: meet_defl_principal meet_fin_defl_greatest)
done

lemma meet_defl_eq2: "b \<sqsubseteq> a \<Longrightarrow> meet_defl\<cdot>a\<cdot>b = b"
by (fast intro: below_antisym meet_defl_below2 meet_defl_greatest)

interpretation meet_defl: semilattice "\<lambda>a b. meet_defl\<cdot>a\<cdot>b"
by standard
  (fast intro: below_antisym meet_defl_greatest
   meet_defl_below1 [THEN below_trans] meet_defl_below2 [THEN below_trans])+

lemma deflation_meet_defl: "deflation (meet_defl\<cdot>a)"
apply (rule deflation.intro)
apply (rule meet_defl.left_idem)
apply (rule meet_defl_below2)
done

lemma finite_deflation_meet_defl:
  assumes "compact a"
  shows "finite_deflation (meet_defl\<cdot>a)"
proof (rule finite_deflation_intro)
  obtain d where a: "a = defl_principal d"
    using defl.compact_imp_principal [OF assms] ..
  have "finite (defl_set -` Pow (defl_set a))"
    apply (rule finite_vimageI)
    apply (rule finite_Pow_iff [THEN iffD2])
    apply (simp add: defl_set_def a cast_defl_principal Abs_fin_defl_inverse)
    apply (rule Rep_fin_defl.finite_fixes)
    apply (rule injI)
    apply (simp add: po_eq_conv defl_set_subset_iff [symmetric])
    done
  hence "finite (range (\<lambda>b. meet_defl\<cdot>a\<cdot>b))"
    apply (rule rev_finite_subset)
    apply (clarsimp, erule rev_subsetD)
    apply (simp add: defl_set_subset_iff meet_defl_below1)
    done
  thus "finite {b. meet_defl\<cdot>a\<cdot>b = b}"
    by (rule finite_range_imp_finite_fixes)
qed (rule deflation_meet_defl)

lemma compact_iff_finite_deflation_cast:
  "compact d \<longleftrightarrow> finite_deflation (cast\<cdot>d)"
apply (safe dest!: defl.compact_imp_principal)
apply (simp add: cast_defl_principal finite_deflation_Rep_fin_defl)
apply (rule compact_cast_iff [THEN iffD1])
apply (erule finite_deflation_imp_compact)
done

lemma compact_iff_finite_defl_set:
  "compact d \<longleftrightarrow> finite (defl_set d)"
by (simp add: compact_iff_finite_deflation_cast defl_set_def
  finite_deflation_def deflation_cast finite_deflation_axioms_def)

lemma compact_meet_defl1: "compact a \<Longrightarrow> compact (meet_defl\<cdot>a\<cdot>b)"
apply (simp add: compact_iff_finite_defl_set)
apply (erule rev_finite_subset)
apply (simp add: defl_set_subset_iff meet_defl_below1)
done

lemma compact_meet_defl2: "compact b \<Longrightarrow> compact (meet_defl\<cdot>a\<cdot>b)"
by (subst meet_defl.commute, rule compact_meet_defl1)

subsection \<open>Chain of approx functions on algebraic deflations\<close>

context bifinite_approx_chain
begin

definition defl_approx :: "nat \<Rightarrow> 'a defl \<rightarrow> 'a defl"
  where "defl_approx i = meet_defl\<cdot>(defl_principal (Abs_fin_defl (approx i)))"

lemma defl_approx: "approx_chain defl_approx"
proof (rule approx_chain.intro)
  have chain1: "chain (\<lambda>i. defl_principal (Abs_fin_defl (approx i)))"
    apply (rule chainI)
    apply (rule defl.principal_mono)
    apply (simp add: below_fin_defl_def Abs_fin_defl_inverse)
    apply (rule chainE [OF chain_approx])
    done
  show chain: "chain (\<lambda>i. defl_approx i)"
    unfolding defl_approx_def by (simp add: chain1)
  have below: "\<And>i d. defl_approx i\<cdot>d \<sqsubseteq> d"
    unfolding defl_approx_def by (rule meet_defl_below2)
  show "(\<Squnion>i. defl_approx i) = ID"
    apply (rule cfun_eqI, rename_tac d, simp)
    apply (rule below_antisym)
    apply (simp add: contlub_cfun_fun chain)
    apply (simp add: lub_below chain below)
    apply (simp add: defl_approx_def)
    apply (simp add: lub_distribs chain1)
    apply (rule meet_defl_greatest [OF _ below_refl])
    apply (rule cast_below_imp_below)
    apply (simp add: contlub_cfun_arg chain1)
    apply (simp add: cast_defl_principal Abs_fin_defl_inverse)
    apply (rule cast.below_ID)
    done
  show "\<And>i. finite_deflation (defl_approx i)"
    unfolding defl_approx_def
    apply (rule finite_deflation_meet_defl)
    apply (rule defl.compact_principal)
    done
qed

end

subsection \<open>Algebraic deflations are a bifinite domain\<close>

instance defl :: (bifinite) bifinite
proof
  obtain a :: "nat \<Rightarrow> 'a \<rightarrow> 'a" where "approx_chain a"
    using bifinite ..
  hence "bifinite_approx_chain a"
    unfolding bifinite_approx_chain_def .
  thus "\<exists>(a::nat \<Rightarrow> 'a defl \<rightarrow> 'a defl). approx_chain a"
    by (fast intro: bifinite_approx_chain.defl_approx)
qed

subsection \<open>Algebraic deflations are representable\<close>

default_sort "domain"

definition defl_emb :: "udom defl \<rightarrow> udom"
  where "defl_emb = udom_emb (bifinite_approx_chain.defl_approx udom_approx)"

definition defl_prj :: "udom \<rightarrow> udom defl"
  where "defl_prj = udom_prj (bifinite_approx_chain.defl_approx udom_approx)"

lemma ep_pair_defl: "ep_pair defl_emb defl_prj"
unfolding defl_emb_def defl_prj_def
apply (rule ep_pair_udom)
apply (rule bifinite_approx_chain.defl_approx)
apply (simp add: bifinite_approx_chain_def)
done

text "Deflation combinator for deflation type constructor"

definition defl_defl :: "udom defl \<rightarrow> udom defl"
  where defl_deflation_def:
  "defl_defl = defl.extension (\<lambda>a. defl_principal
    (Abs_fin_defl (defl_emb oo meet_defl\<cdot>(defl_principal a) oo defl_prj)))"

lemma cast_defl_defl:
  "cast\<cdot>(defl_defl\<cdot>a) = defl_emb oo meet_defl\<cdot>a oo defl_prj"
apply (induct a rule: defl.principal_induct, simp)
apply (subst defl_deflation_def)
apply (subst defl.extension_principal)
apply (simp add: below_fin_defl_def Abs_fin_defl_inverse
  ep_pair.finite_deflation_e_d_p ep_pair_defl
  finite_deflation_meet_defl monofun_cfun)
apply (simp add: cast_defl_principal
  below_fin_defl_def Abs_fin_defl_inverse
  ep_pair.finite_deflation_e_d_p ep_pair_defl
  finite_deflation_meet_defl monofun_cfun)
done

definition defl_map_emb :: "'a::domain defl \<rightarrow> udom defl"
  where "defl_map_emb = defl_fun1 emb prj ID"

definition defl_map_prj :: "udom defl \<rightarrow> 'a::domain defl"
  where "defl_map_prj = defl.extension (\<lambda>a. defl_principal (Abs_fin_defl (prj oo cast\<cdot>(meet_defl\<cdot>DEFL('a)\<cdot>(defl_principal a)) oo emb)))"

lemma defl_map_emb_principal:
  "defl_map_emb\<cdot>(defl_principal a) =
    defl_principal (Abs_fin_defl (emb oo Rep_fin_defl a oo prj))"
unfolding defl_map_emb_def defl_fun1_def
apply (subst defl.extension_principal)
apply (rule defl.principal_mono)
apply (simp add: below_fin_defl_def Abs_fin_defl_inverse monofun_cfun
       domain.finite_deflation_e_d_p finite_deflation_Rep_fin_defl)
apply simp
done

lemma defl_map_prj_principal:
  "(defl_map_prj\<cdot>(defl_principal a) :: 'a::domain defl) =
  defl_principal (Abs_fin_defl (prj oo cast\<cdot>(meet_defl\<cdot>DEFL('a)\<cdot>(defl_principal a)) oo emb))"
unfolding defl_map_prj_def
apply (rule defl.extension_principal)
apply (rule defl.principal_mono)
apply (simp add: below_fin_defl_def)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (simp add: monofun_cfun below_fin_defl_def)
done

lemma defl_map_prj_defl_map_emb: "defl_map_prj\<cdot>(defl_map_emb\<cdot>d) = d"
apply (rule cast_eq_imp_eq)
apply (induct_tac d rule: defl.principal_induct, simp)
apply (subst defl_map_emb_principal)
apply (subst defl_map_prj_principal)
apply (simp add: cast_defl_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (subst meet_defl_eq2)
apply (rule cast_below_imp_below)
apply (simp add: cast_DEFL)
apply (simp add: cast_defl_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_e_d_p)
apply (rule finite_deflation_Rep_fin_defl)
apply (rule cfun_belowI, simp)
apply (rule Rep_fin_defl.below)
apply (simp add: cast_defl_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_e_d_p)
apply (rule finite_deflation_Rep_fin_defl)
apply (simp add: cfun_eqI)
done

lemma defl_map_emb_defl_map_prj:
  "defl_map_emb\<cdot>(defl_map_prj\<cdot>d :: 'a defl) = meet_defl\<cdot>DEFL('a)\<cdot>d"
apply (induct_tac d rule: defl.principal_induct, simp)
apply (subst defl_map_prj_principal)
apply (subst defl_map_emb_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (rule cast_eq_imp_eq)
apply (subst cast_defl_principal)
apply (simp add: cfcomp1 emb_prj)
apply (subst deflation_below_comp2 [OF deflation_cast deflation_cast])
apply (rule monofun_cfun_arg, rule meet_defl_below1)
apply (subst deflation_below_comp1 [OF deflation_cast deflation_cast])
apply (rule monofun_cfun_arg, rule meet_defl_below1)
apply (simp add: eta_cfun)
apply (rule Abs_fin_defl_inverse, simp)
apply (rule finite_deflation_cast)
apply (rule compact_meet_defl2, simp)
done

lemma ep_pair_defl_map_emb_defl_map_prj:
  "ep_pair defl_map_emb defl_map_prj"
apply (rule ep_pair.intro)
apply (rule defl_map_prj_defl_map_emb)
apply (simp add: defl_map_emb_defl_map_prj)
apply (rule meet_defl_below2)
done

instantiation defl :: ("domain") "domain"
begin

definition
  "emb = defl_emb oo defl_map_emb"

definition
  "prj = defl_map_prj oo defl_prj"

definition
  "defl (t::'a defl itself) = defl_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a defl u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a defl u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a defl itself) = liftdefl_of\<cdot>DEFL('a defl)"

instance proof
  show ep: "ep_pair emb (prj :: udom \<rightarrow> 'a defl)"
    unfolding emb_defl_def prj_defl_def
    apply (rule ep_pair_comp [OF _ ep_pair_defl])
    apply (rule ep_pair_defl_map_emb_defl_map_prj)
    done
  show "cast\<cdot>DEFL('a defl) = emb oo (prj :: udom \<rightarrow> 'a defl)"
    unfolding defl_defl_def emb_defl_def prj_defl_def
    by (simp add: cast_defl_defl cfcomp1 defl_map_emb_defl_map_prj)
qed (fact liftemb_defl_def liftprj_defl_def liftdefl_defl_def)+

end

lemma DEFL_defl [domain_defl_simps]: "DEFL('a defl) = defl_defl\<cdot>DEFL('a)"
by (rule defl_defl_def)

end


theory Digraph_Isomorphism imports
  Arc_Walk
  Digraph
  Digraph_Component
begin

section \<open>Isomorphisms of Digraphs\<close>

record ('a,'b,'aa,'bb) digraph_isomorphism =
  iso_verts :: "'a \<Rightarrow> 'aa"
  iso_arcs :: "'b \<Rightarrow> 'bb"
  iso_head :: "'bb \<Rightarrow> 'aa"
  iso_tail :: "'bb \<Rightarrow> 'aa"

definition (in pre_digraph) digraph_isomorphism :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> bool" where
  "digraph_isomorphism hom \<equiv>
    wf_digraph G \<and>
    inj_on (iso_verts hom) (verts G) \<and>
    inj_on (iso_arcs hom) (arcs G) \<and>
    (\<forall>a \<in> arcs G.
    iso_verts hom (tail G a) = iso_tail hom (iso_arcs hom a) \<and>
    iso_verts hom (head G a) = iso_head hom (iso_arcs hom a))"

definition (in pre_digraph) inv_iso :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> ('aa,'bb,'a,'b) digraph_isomorphism" where
  "inv_iso hom \<equiv> \<lparr>
    iso_verts = the_inv_into (verts G) (iso_verts hom),
    iso_arcs = the_inv_into (arcs G) (iso_arcs hom),
    iso_head = head G,
    iso_tail = tail G
    \<rparr>"

definition app_iso
    :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> ('aa,'bb) pre_digraph" where
  "app_iso hom G \<equiv> \<lparr> verts = iso_verts hom ` verts G, arcs = iso_arcs hom ` arcs G,
    tail = iso_tail hom, head = iso_head hom \<rparr>"

definition digraph_iso :: "('a,'b) pre_digraph \<Rightarrow> ('c,'d) pre_digraph \<Rightarrow> bool"  where
  "digraph_iso G H \<equiv> \<exists>f. pre_digraph.digraph_isomorphism G f \<and> H = app_iso f G"

lemma verts_app_iso: "verts (app_iso hom G) = iso_verts hom ` verts G"
  and arcs_app_iso: "arcs (app_iso hom G) = iso_arcs hom `arcs G"
  and tail_app_iso: "tail (app_iso hom G) = iso_tail hom"
  and head_app_iso: "head (app_iso hom G) = iso_head hom"
  by (auto simp: app_iso_def)

lemmas app_iso_simps[simp] = verts_app_iso arcs_app_iso tail_app_iso head_app_iso

context pre_digraph begin

lemma
  assumes "digraph_isomorphism hom"
  shows iso_verts_inv_iso: "\<And>u. u \<in> verts G \<Longrightarrow> iso_verts (inv_iso hom) (iso_verts hom u) = u"
    and iso_arcs_inv_iso: "\<And>a. a \<in> arcs G \<Longrightarrow> iso_arcs (inv_iso hom) (iso_arcs hom a) = a"
    and iso_verts_iso_inv: "\<And>u. u \<in> verts (app_iso hom G) \<Longrightarrow> iso_verts hom (iso_verts (inv_iso hom) u) = u"
    and iso_arcs_iso_inv: "\<And>a. a \<in> arcs (app_iso hom G) \<Longrightarrow> iso_arcs hom (iso_arcs (inv_iso hom) a) = a"
    and iso_tail_inv_iso: "iso_tail (inv_iso hom) = tail G"
    and iso_head_inv_iso: "iso_head (inv_iso hom) = head G"
    and verts_app_inv_iso:"iso_verts (inv_iso hom) ` iso_verts hom ` verts G = verts G"
    and arcs_app_inv_iso:"iso_arcs (inv_iso hom) ` iso_arcs hom ` arcs G = arcs G"
  using assms by (auto simp: inv_iso_def digraph_isomorphism_def the_inv_into_f_f)

lemmas iso_inv_simps[simp] =
   iso_verts_inv_iso iso_verts_iso_inv
   iso_arcs_inv_iso iso_arcs_iso_inv
   verts_app_inv_iso arcs_app_inv_iso
   iso_tail_inv_iso iso_head_inv_iso

lemma app_iso_inv[simp]:
  assumes "digraph_isomorphism hom"
  shows "app_iso (inv_iso hom) (app_iso hom G) = G"
  using assms by (intro pre_digraph.equality) (auto intro: rev_image_eqI)

lemma iso_verts_eq_iff[simp]:
  assumes "digraph_isomorphism hom" "u \<in> verts G" "v \<in> verts G"
  shows "iso_verts hom u = iso_verts hom v \<longleftrightarrow> u = v"
  using assms by (auto simp: digraph_isomorphism_def dest: inj_onD)

lemma iso_arcs_eq_iff[simp]:
  assumes "digraph_isomorphism hom" "e1 \<in> arcs G" "e2 \<in> arcs G"
  shows "iso_arcs hom e1 = iso_arcs hom e2 \<longleftrightarrow> e1 = e2"
  using assms by (auto simp: digraph_isomorphism_def dest: inj_onD)

lemma
  assumes "digraph_isomorphism hom" "e \<in> arcs G"
  shows iso_verts_tail: "iso_tail hom (iso_arcs hom e) = iso_verts hom (tail G e)"
    and iso_verts_head: "iso_head hom (iso_arcs hom e) = iso_verts hom (head G e)"
  using assms unfolding digraph_isomorphism_def by auto

lemma digraph_isomorphism_inj_on_arcs:
  "digraph_isomorphism hom \<Longrightarrow> inj_on (iso_arcs hom) (arcs G)"
  by (auto simp: digraph_isomorphism_def)

lemma digraph_isomorphism_inj_on_verts:
  "digraph_isomorphism hom \<Longrightarrow> inj_on (iso_verts hom) (verts G)"
  by (auto simp: digraph_isomorphism_def)

end

lemma (in wf_digraph) wf_digraphI_app_iso[intro?]:
  assumes "digraph_isomorphism hom"
  shows "wf_digraph (app_iso hom G)"
proof unfold_locales
  fix e assume "e \<in> arcs (app_iso hom G)"
  then obtain e' where e': "e' \<in> arcs G" "iso_arcs hom e' = e"
    by auto
  then have "iso_verts hom (head G e') \<in> verts (app_iso hom G)"
      "iso_verts hom (tail G e') \<in> verts (app_iso hom G)"
    by auto
  then show "tail (app_iso hom G) e \<in> verts (app_iso hom G)"
      "head (app_iso hom G) e \<in> verts (app_iso hom G)"
    using e' assms by (auto simp: iso_verts_tail iso_verts_head)
qed

lemma (in fin_digraph) fin_digraphI_app_iso[intro?]:
  assumes "digraph_isomorphism hom"
  shows "fin_digraph (app_iso hom G)"
proof -
  interpret H: wf_digraph "app_iso hom G" using assms ..
  show ?thesis by unfold_locales auto
qed

context wf_digraph begin

lemma digraph_isomorphism_invI:
  assumes "digraph_isomorphism hom" shows "pre_digraph.digraph_isomorphism (app_iso hom G) (inv_iso hom)"
proof (unfold pre_digraph.digraph_isomorphism_def, safe)
  show "inj_on (iso_verts (inv_iso hom)) (verts (app_iso hom G))"
      "inj_on (iso_arcs (inv_iso hom)) (arcs (app_iso hom G))"
    using assms unfolding pre_digraph.digraph_isomorphism_def inv_iso_def
    by (auto intro: inj_on_the_inv_into)
next
  show "wf_digraph (app_iso hom G)" using assms ..
next
  fix a assume "a \<in> arcs (app_iso hom G)"
  then obtain b where B: "a = iso_arcs hom b" "b \<in> arcs G"
    by auto

  with assms have [simp]:
      "iso_tail hom (iso_arcs hom b) = iso_verts hom (tail G b)"
      "iso_head hom (iso_arcs hom b) = iso_verts hom (head G b)"
      "inj_on (iso_arcs hom) (arcs G)"
      "inj_on (iso_verts hom) (verts G)"
    by (auto simp: digraph_isomorphism_def)

  from B show "iso_verts (inv_iso hom) (tail (app_iso hom G) a)
      = iso_tail (inv_iso hom) (iso_arcs (inv_iso hom) a)"
    by (auto simp: inv_iso_def the_inv_into_f_f)
  from B show "iso_verts (inv_iso hom) (head (app_iso hom G) a)
      = iso_head (inv_iso hom) (iso_arcs (inv_iso hom) a)"
    by (auto simp: inv_iso_def the_inv_into_f_f)
qed

lemma awalk_app_isoI:
  assumes "awalk u p v" and hom: "digraph_isomorphism hom"
  shows "pre_digraph.awalk (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from assms show ?thesis
    by (induct p arbitrary: u)
       (auto simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)
qed

lemma awalk_app_isoD:
  assumes w: "pre_digraph.awalk (app_iso hom G) u p v" and hom: "digraph_isomorphism hom"
  shows "awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from assms show ?thesis
    by (induct p arbitrary: u)
       (force simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)+
qed

lemma awalk_verts_app_iso_eq:
  assumes "digraph_isomorphism hom" and "awalk u p v"
  shows "pre_digraph.awalk_verts (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p)
    = map (iso_verts hom) (awalk_verts u p)"
  using assms
  by (induct p arbitrary: u)
     (auto simp: pre_digraph.awalk_verts.simps iso_verts_head iso_verts_tail awalk_Cons_iff)

(*
lemma awalk_verts_app_iso_eq':
  assumes hom: "digraph_isomorphism hom" and w: "pre_digraph.awalk (app_iso hom G) u p v"
  shows "pre_digraph.awalk_verts (app_iso hom G) u p
    = map (iso_verts hom) (awalk_verts (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p))"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  have w': "awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
    using w hom by (rule awalk_app_isoD)
  have "pre_digraph.awalk_verts (app_iso hom G) u p =
      pre_digraph.awalk_verts (app_iso hom G) (iso_verts hom (iso_verts (inv_iso hom) u)) (map (iso_arcs hom) (map (iso_arcs (inv_iso hom)) p))"
    using hom w by (auto simp add: o_def subsetD cong: map_cong)
  also have "\<dots> = map (iso_verts hom) (awalk_verts (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p))"
    using hom w' by (rule awalk_verts_app_iso_eq)
  finally show ?thesis .
qed
*)

lemma in_arcs_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "in_arcs (app_iso hom G) (iso_verts hom u) = iso_arcs hom ` in_arcs G u"
  using assms unfolding in_arcs_def by (auto simp: iso_verts_head)

lemma out_arcs_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "out_arcs (app_iso hom G) (iso_verts hom u) = iso_arcs hom ` out_arcs G u"
  using assms unfolding out_arcs_def by (auto simp: iso_verts_tail)

lemma in_degree_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "in_degree (app_iso hom G) (iso_verts hom u) = in_degree G u"
  unfolding in_degree_def in_arcs_app_iso_eq[OF assms]
proof (rule card_image)
  from assms show "inj_on (iso_arcs hom) (in_arcs G u)"
    unfolding digraph_isomorphism_def by - (rule subset_inj_on, auto)
qed

lemma out_degree_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "out_degree (app_iso hom G) (iso_verts hom u) = out_degree G u"
  unfolding out_degree_def out_arcs_app_iso_eq[OF assms]
proof (rule card_image)
  from assms show "inj_on (iso_arcs hom) (out_arcs G u)"
    unfolding digraph_isomorphism_def by - (rule subset_inj_on, auto)
qed

lemma in_arcs_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "in_arcs (app_iso hom G) u = iso_arcs hom ` in_arcs G (iso_verts (inv_iso hom) u)"
  using assms in_arcs_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemma out_arcs_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "out_arcs (app_iso hom G) u = iso_arcs hom ` out_arcs G (iso_verts (inv_iso hom) u)"
  using assms out_arcs_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemma in_degree_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "in_degree (app_iso hom G) u = in_degree G (iso_verts (inv_iso hom) u)"
  using assms in_degree_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemma out_degree_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "out_degree (app_iso hom G) u = out_degree G (iso_verts (inv_iso hom) u)"
  using assms out_degree_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemmas app_iso_eq =
  awalk_verts_app_iso_eq
  arcs_ends_app_iso_eq
  in_arcs_app_iso_eq'
  out_arcs_app_iso_eq'
  in_degree_app_iso_eq'
  out_degree_app_iso_eq'

lemma reachableI_app_iso:
  assumes r: "u \<rightarrow>\<^sup>* v" and hom: "digraph_isomorphism hom"
  shows "(iso_verts hom u) \<rightarrow>\<^sup>*\<^bsub>app_iso hom G\<^esub> (iso_verts hom v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from r obtain p where "awalk u p v" by (auto simp: reachable_awalk)
  then have "H.awalk (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
    using hom by (rule awalk_app_isoI)
  then show ?thesis by (auto simp: H.reachable_awalk)
qed

lemma awalk_app_iso_eq:
  assumes hom: "digraph_isomorphism hom"
  assumes "u \<in> iso_verts hom ` verts G" "v \<in> iso_verts hom ` verts G" "set p \<subseteq> iso_arcs hom ` arcs G"
  shows "pre_digraph.awalk (app_iso hom G) u p v
    \<longleftrightarrow> awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from assms show ?thesis
    by (induct p arbitrary: u)
       (auto simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)
qed

lemma reachable_app_iso_eq:
  assumes hom: "digraph_isomorphism hom"
  assumes "u \<in> iso_verts hom ` verts G" "v \<in> iso_verts hom ` verts G"
  shows "u \<rightarrow>\<^sup>*\<^bsub>app_iso hom G\<^esub> v \<longleftrightarrow> iso_verts (inv_iso hom) u \<rightarrow>\<^sup>* iso_verts (inv_iso hom) v" (is "?L \<longleftrightarrow> ?R")
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..

  show ?thesis
  proof
    assume ?L
    then obtain p where "H.awalk u p v" by (auto simp: H.reachable_awalk)
    moreover
    then have "set p \<subseteq> iso_arcs hom ` arcs G" by (simp add: H.awalk_def)
    ultimately
    show ?R using assms by (auto simp: awalk_app_iso_eq reachable_awalk)
  next
    assume ?R
    then obtain p0 where "awalk (iso_verts (inv_iso hom) u) p0 (iso_verts (inv_iso hom) v)"
      by (auto simp: reachable_awalk)
    moreover
    then have "set p0 \<subseteq> arcs G" by (simp add: awalk_def)
    define p where "p = map (iso_arcs hom) p0"
    have "set p \<subseteq> iso_arcs hom ` arcs G" "p0 = map (iso_arcs (inv_iso hom)) p"
      using \<open>set p0 \<subseteq> _\<close> hom by (auto simp: p_def map_idI subsetD)
    ultimately
    show ?L using assms by (auto simp: awalk_app_iso_eq[symmetric] H.reachable_awalk)
  qed
qed

lemma connectedI_app_iso:
  assumes c: "connected G" and hom: "digraph_isomorphism hom"
  shows "connected (app_iso hom G)"
proof -
  have *: "symcl (arcs_ends (app_iso hom G)) = (\<lambda>(u,v). (iso_verts hom u, iso_verts hom v)) ` symcl (arcs_ends G)"
    using hom by (auto simp add: app_iso_eq symcl_def)
  { fix u v assume "(u,v) \<in> rtrancl_on (verts G) (symcl (arcs_ends G))"
    then have "(iso_verts hom u, iso_verts hom v) \<in> rtrancl_on (verts (app_iso hom G)) (symcl (arcs_ends (app_iso hom G)))"
    proof induct
      case (step x y)
      have "(iso_verts hom x, iso_verts hom y)
          \<in> rtrancl_on (verts (app_iso hom G)) (symcl (arcs_ends (app_iso hom G)))"
        using step by (rule_tac rtrancl_on_into_rtrancl_on[where b="iso_verts hom x"]) (auto simp: *)
      then show ?case
        by (rule rtrancl_on_trans) (rule step)
    qed auto }
  with c show ?thesis unfolding connected_conv by auto
qed

end

lemma digraph_iso_swap:
  assumes "wf_digraph G" "digraph_iso G H" shows "digraph_iso H G"
proof -
  from assms obtain f where "pre_digraph.digraph_isomorphism G f" "H = app_iso f G"
    unfolding digraph_iso_def by auto
  then have "pre_digraph.digraph_isomorphism H (pre_digraph.inv_iso G f)" "app_iso (pre_digraph.inv_iso G f) H = G"
    using assms by (simp_all add: wf_digraph.digraph_isomorphism_invI pre_digraph.app_iso_inv)
  then show ?thesis unfolding digraph_iso_def by auto
qed

definition
  o_iso :: "('c,'d,'e,'f) digraph_isomorphism \<Rightarrow> ('a,'b,'c,'d) digraph_isomorphism \<Rightarrow> ('a,'b,'e,'f) digraph_isomorphism"
where
  "o_iso hom2 hom1 = \<lparr>
    iso_verts = iso_verts hom2 o iso_verts hom1,
    iso_arcs = iso_arcs hom2 o iso_arcs hom1,
    iso_head = iso_head hom2,
    iso_tail = iso_tail hom2
    \<rparr>"

lemma digraph_iso_trans[trans]:
  assumes "digraph_iso G H" "digraph_iso H I" shows "digraph_iso G I"
proof -
  from assms obtain hom1 where "pre_digraph.digraph_isomorphism G hom1" "H = app_iso hom1 G"
    by (auto simp: digraph_iso_def)
  moreover
  from assms obtain hom2 where "pre_digraph.digraph_isomorphism H hom2" "I = app_iso hom2 H"
    by (auto simp: digraph_iso_def)
  ultimately
  have "pre_digraph.digraph_isomorphism G (o_iso hom2 hom1)" "I = app_iso (o_iso hom2 hom1) G"
    apply (auto simp: o_iso_def app_iso_def pre_digraph.digraph_isomorphism_def)
    apply (rule comp_inj_on)
    apply auto
    apply (rule comp_inj_on)
    apply auto
    done
  then show ?thesis by (auto simp: digraph_iso_def)
qed

lemma (in pre_digraph) digraph_isomorphism_subgraphI:
  assumes "digraph_isomorphism hom"
  assumes "subgraph H G"
  shows "pre_digraph.digraph_isomorphism H hom"
  using assms by (auto simp: pre_digraph.digraph_isomorphism_def subgraph_def compatible_def intro: subset_inj_on)

(* XXX move *)
lemma (in wf_digraph) verts_app_inv_iso_subgraph:
  assumes hom: "digraph_isomorphism hom" and "V \<subseteq> verts G"
  shows "iso_verts (inv_iso hom) ` iso_verts hom ` V = V"
proof -
  have "\<And>x. x \<in> V \<Longrightarrow> iso_verts (inv_iso hom) (iso_verts hom x) = x"
    using assms by auto
  then show ?thesis by (auto simp: image_image cong: image_cong)
qed

(* XXX move *)
lemma (in wf_digraph) arcs_app_inv_iso_subgraph:
  assumes hom: "digraph_isomorphism hom" and "A \<subseteq> arcs G"
  shows "iso_arcs (inv_iso hom) ` iso_arcs hom ` A = A"
proof -
  have "\<And>x. x \<in> A \<Longrightarrow> iso_arcs (inv_iso hom) (iso_arcs hom x) = x"
    using assms by auto
  then show ?thesis by (auto simp: image_image cong: image_cong)
qed

(* XXX move *)
lemma (in pre_digraph) app_iso_inv_subgraph[simp]:
  assumes "digraph_isomorphism hom" "subgraph H G"
  shows "app_iso (inv_iso hom) (app_iso hom H) = H"
proof -
  from assms interpret wf_digraph G by auto
  have "\<And>u. u \<in> verts H \<Longrightarrow> u \<in> verts G" "\<And>a. a \<in> arcs H \<Longrightarrow> a \<in> arcs G"
    using assms by auto
  with assms show ?thesis
    by (intro pre_digraph.equality) (auto simp: verts_app_inv_iso_subgraph
      arcs_app_inv_iso_subgraph compatible_def)
qed

lemma (in wf_digraph) app_iso_iso_inv_subgraph[simp]:
  assumes "digraph_isomorphism hom"
  assumes subg: "subgraph H (app_iso hom G)"
  shows "app_iso hom (app_iso (inv_iso hom) H) = H"
proof -
  have "\<And>u. u \<in> verts H \<Longrightarrow> u \<in> iso_verts hom ` verts G" "\<And>a. a \<in> arcs H \<Longrightarrow> a \<in> iso_arcs hom ` arcs G"
    using assms by (auto simp: subgraph_def)
  with assms show ?thesis
    by (intro pre_digraph.equality) (auto simp: compatible_def image_image cong: image_cong)
qed

lemma (in pre_digraph) subgraph_app_isoI':
  assumes hom: "digraph_isomorphism hom"
  assumes subg: "subgraph H H'" "subgraph H' G"
  shows "subgraph (app_iso hom H) (app_iso hom H')"
proof -
  have "subgraph H G" using subg by (rule subgraph_trans)
  then have "pre_digraph.digraph_isomorphism H hom" "pre_digraph.digraph_isomorphism H' hom"
    using assms by (auto intro: digraph_isomorphism_subgraphI)
  then show ?thesis
    using assms by (auto simp: subgraph_def wf_digraph.wf_digraphI_app_iso compatible_def
      intro: digraph_isomorphism_subgraphI)
qed

lemma (in pre_digraph) subgraph_app_isoI:
  assumes "digraph_isomorphism hom"
  assumes "subgraph H G"
  shows "subgraph (app_iso hom H) (app_iso hom G)"
  using assms by (auto intro: subgraph_app_isoI' wf_digraph.subgraph_refl)

lemma (in pre_digraph) app_iso_eq_conv:
  assumes "digraph_isomorphism hom"
  assumes "subgraph H1 G" "subgraph H2 G"
  shows "app_iso hom H1 = app_iso hom H2 \<longleftrightarrow> H1 = H2" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  then have "app_iso (inv_iso hom) (app_iso hom H1) = app_iso (inv_iso hom) (app_iso hom H2)"
    by simp
  with assms show ?R by auto
qed simp

lemma in_arcs_app_iso_cases:
  assumes "a \<in> arcs (app_iso hom G)"
  obtains a0 where "a = iso_arcs hom a0" "a0 \<in> arcs G"
  using assms by auto

lemma in_verts_app_iso_cases:
  assumes "v \<in> verts (app_iso hom G)"
  obtains v0 where "v = iso_verts hom v0" "v0 \<in> verts G"
  using assms by auto

lemma (in wf_digraph) max_subgraph_iso:
  assumes hom: "digraph_isomorphism hom"
  assumes subg: "subgraph H (app_iso hom G)"
  shows "pre_digraph.max_subgraph (app_iso hom G) P H
    \<longleftrightarrow> max_subgraph (P o app_iso hom) (app_iso (inv_iso hom) H)"
proof -
  have hom_inv: "pre_digraph.digraph_isomorphism (app_iso hom G) (inv_iso hom)"
    using hom by (rule digraph_isomorphism_invI)
  interpret aG: wf_digraph "app_iso hom G" using hom ..

  have *: "subgraph (app_iso (inv_iso hom) H) G"
    using hom pre_digraph.subgraph_app_isoI'[OF hom_inv subg aG.subgraph_refl] by simp
  define H0 where "H0 = app_iso (inv_iso hom) H"
  then have H0: "H = app_iso hom H0" "subgraph H0 G"
    using hom subg \<open>subgraph _ G\<close> by (auto simp: )

  show ?thesis (is "?L \<longleftrightarrow> ?R")
  proof
    assume ?L then show ?R using assms H0
      by (auto simp: max_subgraph_def aG.max_subgraph_def pre_digraph.subgraph_app_isoI'
        subgraph_refl pre_digraph.app_iso_eq_conv)
  next
    assume ?R
    then show ?L
      using assms hom_inv pre_digraph.subgraph_app_isoI[OF hom_inv]
      apply (auto simp: max_subgraph_def aG.max_subgraph_def)
      apply (erule allE[of _ "app_iso (inv_iso hom) H'" for H'])
      apply (auto simp: pre_digraph.subgraph_app_isoI' pre_digraph.app_iso_eq_conv)
      done
  qed
qed

lemma (in pre_digraph) max_subgraph_cong:
  assumes "H = H'" "\<And>H''. subgraph H' H'' \<Longrightarrow> subgraph H'' G \<Longrightarrow> P H'' = P' H''"
  shows "max_subgraph P H = max_subgraph P' H'"
  using assms by (auto simp: max_subgraph_def intro: wf_digraph.subgraph_refl)

lemma (in pre_digraph) inj_on_app_iso:
  assumes hom: "digraph_isomorphism hom"
  assumes "S \<subseteq> {H. subgraph H G}"
  shows "inj_on (app_iso hom) S"
  using assms by (intro inj_onI) (subst (asm) app_iso_eq_conv, auto)

subsection \<open>Graph Invariants\<close>

context
  fixes G hom assumes hom: "pre_digraph.digraph_isomorphism G hom"
begin

  interpretation wf_digraph G using hom by (auto simp: pre_digraph.digraph_isomorphism_def)

  lemma card_verts_iso[simp]: "card (iso_verts hom ` verts G) = card (verts G)"
    using hom by (intro card_image digraph_isomorphism_inj_on_verts)

  lemma card_arcs_iso[simp]: "card (iso_arcs hom ` arcs G) = card (arcs G)"
    using hom by (intro card_image digraph_isomorphism_inj_on_arcs)

  lemma strongly_connected_iso[simp]: "strongly_connected (app_iso hom G) \<longleftrightarrow> strongly_connected G"
    using hom by (auto simp: strongly_connected_def reachable_app_iso_eq)

  lemma subgraph_strongly_connected_iso:
    assumes "subgraph H G"
    shows "strongly_connected (app_iso hom H) \<longleftrightarrow> strongly_connected H"
  proof -
    interpret H: wf_digraph H using \<open>subgraph H G\<close> ..
    have "H.digraph_isomorphism hom" using hom assms by (rule digraph_isomorphism_subgraphI)
    then show ?thesis
      using assms by (auto simp: strongly_connected_def H.reachable_app_iso_eq)
  qed

  lemma sccs_iso[simp]: "pre_digraph.sccs (app_iso hom G) = app_iso hom ` sccs" (is "?L = ?R")
  proof (intro set_eqI iffI)
    fix x assume "x \<in> ?L"
    then have "subgraph x (app_iso hom G)"
      by (auto simp: pre_digraph.sccs_def)
    then show "x \<in> ?R"
      using \<open>x \<in> ?L\<close> hom by (auto simp: pre_digraph.sccs_altdef2 max_subgraph_iso
        subgraph_strongly_connected_iso cong: max_subgraph_cong  intro: rev_image_eqI)
  next
    fix x assume "x \<in> ?R"
    then obtain x0 where "x0 \<in> sccs" "x = app_iso hom x0" by auto
    then show "x \<in> ?L"
      using hom by (auto simp: pre_digraph.sccs_altdef2 max_subgraph_iso subgraph_app_isoI
        subgraphI_max_subgraph subgraph_strongly_connected_iso cong: max_subgraph_cong)
  qed

  lemma card_sccs_iso[simp]: "card (app_iso hom ` sccs) = card sccs"
    apply (rule card_image)
    using hom
    apply (rule inj_on_app_iso)
    apply auto
    done

end

end


theory MVT_Ex
imports
  "HOL-Analysis.Analysis"
  "HOL-Decision_Procs.Approximation"
  "../ODE_Auxiliarities"
begin

subsection \<open>(Counter)Example of Mean Value Theorem in Euclidean Space \label{sec:countermvt}\<close>

text \<open>There is no exact analogon of the mean value theorem in the multivariate case!\<close>

lemma MVT_wrong: assumes
  "\<And>J a u (f::real*real\<Rightarrow>real*real).
      (\<And>x. FDERIV f x :> J x) \<Longrightarrow>
      (\<exists>t\<in>{0<..<1}. f (a + u) - f a = J (a + t *\<^sub>R u) u)"
  shows "False"
proof -
  have "\<And>t::real*real. FDERIV (\<lambda>t. (cos (fst t), sin (fst t))) t :> (\<lambda>h. (- ((fst h) * sin (fst t)), (fst h) * cos (fst t)))"
    by (auto intro!: derivative_eq_intros)
  from assms[OF this, of "(pi, pi)" "(pi, pi)"] obtain t::real where t: "0 < t" "t < 1" and
    "pi * sin (t * pi) = 2" "cos (t * pi) = 0"
    by auto
  then obtain n where tpi: "t * pi = real_of_int n * (pi / 2)" and "odd n"
    by (auto simp: cos_zero_iff_int)
  then have teq: "t = real_of_int n / 2" by auto
  then have "n = 1" using t \<open>odd n\<close> by arith
  then have "t = 1/2" using teq by simp
  have "sin (t * pi) = 1"
    by (simp add: \<open>t = 1/2\<close> sin_eq_1)
  with \<open>pi * sin (t * pi) = 2\<close>
  have "pi = 2" by simp
  moreover have "pi > 2" using pi_approx by simp
  ultimately show False by simp
qed

lemma MVT_corrected:
  fixes f::"'a::ordered_euclidean_space\<Rightarrow>'b::euclidean_space"
  assumes fderiv: "\<And>x. x \<in> D \<Longrightarrow> (f has_derivative J x) (at x within D)"
  assumes line_in: "\<And>x. \<lbrakk>0 \<le> x; x \<le> 1\<rbrakk> \<Longrightarrow> a + x *\<^sub>R u \<in> D"
  shows "(\<exists>t\<in>Basis\<rightarrow>{0<..<1}. (f (a + u) - f a) = (\<Sum>i\<in>Basis. (J (a + t i *\<^sub>R u) u \<bullet> i) *\<^sub>R i))"
proof -
  {
    fix i::'b
    assume "i \<in> Basis"
    have subset: "((\<lambda>x. a + x *\<^sub>R u) ` {0..1}) \<subseteq> D"
      using line_in by force
    have "\<And>x. \<lbrakk>0 \<le> x; x \<le> 1\<rbrakk> \<Longrightarrow> ((\<lambda>b. f (a + b *\<^sub>R u) \<bullet> i) has_derivative (\<lambda>b. b *\<^sub>R J (a + x *\<^sub>R u) u \<bullet> i)) (at x within {0..1})"
      using line_in
      by (auto intro!: derivative_eq_intros
        has_derivative_subset[OF _ subset]
        has_derivative_in_compose[where f="\<lambda>x. a + x *\<^sub>R u"]
        fderiv line_in
        simp add: linear.scaleR[OF has_derivative_linear[OF fderiv]])
    with zero_less_one
    have "\<exists>x\<in>{0<..<1}. f (a + 1 *\<^sub>R u) \<bullet> i - f (a + 0 *\<^sub>R u) \<bullet> i = (1 - 0) *\<^sub>R J (a + x *\<^sub>R u) u \<bullet> i"
      by (rule mvt_simple)
  }
  then obtain t where "\<forall>i\<in>Basis. t i \<in> {0<..<1} \<and> f (a + u) \<bullet> i - f a \<bullet> i = J (a + t i *\<^sub>R u) u \<bullet> i"
    by atomize_elim (force intro!: bchoice)
  hence "t \<in> Basis \<rightarrow> {0<..<1}" "\<And>i. i \<in> Basis \<Longrightarrow> (f (a + u) - f a) \<bullet> i = J (a + t i *\<^sub>R u) u \<bullet> i"
    by (auto simp: inner_diff_left)
  moreover hence "(f (a + u) - f a) = (\<Sum>i\<in>Basis. (J (a + t i *\<^sub>R u) u \<bullet> i) *\<^sub>R i)"
    by (intro euclidean_eqI[where 'a='b]) simp
  ultimately show ?thesis by blast
qed

lemma MVT_ivl:
  fixes f::"'a::ordered_euclidean_space\<Rightarrow>'b::ordered_euclidean_space"
  assumes fderiv: "\<And>x. x \<in> D \<Longrightarrow> (f has_derivative J x) (at x within D)"
  assumes J_ivl: "\<And>x. x \<in> D \<Longrightarrow> J x u \<in> {J0 .. J1}"
  assumes line_in: "\<And>x. x \<in> {0..1} \<Longrightarrow> a + x *\<^sub>R u \<in> D"
  shows "f (a + u) - f a \<in> {J0..J1}"
proof -
  from MVT_corrected[OF fderiv line_in] obtain t where
    t: "t\<in>Basis \<rightarrow> {0<..<1}" and
    mvt: "f (a + u) - f a = (\<Sum>i\<in>Basis. (J (a + t i *\<^sub>R u) u \<bullet> i) *\<^sub>R i)"
    by auto
  note mvt
  also have "\<dots> \<in> {J0 .. J1}"
  proof -
    have J: "\<And>i. i \<in> Basis \<Longrightarrow> J0 \<le> J (a + t i *\<^sub>R u) u"
            "\<And>i. i \<in> Basis \<Longrightarrow> J (a + t i *\<^sub>R u) u \<le> J1"
      using J_ivl t line_in by (auto simp: Pi_iff)
    show ?thesis
      using J
      unfolding atLeastAtMost_iff eucl_le[where 'a='b]
      by auto
  qed
  finally show ?thesis .
qed

lemma MVT:
  shows
  "\<And>J J0 J1 a u (f::real*real\<Rightarrow>real*real).
    (\<And>x. FDERIV f x :> J x) \<Longrightarrow>
    (\<And>x. J x u \<in> {J0 .. J1}) \<Longrightarrow>
    f (a + u) - f a \<in> {J0 .. J1}"
  by (rule_tac J = J in MVT_ivl[where D=UNIV]) auto

lemma MVT_ivl':
  fixes f::"'a::ordered_euclidean_space\<Rightarrow>'b::ordered_euclidean_space"
  assumes fderiv: "(\<And>x. x \<in> D \<Longrightarrow> (f has_derivative J x) (at x within D))"
  assumes J_ivl: "\<And>x. x \<in> D \<Longrightarrow> J x (a - b) \<in> {J0..J1}"
  assumes line_in: "\<And>x. x \<in> {0..1} \<Longrightarrow> b + x *\<^sub>R (a - b) \<in> D"
  shows "f a \<in> {f b + J0..f b + J1}"
proof -
  have "f (b + (a - b)) - f b \<in> {J0 .. J1}"
    using J_ivl MVT_ivl fderiv line_in by blast
  thus ?thesis
    by (auto simp: diff_le_eq le_diff_eq ac_simps)
qed

end