theory UnionFind
  imports Main
begin

(*Initial definitions*)

definition "init n = [0..<n]"                         (*initial list is a list from 0 to n-1*)
definition "pred ls i = ls!i"                         (*location at every index points to parent*)
definition "is_root ls i \<longleftrightarrow> pred ls i = i"           (*if own parent, then root*)

function (domintros) root_of where                    (*function with custom termination*)
  "root_of ls i = (if is_root ls i then i else root_of ls (ls!i))"
   apply auto[1]
  by blast

thm "root_of.psimps"
thm "root_of.pinduct"

(*A list is a valid UFDS if all its indices are less than the length of the list, and the indices terminate*)
definition "invar ls \<equiv>  \<forall>i<length ls. ls!i < length ls \<and> root_of_dom (ls,i)"

(*Lemmas*)

(*If an element has itself as a root, it is a root*)
lemma is_root_corr : "ls!i = i \<Longrightarrow> is_root ls i"
  apply(subst is_root_def)
  apply(subst pred_def)
  by simp

(*The init function sets all the members to themselves as roots*)
lemma init_corr : "\<forall>i\<in> set(init n). (is_root (init n) i)"
  apply(subst is_root_def)
  apply(auto)
  by (simp add: pred_def init_def)

(*If a member is a root, it is its own root*)
lemma root_of_base: "is_root ls i \<Longrightarrow> root_of ls i = i"
  apply(subst root_of.psimps)
   apply(auto)
  using root_of.domintros by blast

(*The root of a non-root member is the same as the root of its parent's member*)
lemma root_of_step: " \<lbrakk> invar ls; i < length ls; ls!i \<noteq> i \<rbrakk>  \<Longrightarrow> root_of ls i = root_of ls (ls!i)"
  apply(subst root_of.psimps)
  apply (simp add: invar_def)
  by (simp add: pred_def is_root_def)

(*The root of a parent is the root of its child*)
lemma root_of_back: " \<lbrakk> invar ls; i < length ls; ls!i \<noteq> i \<rbrakk>  \<Longrightarrow> root_of ls (ls!i) = root_of ls i"
  by (simp add: root_of_step)

(*The init function returns a valid UFDS*)
lemma invar_init: "invar (init n)"
  apply(subst init_def)
  apply(subst invar_def)
  apply(auto)
  using is_root_corr root_of.domintros by fastforce

(*union of two sets*)
definition union where "union i j ls = ls[root_of ls i := root_of ls j]"

type_synonym eqcs = "nat \<Rightarrow> nat set"

(*return disjoint set the element belongs to*)
definition \<alpha> :: "nat list \<Rightarrow> eqcs" where "\<alpha> ls i =
  (if i<length ls then {j. j<length ls \<and> root_of ls j = root_of ls i} else {i})"

(*return if an element is part of a disjoint set after uniting two other elements*)
definition union_eqc :: "nat \<Rightarrow> nat \<Rightarrow> eqcs \<Rightarrow> eqcs"
  where
  "union_eqc x y eqc i = (if i \<in> eqc x \<union> eqc y then eqc x \<union> eqc y else eqc i)"

(*Lemmas*)

(*Every disjoint set from init list has only itself as an element*)
lemma "\<alpha> (init n) i = {i}"
  apply (auto simp add: init_def \<alpha>_def)
  using is_root_corr root_of_base by auto

(*Union does not change length of list*)
lemma length_same : "length ls = length (union a b ls)"
  by (simp add: union_def)

(*Lemmas I couldn't prove*)
lemma length_fixed : "\<lbrakk>invar ls ; x < length ls ; y < length ls ; i < length ls \<rbrakk> \<Longrightarrow> union x y ls ! i < length (union x y ls)"
  apply(simp add: union_def)
  apply(subst root_of.psimps)
   apply(auto)
  using invar_def apply auto[1]

  oops

lemma
  assumes "invar ls" "x<length ls" "y<length ls"
  shows "\<alpha> (union x y ls) = union_eqc x y (\<alpha> ls)"
  oops

lemma
  assumes "invar ls" "x<length ls" "y<length ls"
  shows "invar (union x y ls)"
  unfolding invar_def
proof(intro allI)
  fix i
  have "union x y ls ! i < length (union x y ls)" using assms
    oops

lemma all_have_root: "invar ls \<Longrightarrow> i < length ls \<Longrightarrow> root_of ls i < length ls"
  oops

end


theory ext_ContinuousInv
  imports ext_BigStepContinuous
begin
lemma chainrule:
  assumes "\<forall>x. ((\<lambda>v. g (vec2state v)) has_derivative g' (vec2state x)) (at x within UNIV)"
    and "ODEsol ode p d"
    and "t \<in> {0 .. d}"
  shows "((\<lambda>t. g (p t)) has_derivative (\<lambda>s. g' (p t) (s *\<^sub>R ODE2Vec ode (p t)))) (at t within {0 .. d})"
proof -
  have 1: "(\<And>x. x \<in> UNIV \<Longrightarrow> ((\<lambda>v. g (vec2state v)) has_derivative g' (vec2state x)) (at x))"
    using assms(1) by auto
  have 2: "0 \<le> t \<and> t \<le> d"
    using assms(3) by auto
  have 3: "((\<lambda>t. state2vec(p t)) has_derivative (\<lambda>s. s *\<^sub>R ODE2Vec ode (p t))) (at t within {0..d})"
    using 2 assms(2) using ODEsol_old[OF assms(2)]unfolding ODEsol_def has_vderiv_on_def has_vector_derivative_def by auto
  show ?thesis
  using 1 2 3 has_derivative_in_compose2[of UNIV "(\<lambda>v. g (vec2state v))" "(\<lambda>v. g' (vec2state v))" "(\<lambda>t. state2vec (p t))" "{0 .. d}" t "(\<lambda>s. s *\<^sub>R ODE2Vec ode (p t))"]
  by auto
qed

lemma chainrule':
  assumes "\<forall>x. ((\<lambda>v. g (vec2state v)) has_derivative g' (vec2state x)) (at x within UNIV)"
    and "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {-e .. d+e}"
    and "e>0"
    and "t \<in> {-e .. d+e}"
  shows "((\<lambda>t. g (p t)) has_derivative (\<lambda>s. g' (p t) (s *\<^sub>R ODE2Vec ode (p t)))) (at t within {-e .. d+e})"
proof -
  have 1: "(\<And>x. x \<in> UNIV \<Longrightarrow> ((\<lambda>v. g (vec2state v)) has_derivative g' (vec2state x)) (at x))"
    using assms(1) by auto
  have 2: "-e \<le> t \<and> t \<le> d+e"
    using assms(3) assms(4) by auto
  have 3: "((\<lambda>t. state2vec(p t)) has_derivative (\<lambda>s. s *\<^sub>R ODE2Vec ode (p t))) (at t within {-e .. d+e})"
    using 2 assms(2) unfolding ODEsol_def has_vderiv_on_def has_vector_derivative_def by auto
  show ?thesis
  using 1 2 3 has_derivative_in_compose2[of UNIV "(\<lambda>v. g (vec2state v))" "(\<lambda>v. g' (vec2state v))" "(\<lambda>t. state2vec (p t))" "{-e .. d+e}" t "(\<lambda>s. s *\<^sub>R ODE2Vec ode (p t))"]
  by auto
qed

theorem Valid_inv:
  fixes inv :: "state \<Rightarrow> real"
  assumes "\<forall>x. ((\<lambda>v. inv (vec2state v)) has_derivative g' x) (at x within UNIV)"
      and "\<forall>S. b S \<longrightarrow> g' (state2vec S) (ODE2Vec ode S) = 0"
    shows "\<Turnstile> {\<lambda>(a,s) tr. inv s = r \<and> tr = tra \<and> b s}
       Cont ode b
      {\<lambda>(a,s) tr. (\<exists>p d. tr = tra @ [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})] \<and> (\<forall>t\<in>{0..d}. inv (p t) = r))}"
  unfolding Valid_def
  apply (auto elim!: contE)
  subgoal for d p
    apply (rule exI[where x=p])
    apply (rule exI[where x=d])
    apply auto
    subgoal premises pre for \<tau>
    proof-
      have 1: "\<forall>t\<in>{0 .. d}. ((\<lambda>t. inv(p t)) has_derivative  (\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec ode (p t)))) (at t within {0 .. d})"
        using pre assms
        using chainrule[of inv "\<lambda>x. g'(state2vec x)" ode p d]
        by auto
      have 2: "\<forall>s. g' (state2vec(p t)) ((s *\<^sub>R 1) *\<^sub>R ODE2Vec ode (p t)) = s *\<^sub>R g' (state2vec(p t)) (1 *\<^sub>R ODE2Vec ode (p t))" if "t\<in>{0 .. d}" for t
        using 1 unfolding has_derivative_def bounded_linear_def
        using that linear_iff[of "(\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec ode (p t)))"]
        by blast
      have 3: "\<forall>s. (s *\<^sub>R 1) = s" by simp
      have 4: "\<forall>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec ode (p t)) = s *\<^sub>R g' (state2vec(p t)) (ODE2Vec ode (p t))" if "t\<in>{0 .. d}" for t
        using 2 3 that by auto
      have 5: "\<forall>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec ode (p t))= 0" if "t\<in>{0 ..<d}" for t
        using 4 assms(2) that pre by auto
      show ?thesis
        using mvt_real_eq[of d "(\<lambda>t. inv(p t))""\<lambda>t. (\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec ode (p t)))" \<tau>]
        using 1 5 pre by auto
    qed
    done
  done

text \<open>ODE with invariant\<close>
inductive ode_inv_assn :: "(state \<Rightarrow> bool) \<Rightarrow> 'a tassn" where
  "\<forall>t\<in>{0..d::real}. f (p t) \<Longrightarrow> ode_inv_assn f [WaitBlk d (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})]"

lemmas ode_inv_assn_induct = ode_inv_assn.induct[split_format(complete)]

inductive_cases ode_inv_assn_elim: "ode_inv_assn f tr"

theorem Valid_inv':
  fixes inv :: "state \<Rightarrow> real"
  assumes "\<forall>x. ((\<lambda>v. inv (vec2state v)) has_derivative g' (x)) (at x within UNIV)"
      and "\<forall>S. b S \<longrightarrow> g' (state2vec S) (ODE2Vec ode S) = 0"
  shows "\<Turnstile> {\<lambda>(a,s) tr. inv s = r \<and> P tr \<and> b s}
     Cont ode b
    {\<lambda>(a,s) tr. (P @\<^sub>t ode_inv_assn (\<lambda>s. inv s = r)) tr}"
  unfolding Valid_def
  apply (auto elim!: contE)
  subgoal for tr1 d p
    apply(simp add: join_assn_def)
    apply(rule exI [where x="tr1"])
    apply auto
    apply (auto intro!: ode_inv_assn.intros)
  subgoal premises pre for \<tau>
    proof-
      have 1: "\<forall>t\<in>{0 .. d}. ((\<lambda>t. inv(p t)) has_derivative  (\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec ode (p t)))) (at t within {0 .. d})"
        using pre assms
        using chainrule[of inv "\<lambda>x. g'(state2vec x)" ode p d]
        by auto
      have 2: "\<forall>s. g' (state2vec(p t)) ((s *\<^sub>R 1) *\<^sub>R ODE2Vec ode (p t)) = s *\<^sub>R g' (state2vec(p t)) (1 *\<^sub>R ODE2Vec ode (p t))" if "t\<in>{0 .. d}" for t
        using 1 unfolding has_derivative_def bounded_linear_def
        using that linear_iff[of "(\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec ode (p t)))"]
        by blast
      have 3: "\<forall>s. (s *\<^sub>R 1) = s" by simp
      have 4: "\<forall>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec ode (p t)) = s *\<^sub>R g' (state2vec(p t)) (ODE2Vec ode (p t))" if "t\<in>{0 .. d}" for t
        using 2 3 that by auto
      have 5: "\<forall>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec ode (p t))= 0" if "t\<in>{0 ..<d}" for t
        using 4 assms(2) that pre by auto
      show ?thesis
        using mvt_real_eq[of d "(\<lambda>t. inv(p t))""\<lambda>t. (\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec ode (p t)))" \<tau>]
        using 1 5 pre by auto
    qed
    done
  done

theorem Valid_ode_supp:
  assumes "ode_supp (ODE ode) \<subseteq> VS"
  shows "\<Turnstile> {\<lambda>(a,s) tr. supp s \<subseteq> VS}
     Cont (ODE ode) b
    {\<lambda>(a,s) tr. supp s \<subseteq> VS}"
  unfolding Valid_def
  apply (auto elim!: contE)
 subgoal for v d p
    unfolding supp_def apply auto
    subgoal premises pre
    proof(rule ccontr)
      assume cond:"v \<notin> VS"
     have 1:"p 0 v = 0" using pre cond by auto
     have 2:"ode v = (\<lambda>_. 0)"
       using assms cond by auto
     have 3:"((\<lambda>t. p t v) has_vderiv_on (\<lambda>t. 0)) {0 .. d}"
       using ODEsol_old[OF pre(4)]
       using has_vderiv_on_proj[of "(\<lambda>t. state2vec (p t))" "(\<lambda>t. ODE2Vec (ODE ode) (p t))"  "{0 .. d}" v]
       apply auto
       unfolding state2vec_def apply auto
       using 2 by auto
     then have 4:"p 0 v = p d v"
       unfolding has_vderiv_on_def has_vector_derivative_def
       using mvt_real_eq[of d "(\<lambda>t. p t v)" "\<lambda>t. (\<lambda>x. x *\<^sub>R 0)" d]
       using pre by auto
     then show False using 1 pre by auto
   qed
   done
  done

theorem Valid_inv_barrier_s_tr_le:
  fixes inv :: "state \<Rightarrow> real"
  assumes "\<forall>x. ((\<lambda>v. inv (vec2state v)) has_derivative g' (x)) (at x within UNIV)"
    and "\<forall>S. (b S)\<longrightarrow> ((inv S = 0) \<longrightarrow> g' (state2vec S) (ODE2Vec (ODE ode) S) < 0)"
  shows "\<Turnstile> {\<lambda>(a,s) tr. inv s \<le> 0 \<and> b s \<and> P tr}
     Cont (ODE ode) b
    {\<lambda>(a,s) tr. inv s \<le> 0 \<and> (P @\<^sub>t ode_inv_assn (\<lambda>s. inv s \<le> 0)) tr}"
  unfolding Valid_def
  apply (auto elim!: contE)
 subgoal premises pre for tr1 d p
    proof-
     obtain e where e: "e > 0" "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec (ODE ode) (p t))) {-e .. d+e}"
       using pre unfolding ODEsol_def by auto
    have 1: "\<forall>t\<in>{-e .. d+e}. ((\<lambda>t. inv(p t)) has_derivative  (\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE ode) (p t)))) (at t within {-e .. d+e})"
        using pre assms e
        using chainrule'[of inv "\<lambda>x. g'(state2vec x)" p "(ODE ode)" e d]
        by auto
    have 2: "\<forall>s. g' (state2vec(p t)) ((s *\<^sub>R 1) *\<^sub>R ODE2Vec (ODE ode) (p t)) = s *\<^sub>R g' (state2vec(p t)) (1 *\<^sub>R ODE2Vec (ODE ode) (p t))" if "t\<in>{-e .. d+e}" for t
        using 1 unfolding has_derivative_def bounded_linear_def
        using that linear_iff[of "(\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE ode) (p t)))"]
        by blast
    have 3: "(s *\<^sub>R 1) = s" and "(1 *\<^sub>R s) = s"
      apply simp by simp
      have 4: "\<forall>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE ode) (p t)) = s *\<^sub>R g' (state2vec(p t)) (ODE2Vec (ODE ode) (p t))" if "t\<in>{-e .. d+e}" for t
        using 2 3 that by auto
      have 5: "\<forall>t\<in>{0..<d}. inv(p t) = 0 \<longrightarrow>  g' (state2vec(p t)) (ODE2Vec (ODE ode) (p t))< 0" if "t\<in>{0 ..<d}" for t
        using 4 assms(2) that pre by auto
      show ?thesis
        using real_inv_le[OF 1, of 0]
        using pre 5 e 3 by auto
    qed
  subgoal for tr1 d p
    apply(simp add: join_assn_def)
    apply(rule exI [where x="tr1"])
    apply auto
   apply (auto intro!: ode_inv_assn.intros)
   subgoal premises pre for \<tau>
   proof-
     obtain e where e: "e > 0" "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec (ODE ode) (p t))) {-e .. d+e}"
       using pre unfolding ODEsol_def by auto
    have 1: "\<forall>t\<in>{-e .. d+e}. ((\<lambda>t. inv(p t)) has_derivative  (\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE ode) (p t)))) (at t within {-e .. d+e})"
        using pre assms e
        using chainrule'[of inv "\<lambda>x. g'(state2vec x)" p "(ODE ode)" e d]
        by auto
    have 2: "\<forall>s. g' (state2vec(p t)) ((s *\<^sub>R 1) *\<^sub>R ODE2Vec (ODE ode) (p t)) = s *\<^sub>R g' (state2vec(p t)) (1 *\<^sub>R ODE2Vec (ODE ode) (p t))" if "t\<in>{-e .. d+e}" for t
        using 1 unfolding has_derivative_def bounded_linear_def
        using that linear_iff[of "(\<lambda>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE ode) (p t)))"]
        by blast
    have 3: "(s *\<^sub>R 1) = s" and "(1 *\<^sub>R s) = s"
      apply simp by simp
      have 4: "\<forall>s. g' (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE ode) (p t)) = s *\<^sub>R g' (state2vec(p t)) (ODE2Vec (ODE ode) (p t))" if "t\<in>{-e .. d+e}" for t
        using 2 3 that by auto
      have 5: "inv(p t) = 0 \<longrightarrow>  g' (state2vec(p t)) (ODE2Vec (ODE ode) (p t))< 0" if "t\<in>{0 ..<d}" for t
        using 4 assms(2) that pre by auto
      show ?thesis
        using real_inv_le[OF 1, of 0]
        using pre 5 e 3 by auto
    qed
    done
  done

theorem DC:
  assumes "\<Turnstile> {\<lambda>(a,s) tr. init s \<and> P tr \<and> b s}
     Cont ode b
    {\<lambda>(a,s) tr. (P @\<^sub>t ode_inv_assn c) tr}"
      and "\<Turnstile> {\<lambda>(a,s) tr. init s \<and> P tr \<and> (\<lambda>s. b s \<and> c s) s}
     Cont ode (\<lambda>s. b s \<and> c s)
    {\<lambda>(a,s) tr. (P @\<^sub>t ode_inv_assn d) tr}"
    shows "\<Turnstile> {\<lambda>(a,s) tr. init s \<and> P tr \<and> b s}
     Cont ode b
    {\<lambda>(a,s) tr. (P @\<^sub>t ode_inv_assn d) tr}"
unfolding Valid_def
  apply (auto elim!: contE)
  subgoal premises pre for tr T p a
  proof-
    have 1:"big_step (Cont ode b) (a,p 0) [WaitBlk T (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})] (a,p T)"
      apply (rule big_step.intros)
      using pre by auto
    have 2:"(P @\<^sub>t ode_inv_assn c) (tr @ [WaitBlk T (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})])"
      using assms(1) 1
      unfolding Valid_def using pre by auto
    obtain tra1 tra2 where tra1:"P tra1" and tra2:"ode_inv_assn c tra2" and tra3:"tra1 @ tra2 = (tr @ [WaitBlk T (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})])"
      using 2 unfolding join_assn_def by auto
    obtain T' p' where Tp:"tra2 = [WaitBlk T' (\<lambda>\<tau>. EState (a,p' \<tau>)) ({}, {})]"
      using tra2 tra3 apply (induct rule: ode_inv_assn.induct)
      by auto
    have 3:"ode_inv_assn c [WaitBlk T (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})]"
      using Tp tra3 tra2 by auto
    have 4: "\<forall>t\<in>{0..T}. c (p t)"
      using 3 apply (elim ode_inv_assn_elim)
      apply auto
      subgoal for d p' t
        apply (frule WaitBlk_cong)
        apply (frule WaitBlk_cong2)
        by auto
      done
    have 5:"big_step (Cont ode (\<lambda>s. b s \<and> c s)) (a,p 0) [WaitBlk T (\<lambda>\<tau>. EState (a,p \<tau>)) ({}, {})] (a,p T)"
      apply (rule big_step.intros)
      using pre 4 by auto
    show ?thesis
      using assms(2)
      unfolding Valid_def
      using pre 4 5
      by (smt (verit, best) atLeastAtMost_iff case_prod_conv)
  qed
  done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_regexp_PlusIdempotent
imports "../../Test_Base"
begin

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Plus p p) s) = (recognise p s))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_regexp_SeqAssociative
imports "../../Test_Base"
begin

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Seq p (Seq q r)) s) =
      (recognise (Seq (Seq p q) r) s))"
  oops

end


theory Smap_fst_szip
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer
codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")
datatype ('a, 'b) Pair2 = Pair2 'a 'b
primcorec szip :: "'a Stream \<Rightarrow> 'b Stream \<Rightarrow> (('a, 'b) Pair2) Stream" where
  "shd (szip s1 s2) = Pair2 (shd s1) (shd s2)"
| "stl (szip s1 s2) = szip (stl s1) (stl s2)"

primcorec smap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "smap f xs = SCons (f (shd xs)) (smap f (stl xs))"

fun fst2 :: "('a,'b) Pair2 \<Rightarrow> 'a" where
"fst2 (Pair2 a b) = a"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"

(*hipster_obs Stream Lst obsStream szip smap fst2
Proving: fst2 (Pair22 x2 z) = x2
Undefined fact: "Smap_fst_szip.Pair2.coinduct_strong"*)
theorem smap_fst_szip:
  "smap fst2 (szip xs ys) = xs"
by hipster_coinduct_sledgehammer
end


theory rotate
imports Main
        "../data/Natu"
        "../data/list"
        "../funcs/append"
        "$HIPSTER_HOME/IsaHipster"

begin

fun rotate :: "Nat => 'a list => 'a list" where
  "rotate (Z) y = y"
| "rotate (S z) (Nil2) = Nil2"
| "rotate (S z) (Cons2 x2 x3) = rotate z (append x3 (Cons2 x2 (Nil2)))"

(*hipster rotate append*)
lemma lemma_ab [thy_expl]: "rotate x1 Nil2 = Nil2"
by (hipster_induct_schemes rotate.simps append.simps)

lemma lemma_ac [thy_expl]: "rotate x2 (Cons2 y2 Nil2) = Cons2 y2 Nil2"
by (hipster_induct_schemes rotate.simps append.simps)

lemma lemma_ad [thy_expl]: "append (rotate x3 y3) (rotate x3 y3) = rotate x3 (append y3 y3)"
by (hipster_induct_schemes rotate.simps append.simps)

lemma lemma_ae [thy_expl]: "rotate (S Z) (rotate x2 y2) = rotate (S x2) y2"
by (hipster_induct_schemes rotate.simps append.simps)

lemma unknown [thy_expl]: "rotate x (rotate y z) = rotate y (rotate x z)"
apply(induction y z arbitrary: x rule: rotate.induct)
apply(simp_all)
apply(metis thy_expl rotate.simps append.simps Nat.exhaust list.exhaust)
by (metis (no_types) lemma_ae Nat.exhaust rotate.simps append.simps list.exhaust) (* NO TYPES! hide_lams? *)

lemma unknown' [thy_expl]: "rotate (S x) (rotate y z) = rotate (S y) (rotate x z)"
by (hipster_induct_schemes rotate.simps append.simps list.exhaust Nat.exhaust)

end


section \<open>Abstract syntax for Logic\<close>

theory Syntax_SL
  imports
    Main HOL.Real
    Ordinary_Differential_Equations.ODE_Analysis
begin

text \<open>Expressions of HCSP language. \<close>
datatype 'a exp = Real real ("Real _" [75] 75)
             | RVar 'a   ("RVar _" [75] 75)
             | DVar 'a ("DVar _" [75] 75)
             | Add "'a exp" "'a exp"   (infixl "[+]" 70)
             | Sub "'a exp" "'a exp"   (infixl "[-]" 70)
             | Mul "'a exp" "'a exp"   (infixl "[*]" 71)
             | Diff "'a exp"  ("Diff _" [73] 73)

text \<open>States\<close>
type_synonym 'a eval = "real^('a :: finite)"
type_synonym 'a state = "'a eval"
text \<open>A pair of states for recording variables and differential variables\<close>
type_synonym 'a pair_state = "'a state \<times> 'a state"

definition Vagree :: "('a :: finite) pair_state \<Rightarrow> 'a pair_state \<Rightarrow> 'a set \<Rightarrow> bool"
  where "Vagree u v V ==
     (\<forall> i. i \<in> V \<longrightarrow> fst u $ i = fst v $ i \<and> snd u $ i = snd v $ i)"

lemma Vagree_eq: "Vagree \<nu> \<omega> UNIV \<Longrightarrow> \<nu> = \<omega>"
  unfolding Vagree_def
  by (simp add: vec_eq_iff prod.expand)

text \<open>Differential-free expressions\<close>
primrec DE_free :: "('a :: finite) exp \<Rightarrow> bool"
  where
  "DE_free (Real y)  = True"
| "DE_free (RVar (x))  = True"
| "DE_free (DVar (x))  = False"
| "DE_free (e1 [+] e2)  = (DE_free e1  \<and> DE_free e2)"
| "DE_free (e1 [-] e2)  = (DE_free e1  \<and> DE_free e2)"
| "DE_free (e1 [*] e2)  = (DE_free e1  \<and> DE_free e2)"
| "DE_free (Diff e)  = False"

text \<open>Evaluation of differential-free expressions\<close>
primrec evalE_df :: "('a :: finite) exp \<Rightarrow> 'a state \<Rightarrow> real"
  where
  "evalE_df (Real y) f = y"
| "evalE_df (RVar (x)) f = f $ x"
| "evalE_df (DVar (x)) f = undefined"
| "evalE_df (e1 [+] e2) f = (evalE_df e1 f + evalE_df e2 f)"
| "evalE_df (e1 [-] e2) f = (evalE_df e1 f - evalE_df e2 f)"
| "evalE_df (e1 [*] e2) f = (evalE_df e1 f * evalE_df e2 f)"
| "evalE_df (Diff e) f = undefined"

primrec frechet :: "'a :: finite exp \<Rightarrow> 'a state => 'a state => real"
  where
  "frechet (Real y) v = (\<lambda> v'. 0)"
| "frechet (RVar x) v = (\<lambda> v'. v' \<bullet> axis x 1)"
| "frechet (DVar x) v = undefined"
| "frechet (e1 [+] e2) v = (\<lambda> v' . frechet e1 v v' + frechet e2 v v')"
| "frechet (e1 [-] e2) v = (\<lambda> v' . frechet e1 v v' - frechet e2 v v')"
| "frechet (e1 [*] e2) v = (\<lambda> v' . (evalE_df e1 v * frechet e2 v v' + frechet e1 v v' * evalE_df e2 v))"
| "frechet (Diff e) v = undefined"

text \<open>Evaluation of all expressions\<close>
primrec evalE :: "'a :: finite exp \<Rightarrow> 'a pair_state \<Rightarrow> real" where
  "evalE (Real y) f = y"
| "evalE (RVar (x)) f = (fst f) $ x"
| "evalE (DVar (x)) f = (snd f) $ x"
| "evalE (e1 [+] e2) f = (evalE e1 f + evalE e2 f)"
| "evalE (e1 [-] e2) f = (evalE e1 f - evalE e2 f)"
| "evalE (e1 [*] e2) f = (evalE e1 f * evalE e2 f)"
| "evalE (Diff e) f = (frechet e (fst f) (snd f))"

lemma DE_free_evalE:
 "DE_free e \<Longrightarrow> evalE e f = evalE_df e (fst f)"
  by (induct e, auto)

subsection \<open>FOL operators\<close>

type_synonym 'a fform = "'a pair_state \<Rightarrow> bool"

definition fTrue :: "'a fform" where "fTrue \<equiv> \<lambda>s. True"
definition fFalse :: "'a fform" where "fFalse \<equiv> \<lambda>s. False"

definition fEqual :: "'a :: finite exp \<Rightarrow> 'a exp \<Rightarrow> 'a fform"  (infixl "[=]" 50) where
  "e [=] f \<equiv> \<lambda>s. evalE e s = evalE f s"

definition fLess :: "'a :: finite exp \<Rightarrow> 'a exp \<Rightarrow> 'a fform"  ("(_/ [<] _)"  [51, 51] 50) where
  "e [<] f \<equiv> \<lambda>s. (evalE e s < evalE f s)"

definition fAnd :: "'a fform \<Rightarrow> 'a fform \<Rightarrow> 'a fform"  (infixr "[&]" 35) where
  "P [&] Q \<equiv> \<lambda>s. P s \<and> Q s"

definition fOr :: "'a fform \<Rightarrow> 'a fform \<Rightarrow> 'a fform"  (infixr "[|]" 30) where
  "P [|] Q \<equiv> \<lambda>s. P s \<or> Q s"

definition fNot :: "'a fform \<Rightarrow> 'a fform"  ("[\<not>]_" [40] 40) where
  "[\<not>]P \<equiv> \<lambda>s. \<not> P s"

definition fImp :: "'a fform \<Rightarrow> 'a fform \<Rightarrow> 'a fform"  (infixr "[\<longrightarrow>]" 25) where
  "P [\<longrightarrow>] Q \<equiv> \<lambda>s. P s \<longrightarrow> Q s"

definition fLessEqual :: "'a :: finite exp \<Rightarrow> 'a exp \<Rightarrow> 'a fform"  ("(_/ [\<le>] _)"  [51, 51] 50) where
  "e [\<le>] f \<equiv> (e [=] f) [|] (e [<] f)"

definition fGreaterEqual :: "'a :: finite exp \<Rightarrow> 'a exp \<Rightarrow> 'a fform"   ("(_/ [\<ge>] _)"  [51, 51] 50) where
  "e [\<ge>] f \<equiv> \<lambda>s. ((evalE e s \<ge> evalE f s))"

definition fGreater :: "'a :: finite exp \<Rightarrow> 'a exp \<Rightarrow> 'a fform"   ("(_/ [>] _)"  [51, 51] 50) where
  "e [>] f == [\<not>](e [\<le>] f)"

text \<open>Evaluate on state after assigning value of expression e to RVar a.\<close>
definition fSubForm :: "'a :: finite fform \<Rightarrow> 'a exp \<Rightarrow> 'a \<Rightarrow> 'a fform" ("_\<lbrakk>_,_\<rbrakk>" [71,71] 70) where
  "P \<lbrakk>e, a\<rbrakk> \<equiv> (\<lambda>s. P (\<chi> x. if x = a then evalE e s else (fst s) $ x, snd s))"

text \<open>Evaluate on state after assigning value of expression e to DVar a.\<close>
definition fSubFormD :: "'a :: finite fform \<Rightarrow> 'a exp \<Rightarrow> 'a \<Rightarrow> 'a fform" ("_\<lbrakk>_,_\<rbrakk>\<^sub>D" [71,71] 70) where
  "P \<lbrakk>e, a\<rbrakk>\<^sub>D \<equiv> (\<lambda>s. P (fst s, \<chi> x. if x = a then evalE e s else (snd s) $ x))"

text \<open>The @{term close} operation extends the formula with the boundary,
  used for continuous evolution.\<close>
axiomatization close :: "'a :: finite fform \<Rightarrow> 'a fform" where
  Lessc[simp]: "close (e [<] f) = (e [\<le>] f)" and
  Greatc[simp]: "close (e [>] f) = (e [\<ge>] f)" and
  Equalc[simp]: "close (e [=] f) = (e [=] f)" and
  LessEqual[simp]: "close (e [\<le>] f) = (e [\<le>] f)" and
  GreatEqual[simp] : "close (e [\<ge>] f) = (e [\<ge>] f)" and
  Andc[simp]: "close (P [&] Q) = (close (P) [&] close (Q))" and
  Orc[simp]: "close (P [|] Q) = (close (P) [|] close (Q))" and
  notLessc[simp]: "close ([\<not>] e [<] f) = (e [\<ge>] f)"

declare fTrue_def [simp]
declare fFalse_def [simp]

text \<open>Types for defining HCSP\<close>
type_synonym cname = string
type_synonym time = real
type_synonym var = string

text \<open>Communication processes of HCSP\<close>
datatype 'a comm =
  Send cname "'a exp"   ("_[!]_" [110,108] 100)
| Receive cname 'a      ("_[?]_" [110,108] 100)

datatype 'a ODE =
  ODEOne 'a "'a exp"  ("odeone _ _" [110,108] 100)
| ODEPar "'a ODE" "'a ODE"  ("odes _, _" [100,100] 90)

fun ODE_vars :: "'a ODE \<Rightarrow> 'a set" where
  "ODE_vars (odeone x e) = { x }"
| "ODE_vars (odes ode1, ode2) = ODE_vars ode1 \<union> ODE_vars ode2"

fun wf_ODE :: "'a ODE \<Rightarrow> bool" where
  "wf_ODE (odeone x e) = True"
| "wf_ODE (odes ode1, ode2) = (ODE_vars ode1 \<inter> ODE_vars ode2 = {})"

text \<open>HCSP processes\<close>
datatype 'a proc =
  Cm "'a comm"
| Skip
| Ass 'a "'a exp"             ("_ := _" [99,95] 94)
| DAss 'a "'a exp"
| Seq "'a proc" "'a proc"           ("_; _" [91,90] 90)
| Cond "'a fform" "'a proc"         ("IF _ _" [95,94] 93)
(*| Pref comm proc          ("_\<rightarrow>_" [95,94] 93)*)
| IChoice "'a proc" "'a proc"          (infixr "\<sqinter>" 90)
| EChoice "'a comm" "'a proc" "'a comm" "'a proc"          ("_ \<rightarrow> _ [] _ \<rightarrow> _" [92,91,92,91] 90)
\<comment> \<open>Repetition is annotated with invariant\<close>
| Rep "'a proc" "'a fform"          ("_*&&_" [91] 90)
| RepN "'a proc" nat           ("_* NUM _" [91, 90] 90)
\<comment> \<open>Continuous evolution is annotated with invariant.\<close>
| Cont "'a ODE" "'a fform" "'a fform"  ("<_&&_&_>" [95,95,96] 94)
| Interr "'a proc" "'a comm" "'a proc"       ("_[]_\<rightarrow>_" [95,94,94] 94)

text \<open>We assume parallel composition only occurs in the topmost level.\<close>
datatype 'a procP = Par "'a proc" "'a proc"  (infixr "||" 89)

end


(*
Author:  Jérémy Dubut (2019-2021)
Author:  Akihisa Yamada (2019-2021)
License: LGPL (see file COPYING.LESSER)
*)

theory Fixed_Points
  imports Complete_Relations
begin

section \<open>Existence of Fixed Points in Complete Related Sets\<close>
text \<open>\label{sec:qfp-exists}\<close>

text \<open>The following proof is simplified and generalized from
  Stouti--Maaden \cite{SM13}. We construct some set whose extreme bounds
  -- if they exist, typically when the underlying related set is complete --
  are fixed points of a monotone or inflationary function on any
  related set. When the related set is attractive, those are actually the least fixed points.
  This generalizes \cite{SM13}, relaxing reflexivity and antisymmetry.\<close>

locale fixed_point_proof = related_set +
  fixes f
  assumes f: "f ` A \<subseteq> A"
begin

sublocale less_eq_notations.

definition AA where "AA \<equiv>
  {X. X \<subseteq> A \<and> f ` X \<subseteq> X \<and> (\<forall>Y s. Y \<subseteq> X \<longrightarrow> extreme_bound A (\<sqsubseteq>) Y s \<longrightarrow> s \<in> X)}"

lemma AA_I:
  "X \<subseteq> A \<Longrightarrow> f ` X \<subseteq> X \<Longrightarrow> (\<And>Y s. Y \<subseteq> X \<Longrightarrow> extreme_bound A (\<sqsubseteq>) Y s \<Longrightarrow> s \<in> X) \<Longrightarrow> X \<in> AA"
  by (unfold AA_def, safe)

lemma AA_E:
  "X \<in> AA \<Longrightarrow>
   (X \<subseteq> A \<Longrightarrow> f ` X \<subseteq> X \<Longrightarrow> (\<And>Y s. Y \<subseteq> X \<Longrightarrow> extreme_bound A (\<sqsubseteq>) Y s \<Longrightarrow> s \<in> X) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  by (auto simp: AA_def)

definition C where "C \<equiv> \<Inter> AA"

lemma A_AA: "A \<in> AA" by (auto intro!:AA_I f)

lemma C_AA: "C \<in> AA"
proof (intro AA_I)
  show "C \<subseteq> A" using C_def A_AA f by auto
  show "f ` C \<subseteq> C" unfolding C_def AA_def by auto
  fix B b assume B: "B \<subseteq> C" "extreme_bound A (\<sqsubseteq>) B b"
  { fix X assume X: "X \<in> AA"
    with B have "B \<subseteq> X" by (auto simp: C_def)
    with X B have "b\<in>X" by (auto elim!: AA_E)
  }
  then show "b \<in> C" by (auto simp: C_def AA_def)
qed

lemma CA: "C \<subseteq> A" using A_AA by (auto simp: C_def)

lemma fC: "f ` C \<subseteq> C" using C_AA by (auto elim!: AA_E)

context
  fixes c assumes Cc: "extreme_bound A (\<sqsubseteq>) C c"
begin

private lemma cA: "c \<in> A" using Cc by auto
private lemma cC: "c \<in> C" using Cc C_AA by (blast elim!:AA_E)
private lemma fcC: "f c \<in> C" using cC AA_def C_AA by auto
private lemma fcA: "f c \<in> A" using fcC CA by auto

lemma qfp_as_extreme_bound:
  assumes infl_mono: "\<forall>x \<in> A. x \<sqsubseteq> f x \<or> (\<forall>y \<in> A. y \<sqsubseteq> x \<longrightarrow> f y \<sqsubseteq> f x)"
  shows "f c \<sim> c"
proof (intro conjI bexI sympartpI)
  show "f c \<sqsubseteq> c" using fcC Cc by auto
  from infl_mono[rule_format, OF cA]
  show "c \<sqsubseteq> f c"
  proof (safe)
    text \<open>Monotone case:\<close>
    assume mono: "\<forall>b\<in>A. b \<sqsubseteq> c \<longrightarrow> f b \<sqsubseteq> f c"
    define D where "D \<equiv> {x \<in> C. x \<sqsubseteq> f c}"
    have "D \<in> AA"
    proof (intro AA_I)
      show "D \<subseteq> A" unfolding D_def C_def using A_AA f by auto
      have fxC: "x \<in> C \<Longrightarrow> x \<sqsubseteq> f c \<Longrightarrow> f x \<in> C" for x using C_AA by (auto simp: AA_def)
      show "f ` D \<subseteq> D"
      proof (unfold D_def, safe intro!: fxC)
        fix x assume xC: "x \<in> C"
        have "x \<sqsubseteq> c" "x \<in> A" using Cc xC CA by auto
        then show "f x \<sqsubseteq> f c" using mono by (auto dest:monotoneD)
      qed
      have DC: "D \<subseteq> C" unfolding D_def by auto
      fix B b assume BD: "B \<subseteq> D" and Bb: "extreme_bound A (\<sqsubseteq>) B b"
      have "B \<subseteq> C" using DC BD by auto
      then have bC: "b \<in> C" using C_AA Bb BD by (auto elim!: AA_E)
      have bfc: "\<forall>a\<in>B. a \<sqsubseteq> f c" using BD unfolding D_def by auto
      with f cA Bb
      have "b \<sqsubseteq> f c" by (auto simp: extreme_def image_subset_iff)
      with bC show "b \<in> D" unfolding D_def by auto
    qed
    then have "C \<subseteq> D" unfolding C_def by auto
    then show "c \<sqsubseteq> f c" using cC unfolding D_def by auto
  qed
qed

lemma extreme_qfp:
  assumes attract: "\<forall>q \<in> A. \<forall>x \<in> A. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
    and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "extreme {q \<in> A. f q \<sim> q \<or> f q = q} (\<sqsupseteq>) c"
proof-
  have fcc: "f c \<sim> c"
    apply (rule qfp_as_extreme_bound)
    using mono by (auto elim!: monotone_onE)
  define L where [simp]: "L \<equiv> {a \<in> A. \<forall>s \<in> A. (f s \<sim> s \<or> f s = s) \<longrightarrow> a \<sqsubseteq> s}"
  have "L \<in> AA"
  proof (unfold AA_def, intro CollectI conjI allI impI)
    show XA: "L \<subseteq> A" by auto
    show "f ` L \<subseteq> L"
    proof safe
      fix x assume xL: "x \<in> L"
      show "f x \<in> L"
      proof (unfold L_def, safe)
        have xA: "x \<in> A" using xL by auto
        then show fxA: "f x \<in> A" using f by auto
        { fix s assume sA: "s \<in> A" and sf: "f s \<sim> s \<or> f s = s"
          then have "x \<sqsubseteq> s" using xL sA sf by auto
          then have "f x \<sqsubseteq> f s" using mono fxA sA xA by (auto elim!:monotone_onE)}
        note fxfs = this
        { fix s assume sA: "s \<in> A" and sf: "f s \<sim> s"
          then show "f x \<sqsubseteq> s" using fxfs attract mono sf fxA sA xA by (auto elim!:monotone_onE)
        }
        { fix s assume sA: "s \<in> A" and sf: "f s = s"
          with fxfs[OF sA] show "f x \<sqsubseteq> s" by simp}
      qed
    qed
    fix B b assume BL: "B \<subseteq> L" and b: "extreme_bound A (\<sqsubseteq>) B b"
    then have BA: "B \<subseteq> A" by auto
    with BL b have bA: "b \<in> A" by auto
    show "b \<in> L"
    proof (unfold L_def, safe intro!: bA)
      { fix s assume sA: "s \<in> A" and sf: "f s \<sim> s \<or> f s = s"
        have "bound B (\<sqsubseteq>) s" using sA BL b sf by auto
      }
      note Bs = this
      { fix s assume sA: "s \<in> A" and sf: "f s \<sim> s"
        with b sA Bs show "b \<sqsubseteq> s" by auto
      }
      { fix s assume sA: "s \<in> A" and sf: "f s = s"
        with b sA Bs show "b \<sqsubseteq> s" by auto
      }
    qed
  qed
  then have "C \<subseteq> L" by (simp add: C_def Inf_lower)
  with cC have "c \<in> L" by auto
  with L_def fcc
  show ?thesis by auto
qed

end

lemma ex_qfp:
  assumes comp: "CC-complete A (\<sqsubseteq>)" and C: "C \<in> CC"
    and infl_mono: "\<forall>a \<in> A. a \<sqsubseteq> f a \<or> (\<forall>b \<in> A. b \<sqsubseteq> a \<longrightarrow> f b \<sqsubseteq> f a)"
  shows "\<exists>s \<in> A. f s \<sim> s"
  using qfp_as_extreme_bound[OF _  infl_mono] completeD[OF comp CA C] by auto

lemma ex_extreme_qfp_fp:
  assumes comp: "CC-complete A (\<sqsubseteq>)" and C: "C \<in> CC"
    and attract: "\<forall>q \<in> A. \<forall>x \<in> A. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
    and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "\<exists>c. extreme {q \<in> A. f q \<sim> q \<or> f q = q} (\<sqsupseteq>) c"
  using extreme_qfp[OF _ attract mono] completeD[OF comp CA C] by auto

lemma ex_extreme_qfp:
  assumes comp: "CC-complete A (\<sqsubseteq>)" and C: "C \<in> CC"
    and attract: "\<forall>q \<in> A. \<forall>x \<in> A. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
    and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "\<exists>c. extreme {q \<in> A. f q \<sim> q} (\<sqsupseteq>) c"
proof-
  from completeD[OF comp CA C]
  obtain c where Cc: "extreme_bound A (\<sqsubseteq>) C c" by auto
  from extreme_qfp[OF Cc attract mono]
  have Qc: "bound {q \<in> A. f q \<sim> q} (\<sqsupseteq>) c" by auto
  have fcc: "f c \<sim> c"
    apply (rule qfp_as_extreme_bound[OF Cc])
    using mono by (auto simp: monotone_onD)
  from Cc CA have cA: "c \<in> A" by auto
  from Qc fcc cA show ?thesis by (auto intro!: exI[of _ c])
qed

end

context
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) and A :: "'a set" and f
  assumes f: "f ` A \<subseteq> A"
begin

interpretation less_eq_notations.
interpretation fixed_point_proof A "(\<sqsubseteq>)" f using f by unfold_locales

theorem complete_infl_mono_imp_ex_qfp:
  assumes comp: "UNIV-complete A (\<sqsubseteq>)" and infl_mono: "\<forall>a\<in>A. a \<sqsubseteq> f a \<or> (\<forall>b\<in>A. b \<sqsubseteq> a \<longrightarrow> f b \<sqsubseteq> f a)"
  shows "\<exists>s\<in>A. f s \<sim> s"
  apply (rule ex_qfp[OF comp _ infl_mono]) by auto

end

corollary (in antisymmetric) complete_infl_mono_imp_ex_fp:
  assumes comp: "UNIV-complete A (\<sqsubseteq>)" and f: "f ` A \<subseteq> A"
    and infl_mono: "\<forall>a\<in>A. a \<sqsubseteq> f a \<or> (\<forall>b\<in>A. b \<sqsubseteq> a \<longrightarrow> f b \<sqsubseteq> f a)"
  shows "\<exists>s \<in> A. f s = s"
proof-
  interpret less_eq_notations.
  from complete_infl_mono_imp_ex_qfp[OF f comp infl_mono]
  obtain s where sA: "s \<in> A" and fss: "f s \<sim> s" by auto
  from f sA have fsA: "f s \<in> A" by auto
  have "f s = s" using antisym fsA sA fss by auto
  with sA show ?thesis by auto
qed

context semiattractive begin

interpretation less_eq_notations.

theorem complete_mono_imp_ex_extreme_qfp:
  assumes comp: "UNIV-complete A (\<sqsubseteq>)" and f: "f ` A \<subseteq> A"
    and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "\<exists>s. extreme {p \<in> A. f p \<sim> p} (\<sqsubseteq>) s"
proof-
  interpret dual: fixed_point_proof A "(\<sqsupseteq>)" rewrites "dual.sym = (\<sim>)"
    using f by unfold_locales (auto intro!:ext)
  show ?thesis
    apply (rule dual.ex_extreme_qfp[OF complete_dual[OF comp] _ _ monotone_on_dual[OF mono]])
    apply simp
    using f sym_order_trans by blast
qed

end

corollary (in antisymmetric) complete_mono_imp_ex_extreme_fp:
  assumes comp: "UNIV-complete A (\<sqsubseteq>)" and f: "f ` A \<subseteq> A"
    and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "\<exists>s. extreme {s \<in> A. f s = s} (\<sqsubseteq>)\<^sup>- s"
proof-
  interpret less_eq_notations.
  interpret fixed_point_proof A "(\<sqsubseteq>)" f using f by unfold_locales
  have "\<exists>c. extreme {q \<in> A. f q \<sim> q \<or> f q = q} (\<sqsupseteq>) c"
    apply (rule ex_extreme_qfp_fp[OF comp _ _ mono])
    using antisym f by (auto dest: order_sym_trans)
  then obtain c where c: "extreme {q \<in> A. f q \<sim> q \<or> f q = q} (\<sqsupseteq>) c" by auto
  then have "f c = c" using antisym f by blast
  with c have "extreme {q \<in> A. f q = q} (\<sqsupseteq>) c" by auto
  then show ?thesis by auto
qed

section \<open>Fixed Points in Well-Complete Antisymmetric Sets\<close>
text \<open>\label{sec:well-complete}\<close>

text \<open>In this section, we prove that an
inflationary or monotone map over a well-complete antisymmetric set
has a fixed point.

In order to formalize such a theorem in Isabelle,
we followed Grall's~\cite{grall10} elementary proof for Bourbaki--Witt and Markowsky's theorems.
His idea is to consider well-founded derivation trees over $A$,
where from a set $C \subseteq A$ of premises
one can derive $f\:(\bigsqcup C)$ if $C$ is a chain.
The main observation is as follows:
Let $D$ be the set of all the derivable elements; that is,
for each $d \in D$ there exists a well-founded derivation
whose root is $d$.
It is shown that $D$ is a chain,
and hence one can build a derivation yielding $f\:(\bigsqcup D)$,
and $f\:(\bigsqcup D)$ is shown to be a fixed point.\<close>

lemma bound_monotone_on:
  assumes mono: "monotone_on A r s f" and XA: "X \<subseteq> A" and aA: "a \<in> A" and rXa: "bound X r a"
  shows "bound (f`X) s (f a)"
proof (safe)
  fix x assume xX: "x \<in> X"
  from rXa xX have "r x a" by auto
  with xX XA mono aA show "s (f x) (f a)" by (auto elim!:monotone_onE)
qed

context fixed_point_proof begin

text \<open>To avoid the usage of the axiom of choice, we carefully define derivations so that any derivable element
determines its lower set. This led to the following definition:\<close>

definition "derivation X \<equiv> X \<subseteq> A \<and> well_ordered_set X (\<sqsubseteq>) \<and>
  (\<forall>x \<in> X. let Y = {y \<in> X. y \<sqsubset> x} in
    (\<exists>y. extreme Y (\<sqsubseteq>) y \<and> x = f y) \<or>
    f ` Y \<subseteq> Y \<and> extreme_bound A (\<sqsubseteq>) Y x)"

lemma assumes "derivation P"
  shows derivation_A: "P \<subseteq> A" and derivation_well_ordered: "well_ordered_set P (\<sqsubseteq>)"
  using assms by (auto simp: derivation_def)

lemma derivation_cases[consumes 2, case_names suc lim]:
  assumes "derivation X" and "x \<in> X"
    and "\<And>Y y. Y = {y \<in> X. y \<sqsubset> x} \<Longrightarrow> extreme Y (\<sqsubseteq>) y \<Longrightarrow> x = f y \<Longrightarrow> thesis"
    and "\<And>Y. Y = {y \<in> X. y \<sqsubset> x} \<Longrightarrow> f ` Y \<subseteq> Y \<Longrightarrow> extreme_bound A (\<sqsubseteq>) Y x \<Longrightarrow> thesis"
  shows thesis
  using assms unfolding derivation_def Let_def by auto

definition "derivable x \<equiv> \<exists>X. derivation X \<and> x \<in> X"

lemma derivableI[intro?]: "derivation X \<Longrightarrow> x \<in> X \<Longrightarrow> derivable x" by (auto simp: derivable_def)
lemma derivableE: "derivable x \<Longrightarrow> (\<And>P. derivation P \<Longrightarrow> x \<in> P \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  by (auto simp: derivable_def)

lemma derivable_A: "derivable x \<Longrightarrow> x \<in> A" by (auto elim: derivableE dest:derivation_A)

lemma UN_derivations_eq_derivable: "(\<Union>{P. derivation P}) = {x. derivable x}"
  by (auto simp: derivable_def)

context
  assumes ord: "antisymmetric A (\<sqsubseteq>)"
begin

interpretation antisymmetric using ord.

lemma derivation_lim:
  assumes P: "derivation P" and fP: "f ` P \<subseteq> P" and Pp: "extreme_bound A (\<sqsubseteq>) P p"
  shows "derivation (P \<union> {p})"
proof (cases "p \<in> P")
  case True
  with P show ?thesis by (auto simp: insert_absorb)
next
  case pP: False
  interpret P: well_ordered_set P "(\<sqsubseteq>)" using derivation_well_ordered[OF P].
  have PA: "P \<subseteq> A" using derivation_A[OF P].
  from Pp have pA: "p \<in> A" by auto
  have bp: "bound P (\<sqsubseteq>) p" using Pp by auto
  then have pp: "p \<sqsubseteq> p" using Pp by auto
  have 1: "y \<in> P \<longrightarrow> {x. (x = p \<or> x \<in> P) \<and> x \<sqsubset> y} = {x \<in> P. x \<sqsubset> y}" for y
    using Pp by (auto dest:extreme_bound_bound)
  { fix x assume xP: "x \<in> P" and px: "p \<sqsubseteq> x"
    from xP Pp have "x \<sqsubseteq> p" by auto
    with px have "p = x" using xP PA pA by (auto intro!: antisym)
    with xP pP
    have "False" by auto
  }
  note 2 = this
  then have 3: "{x. (x = p \<or> x \<in> P) \<and> x \<sqsubset> p} = P" using Pp by (auto intro!: asympartpI)
  have wr: "well_ordered_set (P \<union> {p}) (\<sqsubseteq>)"
    apply (rule well_order_extend[OF P.well_ordered_set_axioms])
    using pp bp pP 2 by auto
  from P fP Pp
  show "derivation (P \<union> {p})" by (auto simp: derivation_def pA wr[simplified] 1 3)
qed

context
  assumes derivation_infl: "\<forall>X x y. derivation X \<longrightarrow> x \<in> X \<longrightarrow> y \<in> X \<longrightarrow> x \<sqsubseteq> y \<longrightarrow> x \<sqsubseteq> f y"
    and derivation_f_refl: "\<forall>X x. derivation X \<longrightarrow> x \<in> X \<longrightarrow> f x \<sqsubseteq> f x"
begin

lemma derivation_suc:
  assumes P: "derivation P" and Pp: "extreme P (\<sqsubseteq>) p" shows "derivation (P \<union> {f p})"
proof (cases "f p \<in> P")
  case True
  with P show ?thesis by (auto simp: insert_absorb)
next
  case fpP: False
  interpret P: well_ordered_set P "(\<sqsubseteq>)" using derivation_well_ordered[OF P].
  have PA: "P \<subseteq> A" using derivation_A[OF P].
  with Pp have pP: "p \<in> P" and pA: "p \<in> A" by auto
  with f have fpA: "f p \<in> A" by auto
  from pP have pp: "p \<sqsubseteq> p" by auto
  from derivation_infl[rule_format, OF P pP pP pp] have "p \<sqsubseteq> f p".
  { fix x assume xP: "x \<in> P"
    then have xA: "x \<in> A" using PA by auto
    have xp: "x \<sqsubseteq> p" using xP Pp by auto
    from derivation_infl[rule_format, OF P xP pP this]
    have "x \<sqsubseteq> f p".
  }
  note Pfp = this
  then have bfp: "bound P (\<sqsubseteq>) (f p)" by auto
  { fix y assume yP: "y \<in> P"
    note yfp = Pfp[OF yP]
    { assume fpy: "f p \<sqsubseteq> y"
      with yfp have "f p = y" using yP PA pA fpA antisym by auto
      with yP fpP have "False" by auto
    }
    with Pfp yP have "y \<sqsubset> f p" by auto
  }
  note Pfp = this
  have 1: "\<And>y. y \<in> P \<longrightarrow> {x. (x = f p \<or> x \<in> P) \<and> x \<sqsubset> y} = {x \<in> P. x \<sqsubset> y}"
   and 2: "{x. (x = f p \<or> x \<in> P) \<and> x \<sqsubset> f p} = P" using Pfp by auto
  have wr: "well_ordered_set (P \<union> {f p}) (\<sqsubseteq>)"
    apply (rule well_order_extend[OF P.well_ordered_set_axioms singleton_well_ordered])
    using Pfp derivation_f_refl[rule_format, OF P pP] by auto
  from P Pp
  show "derivation (P \<union> {f p})" by (auto simp: derivation_def wr[simplified] 1 2 fpA)
qed

lemma derivable_closed:
  assumes x: "derivable x" shows "derivable (f x)"
proof (insert x, elim derivableE)
  fix P
  assume P: "derivation P" and xP: "x \<in> P"
  note PA = derivation_A[OF P]
  then have xA: "x \<in> A" using xP by auto
  interpret P: well_ordered_set P "(\<sqsubseteq>)" using derivation_well_ordered[OF P].
  interpret P.asympartp: transitive P "(\<sqsubset>)" using P.asympartp_transitive.
  define Px where "Px \<equiv> {y. y \<in> P \<and> y \<sqsubset> x} \<union> {x}"
  then have PxP: "Px \<subseteq> P" using xP by auto
  have "x \<sqsubseteq> x" using xP by auto
  then have Pxx: "extreme Px (\<sqsubseteq>) x" using xP PA by (auto simp: Px_def)
  have wr: "well_ordered_set Px (\<sqsubseteq>)" using P.well_ordered_subset[OF PxP].
  { fix z y assume zPx: "z \<in> Px" and yP: "y \<in> P" and yz: "y \<sqsubset> z"
    then have zP: "z \<in> P" using PxP by auto
    have "y \<sqsubset> x"
    proof (cases "z = x")
      case True
      then show ?thesis using yz by auto
    next
      case False
      then have zx: "z \<sqsubset> x" using zPx by (auto simp: Px_def)
      from P.asympartp.trans[OF yz zx yP zP xP] show ?thesis.
    qed
  }
  then have 1: "\<And>z. z \<in> Px \<longrightarrow> {y \<in> Px. y \<sqsubset> z} = {y \<in> P. y \<sqsubset> z}" using Px_def by blast
  have Px: "derivation Px" using PxP PA P by (auto simp: wr derivation_def 1)
  from derivation_suc[OF Px Pxx]
  show ?thesis by (auto intro!: derivableI)
qed

text \<open>The following lemma is derived from Grall’s proof. We simplify the claim so that we
consider two elements from one derivation, instead of two derivations.\<close>

lemma derivation_useful:
  assumes X: "derivation X" and xX: "x \<in> X" and yX: "y \<in> X" and xy: "x \<sqsubset> y"
  shows "f x \<sqsubseteq> y"
proof-
  interpret X: well_ordered_set X "(\<sqsubseteq>)" using derivation_well_ordered[OF X].
  note XA = derivation_A[OF X]
  { fix x y assume xX: "x \<in> X" and yX: "y \<in> X"
    from xX yX have "(x \<sqsubset> y \<longrightarrow> f x \<sqsubseteq> y \<and> f x \<in> X) \<and> (y \<sqsubset> x \<longrightarrow> f y \<sqsubseteq> x \<and> f y \<in> X)"
    proof (induct x arbitrary: y)
      case (less x)
      note xX = \<open>x \<in> X\<close> and IHx = this(2)
      with XA have xA: "x \<in> A" by auto
      from \<open>y \<in> X\<close> show ?case
      proof (induct y)
        case (less y)
        note yX = \<open>y \<in> X\<close> and IHy = this(2)
        with XA have yA: "y \<in> A" by auto
        show ?case
        proof (rule conjI; intro impI)
          assume xy: "x \<sqsubset> y"
          from X yX
          show "f x \<sqsubseteq> y \<and> f x \<in> X"
          proof (cases rule:derivation_cases)
            case (suc Z z)
            with XA have zX: "z \<in> X" and zA: "z \<in> A" and zy: "z \<sqsubset> y" and yfz: "y = f z" by auto
            from xX zX show ?thesis
            proof (cases rule: X.comparable_three_cases)
              case xz: less
              with IHy[OF zX zy] have fxz: "f x \<sqsubseteq> z" and fxX: "f x \<in> X" by auto
              from derivation_infl[rule_format, OF X fxX zX fxz] have "f x \<sqsubseteq> y" by (auto simp: yfz)
              with fxX show ?thesis by auto
            next
              case eq
              with xX zX have "x = z" by auto
              with yX yfz show ?thesis by auto
            next
              case zx: greater
              with IHy[OF zX zy] yfz xy have False by auto
              then show ?thesis by auto
            qed
          next
            case (lim Z)
            note Z = \<open>Z = {z \<in> X. z \<sqsubset> y}\<close> and fZ = \<open>f ` Z \<subseteq> Z\<close>
            from xX xy have "x \<in> Z" by (auto simp: Z)
            with fZ have "f x \<in> Z" by auto
            then have "f x \<sqsubset> y" and "f x \<in> X" by (auto simp: Z)
            then show ?thesis by auto
          qed
        next
          assume yx: "y \<sqsubset> x"
          from X xX
          show "f y \<sqsubseteq> x \<and> f y \<in> X"
          proof (cases rule:derivation_cases)
            case (suc Z z)
            with XA have zX: "z \<in> X" and zA: "z \<in> A" and zx: "z \<sqsubset> x" and xfz: "x = f z" by auto
            from yX zX show ?thesis
            proof (cases rule: X.comparable_three_cases)
              case yz: less
              with IHx[OF zX zx yX] have fyz: "f y \<sqsubseteq> z" and fyX: "f y \<in> X" by auto
              from derivation_infl[rule_format, OF X fyX zX fyz] have "f y \<sqsubseteq> x" by (auto simp: xfz)
              with fyX show ?thesis by auto
            next
              case eq
              with yX zX have "y = z" by auto
              with xX xfz show ?thesis by auto
            next
              case greater
              with IHx[OF zX zx yX] xfz yx have False by auto
              then show ?thesis by auto
            qed
          next
            case (lim Z)
            note Z = \<open>Z = {z \<in> X. z \<sqsubset> x}\<close> and fZ = \<open>f ` Z \<subseteq> Z\<close>
            from yX yx have "y \<in> Z" by (auto simp: Z)
            with fZ have "f y \<in> Z" by auto
            then have "f y \<sqsubset> x" and "f y \<in> X" by (auto simp: Z)
            then show ?thesis by auto
          qed
        qed
      qed
    qed
  }
  with assms show "f x \<sqsubseteq> y" by auto
qed

text \<open>Next one is the main lemma of this section, stating that elements from two possibly different
derivations are comparable, and moreover the lower one is in the derivation of the upper one.
The latter claim, not found in Grall’s proof, is crucial in proving that the union of all
derivations is well-related.\<close>

lemma derivations_cross_compare:
  assumes X: "derivation X" and Y: "derivation Y" and xX: "x \<in> X" and yY: "y \<in> Y"
  shows "(x \<sqsubset> y \<and> x \<in> Y) \<or> x = y \<or> (y \<sqsubset> x \<and> y \<in> X)"
proof-
  { fix X Y x y
    assume X: "derivation X" and Y: "derivation Y" and xX: "x \<in> X" and yY: "y \<in> Y"
    interpret X: well_ordered_set X "(\<sqsubseteq>)" using derivation_well_ordered[OF X].
    interpret X.asympartp: transitive X "(\<sqsubset>)" using X.asympartp_transitive.
    interpret Y: well_ordered_set Y "(\<sqsubseteq>)" using derivation_well_ordered[OF Y].
    have XA: "X \<subseteq> A" using derivation_A[OF X].
    then have xA: "x \<in> A" using xX by auto
    with f have fxA: "f x \<in> A" by auto
    have YA: "Y \<subseteq> A" using derivation_A[OF Y].
    then have yA: "y \<in> A" using yY by auto
    with f have fyA: "f y \<in> A" by auto
    { fix Z
      assume Z: "Z = {z \<in> X. z \<sqsubset> x}"
        and fZ: "f ` Z \<subseteq> Z"
        and Zx: "extreme_bound A (\<sqsubseteq>) Z x"
        and IHx: "\<forall>z \<in> X. z \<sqsubset> x \<longrightarrow> (z \<sqsubset> y \<and> z \<in> Y) \<or> z = y \<or> (y \<sqsubset> z \<and> y \<in> X)"
      have "(y \<sqsubset> x \<and> y \<in> X) \<or> x \<sqsubseteq> y"
      proof (cases "\<exists>z \<in> Z. y \<sqsubset> z")
        case True
        then obtain z where zZ: "z \<in> Z" and yz: "y \<sqsubset> z" by auto
        from zZ Z have zX: "z \<in> X" and zx: "z \<sqsubset> x" by auto
        from IHx[rule_format, OF zX zx] yz have yX: "y \<in> X" by auto
        from X.asympartp.trans[OF yz zx yX zX xX] have "y \<sqsubset> x".
        with yX show ?thesis by auto
      next
        case False
        have "bound Z (\<sqsubseteq>) y"
        proof
          fix z assume "z \<in> Z"
          then have zX: "z \<in> X" and zx: "z \<sqsubset> x" and nyz: "\<not> y \<sqsubset> z" using Z False by auto
          with IHx[rule_format, OF zX zx] X show "z \<sqsubseteq> y" by auto
        qed
        with yA Zx have xy: "x \<sqsubseteq> y" by auto
        then show ?thesis by auto
      qed
    }
    note lim_any = this
    { fix z Z
      assume Z: "Z = {z \<in> X. z \<sqsubset> x}"
        and Zz: "extreme Z (\<sqsubseteq>) z"
        and xfz: "x = f z"
        and IHx: "(z \<sqsubset> y \<and> z \<in> Y) \<or> z = y \<or> (y \<sqsubset> z \<and> y \<in> X)"
      have zX: "z \<in> X" and zx: "z \<sqsubset> x" using Zz Z by (auto simp: extreme_def)
      then have zA: "z \<in> A" using XA by auto
      from IHx have "(y \<sqsubset> x \<and> y \<in> X) \<or> x \<sqsubseteq> y"
      proof (elim disjE conjE)
        assume zy: "z \<sqsubset> y" and zY: "z \<in> Y"
        from derivation_useful[OF Y zY yY zy] xfz have xy: "x \<sqsubseteq> y" by auto
        then show ?thesis by auto
      next
        assume zy: "z = y"
        then have "y \<sqsubset> x" using zx by auto
        with zy zX show ?thesis by auto
      next
        assume yz: "y \<sqsubset> z" and yX: "y \<in> X"
        from X.asympartp.trans[OF yz zx yX zX xX] have "y \<sqsubset> x".
        with yX show ?thesis by auto
      qed
    }
    note lim_any this
  }
  note lim_any = this(1) and suc_any = this(2)
  interpret X: well_ordered_set X "(\<sqsubseteq>)" using derivation_well_ordered[OF X].
  interpret Y: well_ordered_set Y "(\<sqsubseteq>)" using derivation_well_ordered[OF Y].
  have XA: "X \<subseteq> A" using derivation_A[OF X].
  have YA: "Y \<subseteq> A" using derivation_A[OF Y].
  from xX yY show ?thesis
  proof (induct x arbitrary: y)
    case (less x)
    note xX = \<open>x \<in> X\<close> and IHx = this(2)
    from xX XA f have xA: "x \<in> A" and fxA: "f x \<in> A" by auto
    from \<open>y \<in> Y\<close>
    show ?case
    proof (induct y)
      case (less y)
      note yY = \<open>y \<in> Y\<close> and IHy = less(2)
      from yY YA f have yA: "y \<in> A" and fyA: "f y \<in> A" by auto
      from X xX show ?case
      proof (cases rule: derivation_cases)
        case (suc Z z)
        note Z = \<open>Z = {z \<in> X. z \<sqsubset> x}\<close> and Zz = \<open>extreme Z (\<sqsubseteq>) z\<close> and xfz = \<open>x = f z\<close>
        then have zx: "z \<sqsubset> x" and zX: "z \<in> X" by auto
        note IHz = IHx[OF zX zx yY]
        have 1: "y \<sqsubset> x \<and> y \<in> X \<or> x \<sqsubseteq> y" using suc_any[OF X Y xX yY Z Zz xfz IHz] IHy by auto
        from Y yY show ?thesis
        proof (cases rule: derivation_cases)
          case (suc W w)
          note W = \<open>W = {w \<in> Y. w \<sqsubset> y}\<close> and Ww = \<open>extreme W (\<sqsubseteq>) w\<close> and yfw = \<open>y = f w\<close>
          then have wY: "w \<in> Y" and wy: "w \<sqsubset> y" by auto
          have IHw: "w \<sqsubset> x \<and> w \<in> X \<or> w = x  \<or> x \<sqsubset> w \<and> x \<in> Y" using IHy[OF wY wy] by auto
          have "x \<sqsubset> y \<and> x \<in> Y \<or> y \<sqsubseteq> x" using suc_any[OF Y X yY xX W Ww yfw IHw] by auto
          with 1 show ?thesis using antisym xA yA by auto
        next
          case (lim W)
          note W = \<open>W = {w \<in> Y. w \<sqsubset> y}\<close> and fW = \<open>f ` W \<subseteq> W\<close> and Wy = \<open>extreme_bound A (\<sqsubseteq>) W y\<close>
          have "x \<sqsubset> y \<and> x \<in> Y \<or> y \<sqsubseteq> x" using lim_any[OF Y X yY xX W fW Wy] IHy by auto
          with 1 show ?thesis using antisym xA yA by auto
        qed
      next
        case (lim Z)
        note Z = \<open>Z = {z \<in> X. z \<sqsubset> x}\<close> and fZ = \<open>f ` Z \<subseteq> Z\<close> and Zx = \<open>extreme_bound A (\<sqsubseteq>) Z x\<close>
        have 1: "y \<sqsubset> x \<and> y \<in> X \<or> x \<sqsubseteq> y" using lim_any[OF X Y xX yY Z fZ Zx] IHx[OF _ _ yY] by auto
        from Y yY show ?thesis
        proof (cases rule: derivation_cases)
          case (suc W w)
          note W = \<open>W = {w \<in> Y. w \<sqsubset> y}\<close> and Ww = \<open>extreme W (\<sqsubseteq>) w\<close> and yfw = \<open>y = f w\<close>
          then have wY: "w \<in> Y" and wy: "w \<sqsubset> y" by auto
          have IHw: "w \<sqsubset> x \<and> w \<in> X \<or>  w = x  \<or>  x \<sqsubset> w \<and> x \<in> Y" using IHy[OF wY wy] by auto
          have "x \<sqsubset> y \<and> x \<in> Y \<or> y \<sqsubseteq> x" using suc_any[OF Y X yY xX W Ww yfw IHw] by auto
          with 1 show ?thesis using antisym xA yA by auto
        next
          case (lim W)
          note W = \<open>W = {w \<in> Y. w \<sqsubset> y}\<close> and fW = \<open>f ` W \<subseteq> W\<close> and Wy = \<open>extreme_bound A (\<sqsubseteq>) W y\<close>
          have "x \<sqsubset> y \<and> x \<in> Y \<or> y \<sqsubseteq> x" using lim_any[OF Y X yY xX W fW Wy] IHy by auto
          with 1 show ?thesis using antisym xA yA by auto
        qed
      qed
    qed
  qed
qed

interpretation derivable: well_ordered_set "{x. derivable x}" "(\<sqsubseteq>)"
proof (rule well_ordered_set.intro)
  show "antisymmetric {x. derivable x} (\<sqsubseteq>)"
    apply unfold_locales by (auto dest: derivable_A antisym)
  show "well_related_set {x. derivable x} (\<sqsubseteq>)"
  apply (fold UN_derivations_eq_derivable)
  apply (rule closed_UN_well_related)
  by (auto dest: derivation_well_ordered derivations_cross_compare well_ordered_set.axioms)
qed

lemmas derivable_well_ordered = derivable.well_ordered_set_axioms
lemmas derivable_total_ordered = derivable.total_ordered_set_axioms
lemmas derivable_well_related = derivable.well_related_set_axioms

lemma pred_unique:
  assumes X: "derivation X" and xX: "x \<in> X"
  shows "{z \<in> X. z \<sqsubset> x} = {z. derivable z \<and> z \<sqsubset> x}"
proof
  { fix z assume "z \<in> X" and "z \<sqsubset> x"
    then have "derivable z \<and> z \<sqsubset> x" using X by (auto simp: derivable_def)
  }
  then show "{z \<in> X. z \<sqsubset> x} \<subseteq> {z. derivable z \<and> z \<sqsubset> x}" by auto
  { fix z assume "derivable z" and zx: "z \<sqsubset> x"
    then obtain Y where Y: "derivation Y" and zY: "z \<in> Y" by (auto simp: derivable_def)
    then have "z \<in> X" using derivations_cross_compare[OF X Y xX zY] zx by auto
  }
  then show "{z \<in> X. z \<sqsubset> x} \<supseteq> {z. derivable z \<and> z \<sqsubset> x}" by auto
qed

text \<open>The set of all derivable elements is itself a derivation.\<close>

lemma derivation_derivable: "derivation {x. derivable x}"
  apply (unfold derivation_def)
  apply (safe intro!: derivable_A derivable.well_ordered_set_axioms elim!: derivableE)
  apply (unfold mem_Collect_eq pred_unique[symmetric])
  by (auto simp: derivation_def)

text \<open>Finally, if the set of all derivable elements admits a supremum, then it is a fixed point.\<close>

lemma
  assumes p: "extreme_bound A (\<sqsubseteq>) {x. derivable x} p"
  shows sup_derivable_qfp: "f p \<sim> p" and sup_derivable_fp: "f p = p"
proof (intro antisym sympartpI)
  define P where "P \<equiv> {x. derivable x}"
  have pA: "p \<in> A" using p by auto
  have P: "derivation P" using derivation_derivable by (simp add: P_def)
  from derivable_closed have fP: "f ` P \<subseteq> P" by (auto simp: P_def)
  from derivation_lim[OF P fP] p
  have pP: "p \<in> P" by (auto simp: P_def intro:derivableI)
  with fP have "f p \<in> P" by auto
  with p show fpp: "f p \<sqsubseteq> p" by (auto simp: P_def)
  show pfp: "p \<sqsubseteq> f p" apply (rule derivation_infl[rule_format, OF P]) using pP by (auto simp: P_def)
  from fpp pfp p f show "f p = p" by (auto intro!: antisym)
qed

end

text "The assumptions are satisfied by monotone functions."

context
  assumes mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
begin

lemma mono_imp_derivation_infl:
  "\<forall>X x y. derivation X \<longrightarrow> x \<in> X \<longrightarrow> y \<in> X \<longrightarrow> x \<sqsubseteq> y \<longrightarrow> x \<sqsubseteq> f y"
proof (intro allI impI)
  fix X x y
  assume X: "derivation X" and xX: "x \<in> X" and yX: "y \<in> X" and xy: "x \<sqsubseteq> y"
  interpret X: well_ordered_set X "(\<sqsubseteq>)" using derivation_well_ordered[OF X].
  note XA = derivation_A[OF X]
  from xX yX xy show "x \<sqsubseteq> f y"
  proof (induct x)
    case (less x)
    note IH = this(2) and xX = \<open>x \<in> X\<close> and yX = \<open>y \<in> X\<close> and xy = \<open>x \<sqsubseteq> y\<close>
    from xX yX XA have xA: "x \<in> A" and yA: "y \<in> A" by auto
    from X xX show ?case
    proof (cases rule: derivation_cases)
      case (suc Z z)
      then have zX: "z \<in> X" and zsx: "z \<sqsubset> x" and xfz: "x = f z" by auto
      then have zx: "z \<sqsubseteq> x" by auto
      from X.trans[OF zx xy zX xX yX] have zy: "z \<sqsubseteq> y".
      from zX XA have zA: "z \<in> A" by auto
      from zy monotone_onD[OF mono] zA yA xfz show "x \<sqsubseteq> f y" by auto
    next
      case (lim Z)
      note Z = \<open>Z = {z \<in> X. z \<sqsubset> x}\<close> and Zx = \<open>extreme_bound A (\<sqsubseteq>) Z x\<close>
      from f yA have fyA: "f y \<in> A" by auto
      have "bound Z (\<sqsubseteq>) (f y)"
      proof
        fix z assume zZ: "z \<in> Z"
        with Z xX have zsx: "z \<sqsubset> x" and zX: "z \<in> X" by auto
        then have zx: "z \<sqsubseteq> x" by auto
        from X.trans[OF zx xy zX xX yX] have zy: "z \<sqsubseteq> y".
        from IH[OF zX zsx yX] zy show "z \<sqsubseteq> f y" by auto
      qed
      with Zx fyA show ?thesis by auto
    qed
  qed
qed

lemma mono_imp_derivation_f_refl:
  "\<forall>X x. derivation X \<longrightarrow> x \<in> X \<longrightarrow> f x \<sqsubseteq> f x"
proof (intro allI impI)
  fix X x
  assume X: "derivation X" and xX: "x \<in> X"
  interpret X: well_ordered_set X "(\<sqsubseteq>)" using derivation_well_ordered[OF X].
  note XA = derivation_A[OF X]
  from xX have "x \<sqsubseteq> x" by auto
  from monotone_onD[OF mono this] xX XA show "f x \<sqsubseteq> f x" by auto
qed

corollary mono_imp_sup_derivable_fp:
  assumes p: "extreme_bound A (\<sqsubseteq>) {x. derivable x} p"
  shows "f p = p"
  by (simp add: sup_derivable_fp[OF mono_imp_derivation_infl mono_imp_derivation_f_refl p])

lemma mono_imp_sup_derivable_lfp:
  assumes p: "extreme_bound A (\<sqsubseteq>) {x. derivable x} p"
  shows "extreme {q \<in> A. f q = q} (\<sqsupseteq>) p"
proof (safe intro!: extremeI)
  from p show "p \<in> A" by auto
  from sup_derivable_fp[OF mono_imp_derivation_infl mono_imp_derivation_f_refl p]
  show "f p = p".
  fix q assume qA: "q \<in> A" and fqq: "f q = q"
  have "bound {x. derivable x} (\<sqsubseteq>) q"
  proof (safe intro!: boundI elim!:derivableE)
    fix x X
    assume X: "derivation X" and xX: "x \<in> X"
    from X interpret well_ordered_set X "(\<sqsubseteq>)" by (rule derivation_well_ordered)
    from xX show "x \<sqsubseteq> q"
    proof (induct x)
      case (less x)
      note xP = this(1) and IH = this(2)
      with X show ?case
      proof (cases rule: derivation_cases)
        case (suc Z z)
        with IH[of z] have zq: "z \<sqsubseteq> q" and zX: "z \<in> X" by auto
        from monotone_onD[OF mono zq] zX qA derivation_A[OF X]
        show ?thesis by (auto simp: fqq suc)
      next
        case lim
        with IH have "bound {z \<in> X. z \<sqsubset> x} (\<sqsubseteq>) q" by auto
        with lim qA show ?thesis by auto
      qed
    qed
  qed
  with p qA show "p \<sqsubseteq> q" by auto
qed

lemma mono_imp_ex_least_fp:
  assumes comp: "well_complete A (\<sqsubseteq>)"
  shows "\<exists>p. extreme {q \<in> A. f q = q} (\<sqsupseteq>) p"
proof-
  interpret fixed_point_proof using f by unfold_locales
  note as = antisymmetric_axioms
  note infl = mono_imp_derivation_infl
  note refl = mono_imp_derivation_f_refl
  have wr: "well_related_set {x. derivable x} (\<sqsubseteq>)"
    using derivable_well_related[OF infl refl].
  have "\<exists>p. extreme_bound A (\<sqsubseteq>) {x. derivable x} p"
    apply (rule completeD[OF comp])
    using derivable_A wr by auto
  then obtain p where p: "extreme_bound A (\<sqsubseteq>) {x. derivable x} p" by auto
  from p mono_imp_sup_derivable_lfp[OF p] sup_derivable_qfp[OF infl refl p]
  show ?thesis by auto
qed

end

end

end

text \<open>Bourbaki-Witt Theorem on well-complete pseudo-ordered set:\<close>
theorem (in pseudo_ordered_set) well_complete_infl_imp_ex_fp:
  assumes comp: "well_complete A (\<sqsubseteq>)"
    and f: "f ` A \<subseteq> A" and infl: "\<forall>x \<in> A. \<forall>y \<in> A. x \<sqsubseteq> y \<longrightarrow> x \<sqsubseteq> f y"
  shows "\<exists>p \<in> A. f p = p"
proof-
  note as = antisymmetric_axioms
  interpret fixed_point_proof using f by unfold_locales
  have dinfl: "\<forall>X x y. derivation X \<longrightarrow> x \<in> X \<longrightarrow> y \<in> X \<longrightarrow> x \<sqsubseteq> y \<longrightarrow> x \<sqsubseteq> f y"
    using infl by (auto dest!:derivation_A)
  have drefl: "\<forall>X x. derivation X \<longrightarrow> x \<in> X \<longrightarrow> f x \<sqsubseteq> f x" using f by (auto dest!: derivation_A)
  have "\<exists>p. extreme_bound A (\<sqsubseteq>) {x. derivable x} p"
    apply (rule completeD[OF comp])
    using derivable_well_related[OF as dinfl drefl] derivable_A by auto
  with sup_derivable_fp[OF as dinfl drefl]
  show ?thesis by auto
qed

section \<open>Completeness of (Quasi-)Fixed Points\<close>

text \<open>We now prove that, under attractivity, the set of quasi-fixed points is complete.\<close>

definition setwise where "setwise r X Y \<equiv> \<forall>x\<in>X. \<forall>y\<in>Y. r x y"

lemmas setwiseI[intro] = setwise_def[unfolded atomize_eq, THEN iffD2, rule_format]
lemmas setwiseE[elim] = setwise_def[unfolded atomize_eq, THEN iffD1, elim_format, rule_format]

context fixed_point_proof begin

abbreviation setwise_less_eq (infix "\<sqsubseteq>\<^sup>s" 50) where "(\<sqsubseteq>\<^sup>s) \<equiv> setwise (\<sqsubseteq>)"

subsection \<open>Least Quasi-Fixed Points for Attractive Relations.\<close>

lemma attract_mono_imp_least_qfp:
  assumes attract: "attractive A (\<sqsubseteq>)"
    and comp: "well_complete A (\<sqsubseteq>)"
    and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "\<exists>c. extreme {p \<in> A. f p \<sim> p \<or> f p = p} (\<sqsupseteq>) c \<and> f c \<sim> c"
proof-
  interpret attractive using attract by auto
  interpret sym: transitive A "(\<sim>)" using sym_transitive.
  define ecl ("[_]\<^sub>\<sim>") where "[x]\<^sub>\<sim> \<equiv> {y \<in> A. x \<sim> y} \<union> {x}" for x
  define Q where "Q \<equiv> {[x]\<^sub>\<sim> |. x \<in> A}"
  { fix X x assume XQ: "X \<in> Q" and xX: "x \<in> X"
    then have XA: "X \<subseteq> A" by (auto simp: Q_def ecl_def)
    then have xA: "x \<in> A" using xX by auto
    obtain q where qA: "q \<in> A" and X: "X = [q]\<^sub>\<sim>" using XQ by (auto simp: Q_def)
    have xqqx: "x \<sim> q \<or> x = q" using X xX by (auto simp: ecl_def)
    {fix y assume yX: "y \<in> X"
      then have yA: "y \<in> A" using XA by auto
      have "y \<sim> q \<or> y = q" using yX X by (auto simp: ecl_def)
      then have "x \<sim> y \<or> y = x" using sym_order_trans xqqx xA qA yA by blast
    }
    then have 1: "X \<subseteq> [x]\<^sub>\<sim>" using X qA by (auto simp: ecl_def)
    { fix y assume "y \<in> A" and "x \<sim> y \<or> y = x"
      then have "q \<sim> y \<or> y = q" using sym_order_trans xqqx xA qA by blast
    }
    then have 2: "X \<supseteq> [x]\<^sub>\<sim>" using X xX by (auto simp: ecl_def)
    from 1 2 have "X = [x]\<^sub>\<sim>" by auto
  }
  then have XQx: "\<forall>X \<in> Q. \<forall>x \<in> X. X = [x]\<^sub>\<sim>" by auto
  have RSLE_eq: "X \<in> Q \<Longrightarrow> Y \<in> Q \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> X \<sqsubseteq>\<^sup>s Y" for X Y x y
  proof-
    assume XQ: "X \<in> Q" and YQ: "Y \<in> Q" and xX: "x \<in> X" and yY: "y \<in> Y" and xy: "x \<sqsubseteq> y"
    then have XA: "X \<subseteq> A" and YA: "Y \<subseteq> A" by (auto simp: Q_def ecl_def)
    then have xA: "x \<in> A" and yA: "y \<in> A" using xX yY by auto
    { fix xp yp assume xpX: "xp \<in> X" and ypY: "yp \<in> Y"
      then have xpA: "xp \<in> A" and ypA: "yp \<in> A" using XA YA by auto
      then have "xp \<sim> x \<or> xp = x" using xpX XQx xX XQ by (auto simp: ecl_def)
      then have xpy: "xp \<sqsubseteq> y" using attract[OF _ _ xy xpA xA yA] xy by blast
      have "yp \<sim> y \<or> yp = y" using ypY XQx yY YQ by (auto simp: ecl_def)
      then have "xp \<sqsubseteq> yp" using dual.attract[OF _ _ xpy ypA yA xpA] xpy by blast
    }
    then show "X \<sqsubseteq>\<^sup>s Y" using XQ YQ XA YA by auto
  qed
  have compQ: "well_complete Q (\<sqsubseteq>\<^sup>s)"
  proof (intro completeI, safe)
    fix XX assume XXQ: "XX \<subseteq> Q" and XX: "well_related_set XX (\<sqsubseteq>\<^sup>s)"
    have BA: "\<Union>XX \<subseteq> A" using XXQ by (auto simp: Q_def ecl_def)
    from XX interpret XX: well_related_set XX "(\<sqsubseteq>\<^sup>s)".
    interpret UXX: semiattractive "\<Union>XX" "(\<sqsubseteq>)" by (rule semiattractive_subset[OF BA])
    have "well_related_set (\<Union>XX) (\<sqsubseteq>)"
    proof(unfold_locales)
      fix Y assume YXX: "Y \<subseteq> \<Union>XX" and Y0: "Y \<noteq> {}"
      have "{X \<in> XX. X \<inter> Y \<noteq> {}} \<noteq> {}" using YXX Y0 by auto
      from XX.nonempty_imp_ex_extreme[OF _ this]
      obtain E where E: "extreme {X \<in> XX. X \<inter> Y \<noteq> {}} (\<sqsubseteq>\<^sup>s)\<^sup>- E" by auto
      then have "E \<inter> Y \<noteq> {}" by auto
      then obtain e where eE: "e \<in> E" and eX: "e \<in> Y" by auto
      have "extreme Y (\<sqsupseteq>) e"
      proof (intro extremeI eX)
        fix x assume xY: "x \<in> Y"
        with YXX obtain X where XXX: "X \<in> XX" and xX: "x \<in> X" by auto
        with xY E XXX have "E \<sqsubseteq>\<^sup>s X" by auto
        with eE xX show "e \<sqsubseteq> x" by auto
      qed
      then show "\<exists>e. extreme Y (\<sqsupseteq>) e" by auto
    qed
    with completeD[OF comp BA]
    obtain b where extb: "extreme_bound A (\<sqsubseteq>) (\<Union>XX) b" by auto
    then have bb: "b \<sqsubseteq> b" using extreme_def bound_def by auto
    have bA: "b \<in> A" using extb extreme_def by auto
    then have XQ: "[b]\<^sub>\<sim> \<in> Q" using Q_def bA by auto
    have bX: "b \<in> [b]\<^sub>\<sim>" by (auto simp: ecl_def)
    have "extreme_bound Q (\<sqsubseteq>\<^sup>s) XX [b]\<^sub>\<sim>"
    proof(intro extreme_boundI)
      show "[b]\<^sub>\<sim> \<in> Q" using XQ.
    next
      fix Y assume YXX: "Y \<in> XX"
      then have YQ: "Y \<in> Q" using XXQ by auto
      then obtain y where yA: "y \<in> A" and Yy: "Y = [y]\<^sub>\<sim>" by (auto simp: Q_def)
      then have yY: "y \<in> Y" by (auto simp: ecl_def)
      then have "y \<in> \<Union>XX" using yY YXX by auto
      then have "y \<sqsubseteq> b" using extb by auto
      then show "Y \<sqsubseteq>\<^sup>s [b]\<^sub>\<sim>" using RSLE_eq[OF YQ XQ yY bX] by auto
    next
      fix Z assume boundZ: "bound XX (\<sqsubseteq>\<^sup>s) Z" and ZQ: "Z \<in> Q"
      then obtain z where zA: "z \<in> A" and Zz: "Z = [z]\<^sub>\<sim>" by (auto simp: Q_def)
      then have zZ: "z \<in> Z" by (auto simp: ecl_def)
      { fix y assume "y \<in> \<Union>XX"
        then obtain Y where yY: "y \<in> Y" and YXX: "Y \<in> XX" by auto
        then have YA: "Y \<subseteq> A" using XXQ Q_def by (auto simp: ecl_def)
        then have "Y \<sqsubseteq>\<^sup>s Z" using YXX boundZ bound_def by auto
        then have "y \<sqsubseteq> z" using yY zZ by auto
      }
      then have "bound (\<Union>XX) (\<sqsubseteq>) z" by auto
      then have "b \<sqsubseteq> z" using extb zA by auto
      then show "[b]\<^sub>\<sim> \<sqsubseteq>\<^sup>s Z" using RSLE_eq[OF XQ ZQ bX zZ] by auto
    qed
    then show "Ex (extreme_bound Q (\<sqsubseteq>\<^sup>s) XX)" by auto
  qed
  interpret Q: antisymmetric Q "(\<sqsubseteq>\<^sup>s)"
  proof
    fix X Y assume XY: "X \<sqsubseteq>\<^sup>s Y" and YX: "Y \<sqsubseteq>\<^sup>s X" and XQ: "X \<in> Q" and YQ: "Y \<in> Q"
    then obtain q where qA: "q \<in> A" and X: "X = [q]\<^sub>\<sim>" using Q_def by auto
    then have qX: "q \<in> X" using X by (auto simp: ecl_def)
    then obtain p where pA: "p \<in> A" and Y: "Y = [p]\<^sub>\<sim>" using YQ Q_def by auto
    then have pY: "p \<in> Y" using X by (auto simp: ecl_def)
    have pq: "p \<sqsubseteq> q" using  XQ YQ YX qX pY by auto
    have "q \<sqsubseteq> p" using XQ YQ XY qX pY by auto
    then have "p \<in> X" using pq X pA by (auto simp: ecl_def)
    then have "X = [p]\<^sub>\<sim>" using XQ XQx by auto
    then show "X = Y" using Y by (auto simp: ecl_def)
  qed
  define F where "F X \<equiv> {y \<in> A. \<exists>x \<in> X. y \<sim> f x} \<union> f ` X" for X
  have XQFXQ: "\<And>X. X \<in> Q \<Longrightarrow> F X \<in> Q"
  proof-
    fix X assume XQ: "X \<in> Q"
    then obtain x where xA: "x \<in> A" and X: "X = [x]\<^sub>\<sim>" using Q_def by auto
    then have xX: "x \<in> X" by (auto simp: ecl_def)
    have fxA: "f x \<in> A" using xA f by auto
    have FXA: "F X \<subseteq> A" using f fxA X by (auto simp: F_def ecl_def)
    have "F X = [f x]\<^sub>\<sim>"
    proof (unfold X, intro equalityI subsetI)
      fix z assume zFX: "z \<in> F [x]\<^sub>\<sim>"
      then obtain y where yX: "y \<in> [x]\<^sub>\<sim>" and zfy: "z \<sim> f y \<or> z = f y" by (auto simp: F_def)
      have yA: "y \<in> A" using yX xA by (auto simp: ecl_def)
      with f have fyA: "f y \<in> A" by auto
      have zA: "z \<in> A" using zFX FXA by (auto simp: X)
      have "y \<sim> x \<or> y = x" using X yX by (auto simp: ecl_def)
      then have "f y \<sim> f x \<or> f y = f x" using mono xA yA by (auto simp: monotone_on_def)
      then have "z \<sim> f x \<or> z = f x" using zfy sym.trans[OF _ _ zA fyA fxA] by (auto simp:)
      with zA show "z \<in> [f x]\<^sub>\<sim>" by (auto simp: ecl_def)
    qed (auto simp: xX F_def ecl_def)
    with FXA show "F X \<in> Q" by (auto simp: Q_def ecl_def)
  qed
  then have F: "F ` Q \<subseteq> Q" by auto
  then interpret Q: fixed_point_proof Q "(\<sqsubseteq>\<^sup>s)" F by unfold_locales
  have monoQ: "monotone_on Q (\<sqsubseteq>\<^sup>s) (\<sqsubseteq>\<^sup>s) F"
  proof (intro monotone_onI)
    fix X Y assume XQ: "X \<in> Q" and YQ: "Y \<in> Q" and XY: "X \<sqsubseteq>\<^sup>s Y"
    then obtain x y where xX: "x \<in> X" and yY: "y \<in> Y" using Q_def by (auto simp: ecl_def)
    then have xA: "x \<in> A" and yA: "y \<in> A" using XQ YQ by (auto simp: Q_def ecl_def)
    have "x \<sqsubseteq> y" using XY xX yY by auto
    then have fxfy: "f x \<sqsubseteq> f y" using monotone_on_def[of A "(\<sqsubseteq>)" "(\<sqsubseteq>)" f] xA yA mono by auto
    have fxgX: "f x \<in> F X" using xX F_def by blast
    have fygY: "f y \<in> F Y" using yY F_def by blast
    show "F X \<sqsubseteq>\<^sup>s F Y" using RSLE_eq[OF XQFXQ[OF XQ] XQFXQ[OF YQ] fxgX fygY fxfy].
  qed
  have QdA: "{x. Q.derivable x} \<subseteq> Q" using Q.derivable_A by auto
  note asQ = Q.antisymmetric_axioms
  note infl = Q.mono_imp_derivation_infl[OF asQ monoQ]
  note f_refl = Q.mono_imp_derivation_f_refl[OF asQ monoQ]
  from Q.mono_imp_ex_least_fp[OF asQ monoQ compQ]
  obtain P where P: "extreme {q \<in> Q. F q = q} (\<sqsubseteq>\<^sup>s)\<^sup>- P" by auto
  then have PQ: "P \<in> Q" by (auto simp: extreme_def)
  from P have FPP: "F P = P" using PQ by auto
  with P have PP: "P \<sqsubseteq>\<^sup>s P" by auto
  from P obtain p where pA: "p \<in> A" and Pp: "P = [p]\<^sub>\<sim>" using Q_def by auto
  then have pP: "p \<in> P" by (auto simp: ecl_def)
  then have fpA: "f p \<in> A" using pA f by auto
  have "f p \<in> F P" using pP F_def fpA by auto
  then have "F P = [f p]\<^sub>\<sim>" using XQx XQFXQ[OF PQ] by auto
  then have fp: "f p \<sim> p \<or> f p = p" using pP FPP by (auto simp: ecl_def)
  have "p \<sqsubseteq> p" using PP pP by auto
  with fp have fpp: "f p \<sim> p" by auto
  have e: "extreme {p \<in> A. f p \<sim> p \<or> f p = p} (\<sqsupseteq>) p"
  proof (intro extremeI CollectI conjI pA fp, elim CollectE conjE)
    fix q assume qA: "q \<in> A" and fq: "f q \<sim> q \<or> f q = q"
    define Z where "Z \<equiv> {z \<in> A. q \<sim> z}\<union>{q}"
    then have qZ: "q \<in> Z" using qA by auto
    then have ZQ: "Z \<in> Q" using qA by (auto simp: Z_def Q_def ecl_def)
    have fqA: "f q \<in> A" using qA f by auto
    then have "f q \<in> Z" using fq by (auto simp: Z_def)
    then have 1: "Z = [f q]\<^sub>\<sim>" using XQx ZQ by auto
    then have "f q \<in> F Z" using qZ fqA by (auto simp: F_def)
    then have "F Z = [f q]\<^sub>\<sim>" using XQx XQFXQ[OF ZQ] by auto
    with 1 have "Z = F Z" by auto
    then have "P \<sqsubseteq>\<^sup>s Z" using P ZQ by auto
    then show "p \<sqsubseteq> q" using pP qZ by auto
  qed
  with fpp show ?thesis using e by auto
qed

subsection \<open>General Completeness\<close>

lemma attract_mono_imp_fp_qfp_complete:
  assumes attract: "attractive A (\<sqsubseteq>)"
    and comp: "CC-complete A (\<sqsubseteq>)"
    and wr_CC: "\<forall>C \<subseteq> A. well_related_set C (\<sqsubseteq>) \<longrightarrow> C \<in> CC"
    and extend: "\<forall>X \<in> CC. \<forall>Y \<in> CC. X \<sqsubseteq>\<^sup>s Y \<longrightarrow> X \<union> Y \<in> CC"
    and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
    and P: "P \<subseteq> {x \<in> A. f x = x}"
  shows "CC-complete ({q \<in> A. f q \<sim> q} \<union> P) (\<sqsubseteq>)"
proof (intro completeI)
  interpret attractive using attract.
  fix X assume Xfix: "X \<subseteq> {q \<in> A. f q \<sim> q} \<union> P" and XCC: "X \<in> CC"
  with P have XA: "X \<subseteq> A" by auto
  define B where "B \<equiv> {b \<in> A. \<forall>a \<in> X. a \<sqsubseteq> b}"
  { fix s a assume sA: "s \<in> A" and as: "\<forall>a \<in> X. a \<sqsubseteq> s" and aX: "a \<in> X"
    then have aA: "a \<in> A" using XA by auto
    then have fafs: "f a \<sqsubseteq> f s" using mono f aX sA as by (auto elim!: monotone_onE)
    have "a \<sqsubseteq> f s"
    proof (cases "f a = a")
      case True
      then show ?thesis using fafs by auto
    next
      case False
      then have "a \<sim> f a" using P aX Xfix by auto
      also from fafs have "f a \<sqsubseteq> f s" by auto
      finally show ?thesis using f aA sA by auto
    qed
  }
  with f have fBB: "f ` B \<subseteq> B" unfolding B_def by auto
  have BA: "B \<subseteq> A" by (auto simp: B_def)
  have compB: "CC-complete B (\<sqsubseteq>)"
  proof (unfold complete_def, intro allI impI)
    fix Y assume YS: "Y \<subseteq> B" and YCC: "Y \<in> CC"
    with BA have YA: "Y \<subseteq> A" by auto
    define C where "C \<equiv> X\<union>Y"
    then have CA: "C \<subseteq> A" using XA YA C_def by auto
    have XY: "X \<sqsubseteq>\<^sup>s Y" using B_def YS by auto
    then have CCC: "C \<in> CC" using extend XA YA XCC YCC C_def by auto
    then obtain s where s: "extreme_bound A (\<sqsubseteq>) C s"
      using completeD[OF comp CA CCC] by auto
    then have sA: "s \<in> A" by auto
    show "Ex (extreme_bound B (\<sqsubseteq>) Y)"
    proof (intro exI extreme_boundI)
      { fix x assume "x \<in> X"
        then have "x \<sqsubseteq> s" using s C_def by auto
      }
      then show "s \<in> B" using sA B_def by auto
    next
      fix y assume "y \<in> Y"
      then show "y \<sqsubseteq> s" using s C_def using extremeD by auto
    next
      fix c assume cS: "c \<in> B" and "bound Y (\<sqsubseteq>) c"
      then have "bound C (\<sqsubseteq>) c" using C_def B_def by auto
      then show "s \<sqsubseteq> c" using s BA cS by auto
    qed
  qed
  from fBB interpret B: fixed_point_proof B "(\<sqsubseteq>)" f by unfold_locales
  from BA have *: "{x \<in> A. f x \<sim> x} \<inter> B = {x \<in> B. f x \<sim> x}" by auto
  have asB: "attractive B (\<sqsubseteq>)" using attractive_subset[OF BA] by auto
  have monoB: "monotone_on B (\<sqsubseteq>) (\<sqsubseteq>) f" using monotone_on_cmono[OF BA] mono by (auto dest!: le_funD)
  have compB: "well_complete B (\<sqsubseteq>)"
    using wr_CC compB BA by (simp add: complete_def)
  from B.attract_mono_imp_least_qfp[OF asB compB monoB]
  obtain l where "extreme {p \<in> B. f p \<sim> p \<or> f p = p} (\<sqsupseteq>) l" and fll: "f l \<sim> l" by auto
  with P have l: "extreme ({p \<in> B. f p \<sim> p} \<union> P \<inter> B) (\<sqsupseteq>) l" by auto
  show "Ex (extreme_bound ({q \<in> A. f q \<sim> q} \<union> P) (\<sqsubseteq>) X)"
  proof (intro exI extreme_boundI)
    show "l \<in> {q \<in> A. f q \<sim> q} \<union> P" using l BA by auto
    fix a assume "a \<in> X"
    with l show "a \<sqsubseteq> l" by (auto simp: B_def)
  next
    fix c assume c: "bound X (\<sqsubseteq>) c" and cfix: "c \<in> {q \<in> A. f q \<sim> q} \<union> P"
    with P have cA: "c \<in> A" by auto
    with c have "c \<in> B" by (auto simp: B_def)
    with cfix l show "l \<sqsubseteq> c" by auto
  qed
qed

lemma attract_mono_imp_qfp_complete:
  assumes "attractive A (\<sqsubseteq>)"
    and "CC-complete A (\<sqsubseteq>)"
    and "\<forall>C \<subseteq> A. well_related_set C (\<sqsubseteq>) \<longrightarrow> C \<in> CC"
    and "\<forall>X \<in> CC. \<forall>Y \<in> CC. X \<sqsubseteq>\<^sup>s Y \<longrightarrow> X \<union> Y \<in> CC"
    and "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "CC-complete {p \<in> A. f p \<sim> p} (\<sqsubseteq>)"
  using attract_mono_imp_fp_qfp_complete[OF assms, of "{}"] by simp

lemma antisym_mono_imp_fp_complete:
  assumes anti: "antisymmetric A (\<sqsubseteq>)"
    and comp: "CC-complete A (\<sqsubseteq>)"
    and wr_CC: "\<forall>C \<subseteq> A. well_related_set C (\<sqsubseteq>) \<longrightarrow> C \<in> CC"
    and extend: "\<forall>X \<in> CC. \<forall>Y \<in> CC. X \<sqsubseteq>\<^sup>s Y \<longrightarrow> X \<union> Y \<in> CC"
    and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "CC-complete {p \<in> A. f p = p} (\<sqsubseteq>)"
proof-
  interpret antisymmetric using anti.
  have *: "{q \<in> A. f q \<sim> q} \<subseteq> {p \<in> A. f p = p}" using f by (auto intro!: antisym)
  from * attract_mono_imp_fp_qfp_complete[OF attractive_axioms comp wr_CC extend mono, of "{p\<in>A. f p = p}"]
  show ?thesis by (auto simp: subset_Un_eq)
qed

end

subsection \<open>Instances\<close>

subsubsection \<open>Instances under attractivity\<close>

context attractive begin

interpretation less_eq_notations.

text \<open>Full completeness\<close>
theorem mono_imp_qfp_UNIV_complete:
  assumes comp: "UNIV-complete A (\<sqsubseteq>)" and f: "f ` A \<subseteq> A" and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "UNIV-complete {p \<in> A. f p \<sim> p} (\<sqsubseteq>)"
  apply (intro fixed_point_proof.attract_mono_imp_qfp_complete comp mono)
    apply unfold_locales
  by (auto simp: f)

text \<open>Connex completeness\<close>
theorem mono_imp_qfp_connex_complete:
  assumes comp: "{X. connex X (\<sqsubseteq>)}-complete A (\<sqsubseteq>)"
    and f: "f ` A \<subseteq> A" and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "{X. connex X (\<sqsubseteq>)}-complete {p \<in> A. f p \<sim> p} (\<sqsubseteq>)"
  apply (intro fixed_point_proof.attract_mono_imp_qfp_complete mono comp)
    apply unfold_locales
  by (auto simp: f intro: connex_union well_related_set.connex_axioms)

text \<open>Directed completeness\<close>
theorem mono_imp_qfp_directed_complete:
  assumes comp: "{X. directed X (\<sqsubseteq>)}-complete A (\<sqsubseteq>)"
    and f: "f ` A \<subseteq> A" and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "{X. directed X (\<sqsubseteq>)}-complete {p \<in> A. f p \<sim> p} (\<sqsubseteq>)"
  apply (intro fixed_point_proof.attract_mono_imp_qfp_complete mono comp)
    apply unfold_locales
  by (auto simp: f intro!: directed_extend intro: well_related_set.connex_axioms connex.directed)

text \<open>Well Completeness\<close>
theorem mono_imp_qfp_well_complete:
  assumes comp: "well_complete A (\<sqsubseteq>)"
    and f: "f ` A \<subseteq> A" and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "well_complete {p \<in> A. f p \<sim> p} (\<sqsubseteq>)"
  apply (intro fixed_point_proof.attract_mono_imp_qfp_complete mono comp)
    apply unfold_locales
  by (auto simp: f well_related_extend)

end

subsubsection \<open>Usual instances under antisymmetry \<close>

context antisymmetric begin

text \<open>Knaster--Tarski\<close>
theorem mono_imp_fp_complete:
  assumes comp: "UNIV-complete A (\<sqsubseteq>)"
    and f: "f ` A \<subseteq> A" and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "UNIV-complete {p \<in> A. f p = p} (\<sqsubseteq>)"
proof-
  interpret fixed_point_proof using f by unfold_locales
  show ?thesis
    apply (intro antisym_mono_imp_fp_complete mono antisymmetric_axioms comp)
    by auto
qed

text \<open>Markowsky 1976\<close>
theorem mono_imp_fp_connex_complete:
  assumes comp: "{X. connex X (\<sqsubseteq>)}-complete A (\<sqsubseteq>)"
    and f: "f ` A \<subseteq> A" and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "{X. connex X (\<sqsubseteq>)}-complete {p \<in> A. f p = p} (\<sqsubseteq>)"
proof-
  interpret fixed_point_proof using f by unfold_locales
  show ?thesis
    apply (intro antisym_mono_imp_fp_complete antisymmetric_axioms mono comp)
    by (auto intro: connex_union well_related_set.connex_axioms)
qed

text \<open>Pataraia\<close>
theorem mono_imp_fp_directed_complete:
  assumes comp: "{X. directed X (\<sqsubseteq>)}-complete A (\<sqsubseteq>)"
    and f: "f ` A \<subseteq> A" and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "{X. directed X (\<sqsubseteq>)}-complete {p \<in> A. f p = p} (\<sqsubseteq>)"
proof-
  interpret fixed_point_proof using f by unfold_locales
  show ?thesis
    apply (intro antisym_mono_imp_fp_complete mono antisymmetric_axioms comp)
     by (auto intro: directed_extend connex.directed well_related_set.connex_axioms)
qed

text \<open>Bhatta \& George 2011\<close>
theorem mono_imp_fp_well_complete:
  assumes comp: "well_complete A (\<sqsubseteq>)"
    and f: "f ` A \<subseteq> A" and mono: "monotone_on A (\<sqsubseteq>) (\<sqsubseteq>) f"
  shows "well_complete {p \<in> A. f p = p} (\<sqsubseteq>)"
proof-
  interpret fixed_point_proof using f by unfold_locales
  show ?thesis
    apply (intro antisym_mono_imp_fp_complete mono antisymmetric_axioms comp)
    by (auto intro!: antisym well_related_extend)
qed

end

end


theory Forward imports TPrimes begin

text{*\noindent
Forward proof material: of, OF, THEN, simplify, rule_format.
*}

text{*\noindent
SKIP most developments...
*}

(** Commutativity **)

lemma is_gcd_commute: "is_gcd k m n = is_gcd k n m"
apply (auto simp add: is_gcd_def)
done

lemma gcd_commute: "gcd m n = gcd n m"
apply (rule is_gcd_unique)
apply (rule is_gcd)
apply (subst is_gcd_commute)
apply (simp add: is_gcd)
done

lemma gcd_1 [simp]: "gcd m (Suc 0) = Suc 0"
apply simp
done

lemma gcd_1_left [simp]: "gcd (Suc 0) m = Suc 0"
apply (simp add: gcd_commute [of "Suc 0"])
done

text{*\noindent
as far as HERE.
*}

text{*\noindent
SKIP THIS PROOF
*}

lemma gcd_mult_distrib2: "k * gcd m n = gcd (k*m) (k*n)"
apply (induct_tac m n rule: gcd.induct)
apply (case_tac "n=0")
apply simp
apply (case_tac "k=0")
apply simp_all
done

text {*
@{thm[display] gcd_mult_distrib2}
\rulename{gcd_mult_distrib2}
*}

text{*\noindent
of, simplified
*}

lemmas gcd_mult_0 = gcd_mult_distrib2 [of k 1]
lemmas gcd_mult_1 = gcd_mult_0 [simplified]

lemmas where1 = gcd_mult_distrib2 [where m=1]

lemmas where2 = gcd_mult_distrib2 [where m=1 and k=1]

lemmas where3 = gcd_mult_distrib2 [where m=1 and k="j+k"]

text {*
example using ``of'':
@{thm[display] gcd_mult_distrib2 [of _ 1]}

example using ``where'':
@{thm[display] gcd_mult_distrib2 [where m=1]}

example using ``where'', ``and'':
@{thm[display] gcd_mult_distrib2 [where m=1 and k="j+k"]}

@{thm[display] gcd_mult_0}
\rulename{gcd_mult_0}

@{thm[display] gcd_mult_1}
\rulename{gcd_mult_1}

@{thm[display] sym}
\rulename{sym}
*}

lemmas gcd_mult0 = gcd_mult_1 [THEN sym]
      (*not quite right: we need ?k but this gives k*)

lemmas gcd_mult0' = gcd_mult_distrib2 [of k 1, simplified, THEN sym]
      (*better in one step!*)

text {*
more legible, and variables properly generalized
*}

lemma gcd_mult [simp]: "gcd k (k*n) = k"
by (rule gcd_mult_distrib2 [of k 1, simplified, THEN sym])

lemmas gcd_self0 = gcd_mult [of k 1, simplified]

text {*
@{thm[display] gcd_mult}
\rulename{gcd_mult}

@{thm[display] gcd_self0}
\rulename{gcd_self0}
*}

text {*
Rules handy with THEN

@{thm[display] iffD1}
\rulename{iffD1}

@{thm[display] iffD2}
\rulename{iffD2}
*}

text {*
again: more legible, and variables properly generalized
*}

lemma gcd_self [simp]: "gcd k k = k"
by (rule gcd_mult [of k 1, simplified])

text{*
NEXT SECTION: Methods for Forward Proof

NEW

theorem arg_cong, useful in forward steps
@{thm[display] arg_cong[no_vars]}
\rulename{arg_cong}
*}

lemma "2 \<le> u \<Longrightarrow> u*m \<noteq> Suc(u*n)"
apply (intro notI)
txt{*
before using arg_cong
@{subgoals[display,indent=0,margin=65]}
*}
apply (drule_tac f="\<lambda>x. x mod u" in arg_cong)
txt{*
after using arg_cong
@{subgoals[display,indent=0,margin=65]}
*}
apply (simp add: mod_Suc)
done

text{*
have just used this rule:
@{thm[display] mod_Suc[no_vars]}
\rulename{mod_Suc}

@{thm[display] mult_le_mono1[no_vars]}
\rulename{mult_le_mono1}
*}

text{*
example of "insert"
*}

lemma relprime_dvd_mult:
      "\<lbrakk> gcd k n = 1; k dvd m*n \<rbrakk> \<Longrightarrow> k dvd m"
apply (insert gcd_mult_distrib2 [of m k n])
txt{*@{subgoals[display,indent=0,margin=65]}*}
apply simp
txt{*@{subgoals[display,indent=0,margin=65]}*}
apply (erule_tac t="m" in ssubst)
apply simp
done

text {*
@{thm[display] relprime_dvd_mult}
\rulename{relprime_dvd_mult}

Another example of "insert"

@{thm[display] div_mult_mod_eq}
\rulename{div_mult_mod_eq}
*}

(*MOVED to Force.thy, which now depends only on Divides.thy
lemma div_mult_self_is_m: "0<n \<Longrightarrow> (m*n) div n = (m::nat)"
*)

lemma relprime_dvd_mult_iff: "gcd k n = 1 \<Longrightarrow> (k dvd m*n) = (k dvd m)"
by (auto intro: relprime_dvd_mult elim: dvdE)

lemma relprime_20_81: "gcd 20 81 = 1"
by (simp add: gcd.simps)

text {*
Examples of 'OF'

@{thm[display] relprime_dvd_mult}
\rulename{relprime_dvd_mult}

@{thm[display] relprime_dvd_mult [OF relprime_20_81]}

@{thm[display] dvd_refl}
\rulename{dvd_refl}

@{thm[display] dvd_add}
\rulename{dvd_add}

@{thm[display] dvd_add [OF dvd_refl dvd_refl]}

@{thm[display] dvd_add [OF _ dvd_refl]}
*}

lemma "\<lbrakk>(z::int) < 37; 66 < 2*z; z*z \<noteq> 1225; Q(34); Q(36)\<rbrakk> \<Longrightarrow> Q(z)"
apply (subgoal_tac "z = 34 \<or> z = 36")
txt{*
the tactic leaves two subgoals:
@{subgoals[display,indent=0,margin=65]}
*}
apply blast
apply (subgoal_tac "z \<noteq> 35")
txt{*
the tactic leaves two subgoals:
@{subgoals[display,indent=0,margin=65]}
*}
apply arith
apply force
done

end