(*  Title:       Instances of Schneider's generalized protocol of clock synchronization
    Author:      Damián Barsotti <damian at hal.famaf.unc.edu.ar>, 2006
    Maintainer:  Damián Barsotti <damian at hal.famaf.unc.edu.ar>
*)

header {* Fault-tolerant Midpoint algorithm *}

theory LynchInstance imports Complex_Main begin

text {* This algorithm is presented in \cite{lynch_cs}. *}

subsection {* Model of the system *}

text {* The main ideas for the formalization of the system were
obtained from \cite{shankar92mechanical}.  *}

subsubsection {* Types in the formalization *}

text {* The election of the basics types was based on
\cite{shankar92mechanical}. There, the process are natural numbers and
the real time and the clock readings are reals. *}

type_synonym process = nat
type_synonym time = real      -- "real time"
type_synonym Clocktime = real -- "time of the clock readings (clock time)"

subsubsection {* Some constants *}

text{* Here we define some parameters of the algorithm that we use:
the number of process and the number of lowest and highest readed
values that the algorithm discards. The defined constants must satisfy
this axiom. If not, the algorithm cannot obtain the maximum and
minimum value, because it will have discarded all the values. *}

axiomatization
  np  :: nat  -- "Number of processes" and
  khl :: nat  -- "Number of lowest and highest values" where
  constants_ax: "2 * khl < np"

text {* We define also the set of process that the algorithm
manage. This definition exist only for readability matters. *}

definition
PR :: "process set" where
[simp]: "PR = {..<np}"

subsubsection {* Convergence function *}

text {* This functions is called ``Fault-tolerant Midpoint''
(\cite{schneider87understanding})*}

text {* In this algorithm each process has an array where it store the
clocks readings from the others processes (including itself). We
formalise that as a function from processes to clock time as
\cite{shankar92mechanical}. *}

text {* First we define two functions. They take a function of clock
readings and a set of processes and they return a set of @{term khl}
processes which has the greater (smaller) clock readings. They were
defined with the Hilbert's $\varepsilon$-operator (the indefinite
description operator @{text SOME} in Isabelle) because in this way the
formalization is not fixed to a particular eleccion of the processes's
readings to discards and then the modelization is more general. *}

definition
kmax :: "(process \<Rightarrow> Clocktime) \<Rightarrow> process set \<Rightarrow> process set" where
"kmax f P = (SOME S. S \<subseteq> P \<and> card S = khl \<and>
                (\<forall> i\<in>S. \<forall> j\<in>(P-S). f j <= f i))"

definition
kmin :: "(process \<Rightarrow> Clocktime) \<Rightarrow> process set \<Rightarrow> process set" where
"kmin f P = (SOME S. S \<subseteq> P \<and> card S = khl \<and>
                (\<forall> i\<in>S. \<forall> j\<in>(P-S). f i <= f j))"

text {* With the previus functions we define a new one @{term
reduce}\footnote{The name of this function was taken from
\cite{lynch_cs}.}. This take a function of clock readings and a set of
processes and return de set of readings of the not dicarded
processes. In order to define this function we use the image operator
(@{term "op `"}) of Isabelle.*}

definition
reduce :: "(process \<Rightarrow> Clocktime) \<Rightarrow> process set \<Rightarrow> Clocktime set" where
"reduce f P = f ` (P - (kmax f P \<union> kmin f P))"

text {* And finally the convergence function. This is defined with the
builtin @{term Max} and @{term Min} functions of Isabelle.
*}

definition
cfnl :: "process  \<Rightarrow> (process \<Rightarrow> Clocktime) \<Rightarrow> Clocktime" where
"cfnl p f = (Max (reduce f PR) + Min (reduce f PR)) / 2"

subsection {* Translation Invariance property.*}

subsubsection {* Auxiliary lemmas *}

text {* These lemmas proves the existence of the maximum and minimum
of the image of a set, if the set is finite and not empty. *}

(* The proofs are almost the same one that those of the lemmas @{thm *)
(* [source] ex_Max} and @{thm [source] ex_Min} in the Isabelle's standard *)
(* theories. *)

lemma ex_Maxf:
fixes S and f :: "'a \<Rightarrow> ('b::linorder)"
  assumes fin: "finite S"
  shows "S \<noteq> {} ==> \<exists>m\<in>S. \<forall>s \<in> S. f s \<le> f m"
using fin
proof (induct)
  case empty thus ?case by simp
next
  case (insert x S)
  show ?case
  proof (cases)
    assume "S = {}" thus ?thesis by simp
  next
    assume nonempty: "S \<noteq> {}"
    then obtain m where m: "m\<in>S" "\<forall>s\<in>S. f s \<le> f m"
      using insert by blast
    show ?thesis
    proof (cases)
      assume "f x \<le> f m" thus ?thesis using m by blast
    next
      assume "~ f x \<le> f m" thus ?thesis using m
        by(simp add:linorder_not_le order_less_le)
          (blast intro: order_trans)
    qed
  qed
qed

lemma ex_Minf:
fixes S and f :: "'a \<Rightarrow> ('b::linorder)"
  assumes fin: "finite S"
  shows "S \<noteq> {} ==> \<exists>m\<in>S. \<forall>s \<in> S. f m \<le> f s"
using fin
proof (induct)
  case empty thus ?case by simp
next
  case (insert x S)
  show ?case
  proof (cases)
    assume "S = {}" thus ?thesis by simp
  next
    assume nonempty: "S \<noteq> {}"
    then obtain m where m: "m\<in>S" "\<forall>s\<in>S. f m \<le> f s"
      using insert by blast
    show ?thesis
    proof (cases)
      assume "f m \<le> f x" thus ?thesis using m by blast
    next
      assume "~ f m \<le> f x" thus ?thesis using m
        by(simp add:linorder_not_le order_less_le)
          (blast intro: order_trans)
    qed
  qed
qed

text {* This trivial lemma is needed by the next two. *}

lemma khl_bound: "khl < np"
  using constants_ax by arith

text {* The next two lemmas prove that de functions kmin and kmax
return some values that satisfy their definition. This is not trivial
because we need to prove the existence of these values, according to
the rule of the Hilbert's operator. We will need this lemma many
times because is the only thing that we know about these functions. *}

lemma kmax_prop:
fixes f :: "nat \<Rightarrow> Clocktime"
  shows
"(kmax f PR) \<subseteq> PR \<and> card (kmax f PR) = khl \<and>
                (\<forall>i\<in>(kmax f PR). \<forall>j\<in>PR - (kmax f PR). f j \<le> f i)"
proof-
  have "khl <= np \<longrightarrow>
    (\<exists> S. S \<subseteq> PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f j \<le> f i))"
    ( is "khl <= np \<longrightarrow> ?P khl" )
  proof(induct (khl))
    have "?P 0" by force
    thus "0 <= np \<longrightarrow> ?P 0" ..
  next
    fix n
    assume asm: "n <= np \<longrightarrow> ?P n"
    show "Suc n <= np \<longrightarrow> ?P (Suc n)"
    proof
      assume asm2: "Suc n <= np"
      with asm have "?P n" by simp
      then obtain S where
        SinPR : "S\<subseteq>PR" and
        cardS: "card S = n" and
        HI: "(\<forall>i\<in>S. \<forall>j\<in>PR - S. f j \<le> f i)"
        by blast
      let ?e = "SOME i. i\<in>PR-S \<and>
        (\<forall>j\<in>PR-S. f j \<le> f i)"
      let ?S = "insert  ?e S"
      have "\<exists>i. i\<in>PR-S \<and> (\<forall>j\<in>PR-S. f j \<le> f i)"
      proof-
        from SinPR and finite_subset
        have "finite (PR-S)"
          by auto
        moreover
        from cardS and asm2 SinPR
        have "S\<subset>PR" by auto
        hence "PR-S \<noteq> {}" by auto
        ultimately
        show ?thesis using ex_Maxf by blast
      qed
      hence
        ePRS: "?e \<in> PR-S" and maxH: "(\<forall>j \<in> PR-S. f j \<le> f ?e)"
        by (auto dest!: someI_ex)
      from maxH and HI
      have "(\<forall>i\<in>?S. \<forall>j\<in>PR - ?S. f j \<le> f i)"
        by blast
      moreover
      from SinPR and finite_subset
      cardS and ePRS
      have "card ?S = Suc n"
        by (auto dest: card_insert_disjoint)
      moreover
      have "?S \<subseteq> PR" using SinPR and ePRS by auto
      ultimately
      show "?P (Suc n)" by blast
    qed
  qed
  hence "?P khl" using khl_bound by auto
  then obtain S where
    "S\<le>PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f j \<le> f i)" ..
    thus ?thesis by (unfold kmax_def)
      (rule someI [where P="\<lambda>S. S \<subseteq> PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f j \<le> f i)"])
qed

lemma kmin_prop:
fixes f :: "nat \<Rightarrow> Clocktime"
  shows
"(kmin f PR) \<subseteq> PR \<and> card (kmin f PR) = khl \<and>
                (\<forall>i\<in>(kmin f PR). \<forall>j\<in>PR - (kmin f PR). f i \<le> f j)"
proof-
  have "khl <= np \<longrightarrow>
    (\<exists> S. S \<subseteq> PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f i \<le> f j))"
    ( is "khl <= np \<longrightarrow> ?P khl" )
  proof(induct (khl))
    have "?P 0" by force
    thus "0 <= np \<longrightarrow> ?P 0" ..
  next
    fix n
    assume asm: "n <= np \<longrightarrow> ?P n"
    show "Suc n <= np \<longrightarrow> ?P (Suc n)"
    proof
      assume asm2: "Suc n <= np"
      with asm have "?P n" by simp
      then obtain S where
        SinPR : "S\<subseteq>PR" and
        cardS: "card S = n" and
        HI: "(\<forall>i\<in>S. \<forall>j\<in>PR - S. f i \<le> f j)"
        by blast
      let ?e = "SOME i. i\<in>PR-S \<and>
        (\<forall>j\<in>PR-S. f i \<le> f j)"
      let ?S = "insert  ?e S"
      have "\<exists>i. i\<in>PR-S \<and> (\<forall>j\<in>PR-S. f i \<le> f j)"
      proof-
        from SinPR and finite_subset
        have "finite (PR-S)"
          by auto
        moreover
        from cardS and asm2 SinPR
        have "S\<subset>PR" by auto
        hence "PR-S \<noteq> {}" by auto
        ultimately
        show ?thesis using ex_Minf by blast
      qed
      hence
        ePRS: "?e \<in> PR-S" and minH: "(\<forall>j \<in> PR-S. f ?e \<le> f j)"
        by (auto dest!: someI_ex)
      from minH and  HI
      have "(\<forall>i\<in>?S. \<forall>j\<in>PR - ?S. f i \<le> f j)"
        by blast
      moreover
      from SinPR and finite_subset and
        cardS and ePRS
      have "card ?S = Suc n"
        by (auto dest: card_insert_disjoint)
      moreover
      have "?S \<subseteq> PR" using SinPR and ePRS by auto
      ultimately
      show "?P (Suc n)" by blast
    qed
  qed
  hence "?P khl" using khl_bound by auto
  then obtain S where
    "S\<le>PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f i \<le> f j)" ..
    thus ?thesis by (unfold kmin_def)
      (rule someI [where P="\<lambda>S. S \<subseteq> PR \<and> card S = khl \<and> (\<forall>i\<in>S. \<forall>j\<in>PR - S. f i \<le> f j)"])
qed

text {* The next two lemmas are trivial from the previous ones *}

lemma finite_kmax:
"finite (kmax f PR)"
proof-
  have "finite PR" by auto
  with  kmax_prop and finite_subset show ?thesis
    by blast
qed

lemma finite_kmin:
"finite (kmin f PR)"
proof-
  have "finite PR" by auto
  with  kmin_prop and finite_subset show ?thesis
    by blast
qed

text {* This lemma is necesary because the definition of the
convergence function use the builtin Max and Min. *}

lemma reduce_not_empty:
"reduce f PR \<noteq> {}"
proof-
  from constants_ax have
    "0 < (np - 2 * khl)" by arith
  also
  {
    from kmax_prop kmin_prop
    have "card (kmax f PR) = khl \<and> card (kmin f PR) = khl"
      by blast
    moreover
    from finite_kmax and finite_kmin card_Un_Int[THEN sym]
    have "card (kmax f PR \<union> kmin f PR) +
      card (kmax f PR \<inter> kmin f PR) =
      card (kmax f PR) +  card (kmin f PR)"
      by auto
    ultimately
    have "card (kmax f PR \<union> kmin f PR) <= 2 * khl"
      by auto
  }
  hence
    "... <= card PR - card (kmax f PR \<union> kmin f PR)"
    by simp
  also
  {
    from kmax_prop and kmin_prop have
    "(kmax f PR \<union> kmin f PR) \<subseteq> PR" by blast
  }
  hence
    "... = card (PR-(kmax f PR \<union> kmin f PR))"
    apply (intro card_Diff_subset[THEN sym])
    apply (rule finite_subset)
    by auto
    (* by (intro card_Diff_subset,auto) *)
  finally
  have "0 < card (PR-(kmax f PR \<union> kmin f PR))" .
  hence "(PR-(kmax f PR \<union> kmin f PR)) \<noteq> {}"
    by (intro notI, simp only: card_0_eq, simp)
  thus ?thesis
    by (auto simp add: reduce_def)
qed

text {* The next three are the main lemmas necessary for prove the
Translation Invariance property.*}

lemma reduce_shift:
fixes f :: "nat \<Rightarrow> Clocktime"
  shows
  "f ` (PR - (kmax f PR \<union> kmin f PR)) =
            f ` (PR - (kmax (\<lambda> p. f p + c) PR \<union> kmin (\<lambda> p. f p + c) PR))"
apply (unfold kmin_def kmax_def)
by simp

lemma max_shift:
fixes f :: "nat \<Rightarrow> Clocktime" and S
assumes notEmpFin: "S \<noteq> {}" "finite S"
shows
"Max (f`S) + x = Max ( (\<lambda> p. f p + x) ` S) "
proof-
  from notEmpFin have "f`S \<noteq> {}" and "(\<lambda> p. f p + x) ` S \<noteq> {}"
    by auto
  with notEmpFin have
    "Max (f`S) \<in> f ` S " "Max ((\<lambda> p. f p + x)`S) \<in> (\<lambda> p. f p + x) ` S "
    "(\<forall>fs \<in> (f`S). fs \<le> Max (f`S))"
    "(\<forall>fs \<in> ((\<lambda> p. f p + x)`S). fs \<le> Max ((\<lambda> p. f p + x)`S))"
    by auto
  thus ?thesis by force
qed

lemma min_shift:
fixes f :: "nat \<Rightarrow> Clocktime" and S
assumes notEmpFin: "S \<noteq> {}" "finite S"
shows
"Min (f`S) + x = Min ( (\<lambda> p. f p + x) ` S) "
proof-
  from notEmpFin have "f`S \<noteq> {}" and "(\<lambda> p. f p + x) ` S \<noteq> {}"
    by auto
  with notEmpFin have
    "Min (f`S) \<in> f ` S " "Min ((\<lambda> p. f p + x)`S) \<in> (\<lambda> p. f p + x) ` S "
    "(\<forall>fs \<in> (f`S). Min (f`S) <= fs)"
    "(\<forall>fs \<in> ((\<lambda> p. f p + x)`S). Min ((\<lambda> p. f p + x)`S) <= fs)"
    by auto
  thus ?thesis by force
qed

subsubsection {* Main theorem *}

theorem trans_inv:
fixes f :: "nat \<Rightarrow> Clocktime"
  shows
"cfnl p f + x = cfnl p (\<lambda> p. f p + x)"
proof-
  have "cfnl p (\<lambda> p. f p + x) =
      (Max (reduce (\<lambda> p. f p + x) PR) + Min (reduce (\<lambda> p. f p + x) PR)) / 2"
    by (unfold cfnl_def, simp)
  also
  have "... =
    (Max ((\<lambda> p. f p + x) `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))) +
     Min ((\<lambda> p. f p + x) `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR)))) / 2"
    by (unfold reduce_def, simp)
  also
  have
    "... =
    (Max (f `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))) + x +
     Min (f `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))) + x ) / 2"
  proof-
    have "finite (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))"
      by auto
    moreover
    from reduce_not_empty have
      "PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR) \<noteq> {}"
      by (auto simp add: reduce_def)
    ultimately
    have
      "Max ((\<lambda> p. f p + x) `
       (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR)))
      =
       Max (f `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))) + x"
       and
      "Min ((\<lambda> p. f p + x) `
       (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR)))
      =
       Min (f `
             (PR - (kmax (\<lambda> p. f p + x) PR \<union> kmin (\<lambda> p. f p + x) PR))) + x"
      using max_shift and min_shift
      by auto
    thus ?thesis by auto
  qed
  also
  from reduce_shift
  have
    "... =
    (Max (f `
             (PR - (kmax f  PR \<union> kmin f PR))) + x +
     Min (f `
             (PR - (kmax f PR \<union> kmin f PR))) + x ) / 2"
    by auto
  also
  have "... = ((Max (reduce f PR)+ x) + (Min (reduce f PR) + x)) / 2"
    by (auto simp add: reduce_def)
  also
  have "... = (Max (reduce f PR) + Min (reduce f PR)) / 2 + x"
    by auto
  finally
  show ?thesis by (auto simp add: cfnl_def)
qed

subsection {* Precision Enhancement property *}

text {* An informal proof of this theorem can be found in \cite{miner93} *}

subsubsection {* Auxiliary lemmas *}

text {* This first lemma is most important for prove the
property. This is a consecuence of the @{thm [source] card_Un_Int}
lemma *}

lemma pigeonhole:
assumes
  finitA: "finite A" and
  Bss: "B \<subseteq> A" and Css: "C \<subseteq> A" and
  cardH: "card A + k <= card B + card C"
shows "k <= card (B \<inter> C)"
proof-
  from Bss Css have "B \<union> C \<subseteq> A" by blast
  with finitA have "card (B \<union> C) <= card A"
    by (simp add: card_mono)
  with cardH have
      h: "k <= card B + card C - card (B \<union> C)"
    by arith
  from finitA Bss Css and finite_subset
  have "finite B \<and> finite C" by auto
  thus ?thesis
    using card_Un_Int and h by force
qed

text {*This lemma is a trivial consecuence of the previous one. With
only this lemma we can prove the Precision Enhancement property with
the bound $\pi(x,y) = x + y$. But this bound not satisfy the property
\[ \pi(2\Lambda + 2 \beta\rho, \delta_S + 2\rho(r_{max}+\beta) +
2\Lambda) \leq \delta_S
\] that is used in \cite{shankar92mechanical} for prove the
Schneider's schema. *}

lemma subsets_int:
assumes
  finitA: "finite A" and
  Bss: "B \<subseteq> A" and Css: "C \<subseteq> A" and
  cardH: "card A < card B + card C"
shows
  "B \<inter> C \<noteq> {}"
proof-
  from finitA Bss Css cardH
  have "1 <= card (B \<inter> C)"
    by (auto intro!:  pigeonhole)
  thus ?thesis by auto
qed

text {* This lemma is true because @{term "reduce f PR"} is the image
of @{term "PR-(kmax f PR \<union> kmin f PR)"} by the function @{term f}. *}

lemma exist_reduce:
"\<forall> c \<in> reduce f PR. \<exists> i\<in> PR-(kmax f PR \<union> kmin f PR). f i = c"
proof
fix c assume asm: "c \<in> reduce f PR"
thus "\<exists> i\<in> PR-(kmax f PR \<union> kmin f PR). f i = c"
  by (auto simp add: reduce_def kmax_def kmin_def)
qed

text {* The next three lemmas are consequence of the definition of
@{term reduce}, @{term kmax} and @{term kmin} *}

lemma finite_reduce:
"finite (reduce f PR)"
proof(unfold reduce_def)
  show "finite (f ` (PR - (kmax f PR \<union> kmin f PR)))"
    by auto
qed

lemma kmax_ge:
  "\<forall> i\<in> (kmax f PR). \<forall> r \<in> (reduce f PR). r <= f i "
proof
  fix i assume asm: "i \<in> kmax f PR"
  show "\<forall>r\<in>reduce f PR. r \<le> f i"
  proof
    fix r assume asm2: "r \<in> reduce f PR"
    show "r \<le> f i"
    proof-
      from asm2 and exist_reduce have
        "\<exists> j \<in> PR-(kmax f PR \<union> kmin f PR). f j = r" by blast
      then obtain j
      where fjr:"j \<in> PR-(kmax f PR \<union> kmin f PR) \<and> f j = r"
        by blast
      hence "j \<in> (PR - kmax f PR)"
        by blast
      from this fjr asm
      show ?thesis using kmax_prop
        by auto
    qed
  qed
qed

lemma kmin_le:
  "\<forall> i\<in> (kmin f PR). \<forall> r \<in> (reduce f PR). f i <= r "
proof
  fix i assume asm: "i \<in> kmin f PR"
  show "\<forall>r\<in>reduce f PR. f i \<le> r"
  proof
    fix r assume asm2: "r \<in> reduce f PR"
    show "f i <= r"
    proof-
      from asm2 and exist_reduce have
        "\<exists> j\<in> PR-(kmax f PR \<union> kmin f PR). f j = r" by blast
      then obtain j
      where fjr:"j \<in> PR-(kmax f PR \<union> kmin f PR) \<and> f j = r"
        by blast
      hence "j \<in> (PR - kmin f PR)"
        by blast
      from this fjr asm
      show ?thesis using kmin_prop
        by auto
    qed
  qed
qed

text {* The next lemma is used for prove the Precision Enhancement
property. This has been proved in ICS. The proof is in the appendix
\ref{sec:abs_distrib_mult}.  This cannot be prove by a simple @{text
arith} or @{text auto} tactic. *}

text{* This lemma is true also with @{text "0 <= c"} !! *}

lemma abs_distrib_div:
  "0 < (c::real)  \<Longrightarrow> \<bar>a / c - b / c\<bar> = \<bar>a - b\<bar> / c"
proof-
  assume ch: "0<c"
  {
    fix d :: real
    assume dh: "0<=d"
    have "a * d - b * d = (a - b) * d "
      by (simp add: algebra_simps)
    hence "\<bar>a * d - b * d\<bar> = \<bar>(a - b) * d\<bar>"
      by simp
    also with dh have
      "... = \<bar>a - b\<bar> * d"
      by (simp add: abs_mult)
    finally
      have "\<bar>a * d - b * d\<bar> = \<bar>a - b\<bar> * d"
        .
    (* This sublemma is solved by ICS, file: abs_distrib_mult.ics *)
    (* It is not solved nor
       by (auto simp add: distrib_right diff_minus)(arith)
        in Isabelle  *)
  }
  with ch and divide_inverse show ?thesis
    by (auto simp add: divide_inverse)
qed

text {* The next three lemmas are about the existence of bounds of the
values @{term "Max (reduce f PR)"} and @{term "Min (reduce f PR)"}. These
are used in the proof of the main property. *}

lemma uboundmax:
assumes
  hC: "C \<subseteq> PR" and
  hCk: "np <= card C + khl"
shows
  "\<exists> i\<in>C. Max (reduce f PR) <= f i"
proof-
  from reduce_not_empty and finite_reduce
  have maxrinr: "Max (reduce f PR) \<in> reduce f PR"
    by simp
  with exist_reduce
  have "\<exists> i\<in> PR-(kmax f PR \<union> kmin f PR). f i = Max (reduce f PR)"
    by simp
  then obtain pmax where
    pmax_in_reduc: "pmax \<in> PR-(kmax f PR \<union> kmin f PR)" and
    fpmax_ismax: "f pmax = Max (reduce f PR)" ..
  hence "C \<inter> insert pmax (kmax f PR)  \<noteq> {}"
  proof-
    from kmax_prop and pmax_in_reduc
      and finite_kmax and hCk  have
      "card PR < card C + card (insert pmax (kmax f PR))"
      by simp
    moreover
    from pmax_in_reduc and kmax_prop
    have "insert pmax (kmax f PR) \<subseteq> PR" by blast
    moreover
    note hC
    ultimately
    show ?thesis
      using subsets_int[of PR C "insert pmax (kmax f PR)"]
      by simp
  qed
  hence res: "\<exists> i\<in>C. i=pmax \<or> i \<in> kmax f PR" by blast
  then obtain i where
    iinC: "i\<in>C" and altern: "i=pmax \<or> i \<in> kmax f PR" ..
  thus ?thesis
  proof(cases "i=pmax")
    case True
    with iinC fpmax_ismax show ?thesis by force
  next
    case False
    with altern maxrinr fpmax_ismax kmax_ge
    have "f pmax <= f i" by simp
    with iinC fpmax_ismax show ?thesis by auto
  qed
qed

lemma lboundmin:
assumes
  hC: "C \<subseteq> PR" and
  hCk: "np <= card C + khl"
shows
  "\<exists> i\<in>C. f i <= Min (reduce f PR)"
proof-
  from reduce_not_empty and finite_reduce
  have minrinr: "Min (reduce f PR) \<in> reduce f PR"
    by simp
  with exist_reduce
  have "\<exists> i\<in> PR-(kmax f PR \<union> kmin f PR). f i = Min (reduce f PR)"
    by simp
  then obtain pmin where
    pmin_in_reduc: "pmin \<in> PR-(kmax f PR \<union> kmin f PR)" and
    fpmin_ismin: "f pmin = Min (reduce f PR)" ..
  hence "C \<inter> insert pmin (kmin f PR)  \<noteq> {}"
  proof-
    from kmin_prop and pmin_in_reduc
      and finite_kmin and hCk  have
      "card PR < card C + card (insert pmin (kmin f PR))"
      by simp
    moreover
    from pmin_in_reduc and kmin_prop
    have "insert pmin (kmin f PR) \<subseteq> PR" by blast
    moreover
    note hC
    ultimately
    show ?thesis
      using subsets_int[of PR C "insert pmin (kmin f PR)"]
      by simp
  qed
  hence res: "\<exists> i\<in>C. i=pmin \<or> i \<in> kmin f PR" by blast
  then obtain i where
    iinC: "i\<in>C" and altern: "i=pmin \<or> i \<in> kmin f PR" ..
  thus ?thesis
  proof(cases "i=pmin")
    case True
    with iinC fpmin_ismin show ?thesis by force
  next
    case False
    with altern minrinr fpmin_ismin kmin_le
    have "f i <= f pmin" by simp
    with iinC fpmin_ismin show ?thesis by auto
  qed
qed

lemma same_bound:
assumes
  hC: "C \<subseteq> PR" and
  hCk: "np <= card C + khl" and
  hnk: "3 * khl < np"
shows
  "\<exists> i\<in>C. Min (reduce f PR) <= f i \<and> g i <= Max (reduce g PR) "
proof-
  have b1: "khl + 1 <= card (C \<inter> (PR - kmin f PR))"
  proof(rule pigeonhole)
    show "finite PR" by simp
  next
    show "C \<subseteq> PR" by fact
  next
    show "PR - kmin f PR \<subseteq> PR" by blast
  next
    show "card PR + (khl + 1) \<le> card C + card (PR - kmin f PR)"
    proof-
      from hnk and hCk have
        "np + khl < np + card C - khl" by arith
      also
      from kmin_prop
      have "... = np + card C - card (kmin f PR)"
        by auto
      also
      have "... = card C + (card PR - card (kmin f PR))"
      proof-
        from kmin_prop have
          "card (kmin f PR) <= card PR"
          by (intro card_mono, auto)
        thus ?thesis by (simp)
      qed
      also
      from kmin_prop
      have "... = card C +  card (PR - kmin f PR)"
      proof-
        from kmin_prop and finite_kmin have
          "card PR - card (kmin f PR) =  card (PR - kmin f PR)"
          by (intro card_Diff_subset[THEN sym])(auto)
        thus ?thesis by auto
      qed
      finally
      show ?thesis
        by (simp)
    qed
  qed

  have "C \<inter> (PR - kmin f PR) \<inter> (PR - kmax g PR) \<noteq> {}"
  proof(intro subsets_int)
    show "finite PR" by simp
  next
    show "C \<inter> (PR - kmin f PR) \<subseteq> PR"
      by blast
  next
    show "PR - kmax g PR \<subseteq> PR"
      by blast
  next
    show "card PR <
      card (C \<inter> (PR - kmin f PR)) + card (PR - kmax g PR)"
    proof-
      from kmax_prop and finite_kmax
      have "card (PR - kmax g PR)= card PR - card (kmax g PR) "
        by  (intro card_Diff_subset, auto)
      with kmax_prop have
        "card (PR - kmax g PR) = card PR - khl" by simp
      with b1
      show ?thesis by arith
    qed
  qed

  hence
    "\<exists> i. i \<in> C \<and> i \<in> (PR - kmin f PR) \<and> i \<in> (PR - kmax g PR)"
    by blast
  then obtain i where
    in_C: "i \<in> C" and
    not_in_kmin: "i \<in> (PR - kmin f PR)" and
    not_in_kmax: "i \<in> (PR - kmax g PR)" by blast
  have "Min (reduce f PR) <= f i"
  proof(cases "i \<in> kmax f PR")
    case True
    from reduce_not_empty and finite_reduce have
      " Min (reduce f PR) \<in> reduce f PR" by auto
    with True show ?thesis
      using kmax_ge by blast
  next
    case False
    with not_in_kmin
    have "i \<in> PR - (kmax f PR \<union> kmin f PR)"
      by blast
    with reduce_def have "f i \<in> reduce f PR"
      by auto
    with reduce_not_empty and finite_reduce
    show ?thesis by auto
  qed
  moreover
  have "g i <= Max (reduce g PR)"
  proof(cases "i \<in> kmin g PR")
    case True
    from reduce_not_empty and finite_reduce have
      " Max (reduce g PR) \<in> reduce g PR" by auto
    with True show ?thesis
      using kmin_le by blast
  next
    case False
    with not_in_kmax
    have "i \<in> PR - (kmax g PR \<union> kmin g PR)"
      by blast
    with reduce_def have "g i \<in> reduce g PR"
      by auto
    with reduce_not_empty and finite_reduce
    show ?thesis by auto
  qed
  moreover
  note in_C
  ultimately
  show ?thesis by blast
qed

subsubsection {* Main theorem *}

text {* The most part of this theorem can be proved with CVC-lite
using the three previous lemmas (appendix \ref{sec:bound_prec_enh}).*}

theorem prec_enh:
assumes
  hC: "C \<subseteq> PR" and
  hCF: "np - nF <= card C" and
  hFn: "3 * nF < np" and
  hFk: "nF = khl" and
  hbx: "\<forall> l\<in>C. \<bar>f l - g l\<bar> <= x" and
  hby1: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hby2: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>g l - g m\<bar> <= y" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C"
shows "\<bar> cfnl p f - cfnl q g \<bar> <= y / 2 + x"
proof-
  from hCF and hFk
  have hCk: "np <= card C + khl" by arith
  from hFn and hFk
  have hnk: "3 * khl < np"  by arith
  let    ?maxf = "Max (reduce f PR)"
    and  ?minf = "Min (reduce f PR)"
    and  ?maxg = "Max (reduce g PR)"
    and  ?ming = "Min (reduce g PR)"
  from abs_distrib_div
  have "\<bar>cfnl p f - cfnl q g\<bar> =
    \<bar>?maxf + ?minf  +  - ?maxg + - ?ming\<bar> / 2"
    by (unfold cfnl_def) simp
  moreover
  have "\<bar>?maxf + ?minf  +  - ?maxg + - ?ming\<bar> <= y + 2 * x"
    -- {* The rest of the property can be proved by CVC-lite
           (see appendix \ref{sec:bound_prec_enh}) *}
  proof ( cases "0 <= ?maxf + ?minf  +  - ?maxg + - ?ming")
    case True
    hence
    "\<bar>?maxf + ?minf  +  - ?maxg + - ?ming\<bar> =
      ?maxf + ?minf  +  - ?maxg + - ?ming" by arith
    moreover
    from uboundmax hC hCk
    obtain mxf
      where mxfinC: "mxf\<in>C" and
            maxf: "?maxf <= f mxf" by blast
    moreover
    from lboundmin hC hCk
    obtain mng
      where mnginC: "mng\<in>C" and
            ming: "g mng <= ?ming" by blast
    moreover
    from same_bound hC hCk hnk
    obtain mxn
      where mxninC: "mxn\<in>C" and
            mxnf: "?minf  \<le> f mxn" and
            mxng: "g mxn \<le> ?maxg" by blast
    ultimately
    have
      "\<bar> ?maxf + ?minf  +  - ?maxg + - ?ming\<bar> <=
      (f mxf + - g mng) + (f mxn  +  - g mxn)" by arith
    also
    from  mxninC hbx abs_le_D1
    have
      "... <= (f mxf + - g mng) + x"
      by auto
    also
    have
      "... = (f mxf + - f mng ) + ( f mng + - g mng) + x"
      by arith
    also
    have "... <= y + ( f mng + - g mng) + x"
    proof-
      from  mxfinC mnginC hby1 abs_le_D1
      have "f mxf + - f mng <= y"
        by auto
      thus ?thesis
        by auto
    qed
    also
    from  mnginC hbx abs_le_D1
    have "... <= y + 2 * x"
      by auto
    finally
    show ?thesis .
  next
    case False
    hence
    "\<bar>?maxf + ?minf  +  - ?maxg + - ?ming\<bar> =
      ?maxg + ?ming  +  - ?maxf + - ?minf" by arith
    moreover
    from uboundmax hC hCk
    obtain mxg
      where mxginC: "mxg\<in>C" and
            maxg: "?maxg <= g mxg" by blast
    moreover
    from lboundmin hC hCk
    obtain mnf
      where mnfinC: "mnf\<in>C" and
            minf: "f mnf <= ?minf" by blast
    moreover
    from same_bound hC hCk hnk
    obtain mxn
      where mxninC: "mxn\<in>C" and
            mxnf: "?ming  \<le> g mxn" and
            mxng: "f mxn \<le> ?maxf" by blast
    ultimately
    have
      "\<bar> ?maxf + ?minf  +  - ?maxg + - ?ming\<bar> <=
      (g mxg + - f mnf) + (g mxn  +  - f mxn)" by arith
    also
    from  mxninC hbx
    have "... <= (g mxg + - f mnf) + x"
        by (auto dest!: abs_le_D2)
    also
    have
      "... = (g mxg + - g mnf ) + ( g mnf + - f mnf) + x"
      by arith
    also
    have "... <= y + ( g mnf + - f mnf) + x"
    proof-
      from  mxginC mnfinC hby2 abs_le_D1
      have "g mxg + - g mnf <= y"
        by auto
      thus ?thesis
        by auto
    qed
    also
    from  mnfinC hbx
    have "... <= y + 2 * x"
      by (auto dest!: abs_le_D2)
    finally
    show ?thesis .
  qed
  ultimately
  show ?thesis
    by simp
qed

subsection {* Accuracy Preservation property *}

text {* No new lemmas are needed for prove this property. The bound
has been found using the lemmas @{thm [source] uboundmax} and @{thm
[source] lboundmin} *}

text {* This theorem can be proved with ICS and CVC-lite assuming
those lemmas (see appendix \ref{sec:accur_pres}).  *}

theorem accur_pres:
assumes
  hC: "C \<subseteq> PR" and
  hCF: "np - nF <= card C" and
  hFk: "nF = khl" and
  hby: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hqC: "q\<in>C"
shows "\<bar> cfnl p f - f q \<bar> <= y"
proof-
  from hCF and hFk
  have npleCk: "np <= card C + khl" by arith
  show ?thesis
  proof(cases "f q <= cfnl p f")
    case True
    from npleCk hC and  uboundmax
    have "\<exists> i\<in>C. Max (reduce f PR) <= f i"
      by auto
    then obtain pi where
      hpiC: "pi \<in> C" and
      fpiGeMax: "Max (reduce f PR) <= f pi" by blast
    from reduce_not_empty
    have "Min (reduce f PR) <= Max (reduce f PR)"
      by (auto simp add: reduce_def)
    with fpiGeMax have
      cfnlLefpi: "cfnl p f <= f pi"
      by (auto simp add: cfnl_def)
    with True have
      "\<bar> cfnl p f - f q \<bar> <= \<bar> f pi - f q \<bar>"
      by arith
    with hpiC and hqC and hby show ?thesis
      by force
  next
    case False
    from npleCk hC and lboundmin
    have "\<exists> i\<in>C. f i <= Min (reduce f PR)"
      by auto
    then obtain qi where
      hqiC: "qi \<in> C" and
      fqiLeMax: "f qi <= Min (reduce f PR)" by blast
    from reduce_not_empty
    have "Min (reduce f PR) <= Max (reduce f PR)"
      by (auto simp add: reduce_def)
    with fqiLeMax
    have "f qi <= cfnl p f"
      by (auto simp add: cfnl_def)
    with False have
      "\<bar> cfnl p f - f q \<bar> <= \<bar> f qi - f q \<bar>"
      by arith
    with hqiC and hqC and hby show ?thesis
      by force
  qed
qed

end


(*  Author:     Manuel Eberl (TU München)

Defines the set of permutations of a given multiset (or set), i.e. the set of all lists whose
entries correspond to the multiset (resp. set).
*)

section \<open>Permutations of a Multiset\<close>

theory Multiset_Permutations
imports
  Complex_Main
  Permutations
begin

(* TODO Move *)
lemma mset_tl: "xs \<noteq> [] \<Longrightarrow> mset (tl xs) = mset xs - {#hd xs#}"
  by (cases xs) simp_all

lemma mset_set_image_inj:
  assumes "inj_on f A"
  shows   "mset_set (f ` A) = image_mset f (mset_set A)"
proof (cases "finite A")
  case True
  from this and assms show ?thesis by (induction A) auto
qed (insert assms, simp add: finite_image_iff)

lemma multiset_remove_induct [case_names empty remove]:
  assumes "P {#}" "\<And>A. A \<noteq> {#} \<Longrightarrow> (\<And>x. x \<in># A \<Longrightarrow> P (A - {#x#})) \<Longrightarrow> P A"
  shows   "P A"
proof (induction A rule: full_multiset_induct)
  case (less A)
  hence IH: "P B" if "B \<subset># A" for B using that by blast
  show ?case
  proof (cases "A = {#}")
    case True
    thus ?thesis by (simp add: assms)
  next
    case False
    hence "P (A - {#x#})" if "x \<in># A" for x
      using that by (intro IH) (simp add: mset_subset_diff_self)
    from False and this show "P A" by (rule assms)
  qed
qed

lemma map_list_bind: "map g (List.bind xs f) = List.bind xs (map g \<circ> f)"
  by (simp add: List.bind_def map_concat)

lemma mset_eq_mset_set_imp_distinct:
  "finite A \<Longrightarrow> mset_set A = mset xs \<Longrightarrow> distinct xs"
proof (induction xs arbitrary: A)
  case (Cons x xs A)
  from Cons.prems(2) have "x \<in># mset_set A" by simp
  with Cons.prems(1) have [simp]: "x \<in> A" by simp
  from Cons.prems have "x \<notin># mset_set (A - {x})" by simp
  also from Cons.prems have "mset_set (A - {x}) = mset_set A - {#x#}"
    by (subst mset_set_Diff) simp_all
  also have "mset_set A = mset (x#xs)" by (simp add: Cons.prems)
  also have "\<dots> - {#x#} = mset xs" by simp
  finally have [simp]: "x \<notin> set xs" by (simp add: in_multiset_in_set)
  from Cons.prems show ?case by (auto intro!: Cons.IH[of "A - {x}"] simp: mset_set_Diff)
qed simp_all
(* END TODO *)

subsection \<open>Permutations of a multiset\<close>

definition permutations_of_multiset :: "'a multiset \<Rightarrow> 'a list set" where
  "permutations_of_multiset A = {xs. mset xs = A}"

lemma permutations_of_multisetI: "mset xs = A \<Longrightarrow> xs \<in> permutations_of_multiset A"
  by (simp add: permutations_of_multiset_def)

lemma permutations_of_multisetD: "xs \<in> permutations_of_multiset A \<Longrightarrow> mset xs = A"
  by (simp add: permutations_of_multiset_def)

lemma permutations_of_multiset_Cons_iff:
  "x # xs \<in> permutations_of_multiset A \<longleftrightarrow> x \<in># A \<and> xs \<in> permutations_of_multiset (A - {#x#})"
  by (auto simp: permutations_of_multiset_def)

lemma permutations_of_multiset_empty [simp]: "permutations_of_multiset {#} = {[]}"
  unfolding permutations_of_multiset_def by simp

lemma permutations_of_multiset_nonempty:
  assumes nonempty: "A \<noteq> {#}"
  shows   "permutations_of_multiset A =
             (\<Union>x\<in>set_mset A. ((#) x) ` permutations_of_multiset (A - {#x#}))" (is "_ = ?rhs")
proof safe
  fix xs assume "xs \<in> permutations_of_multiset A"
  hence mset_xs: "mset xs = A" by (simp add: permutations_of_multiset_def)
  hence "xs \<noteq> []" by (auto simp: nonempty)
  then obtain x xs' where xs: "xs = x # xs'" by (cases xs) simp_all
  with mset_xs have "x \<in> set_mset A" "xs' \<in> permutations_of_multiset (A - {#x#})"
    by (auto simp: permutations_of_multiset_def)
  with xs show "xs \<in> ?rhs" by auto
qed (auto simp: permutations_of_multiset_def)

lemma permutations_of_multiset_singleton [simp]: "permutations_of_multiset {#x#} = {[x]}"
  by (simp add: permutations_of_multiset_nonempty)

lemma permutations_of_multiset_doubleton:
  "permutations_of_multiset {#x,y#} = {[x,y], [y,x]}"
  by (simp add: permutations_of_multiset_nonempty insert_commute)

lemma rev_permutations_of_multiset [simp]:
  "rev ` permutations_of_multiset A = permutations_of_multiset A"
proof
  have "rev ` rev ` permutations_of_multiset A \<subseteq> rev ` permutations_of_multiset A"
    unfolding permutations_of_multiset_def by auto
  also have "rev ` rev ` permutations_of_multiset A = permutations_of_multiset A"
    by (simp add: image_image)
  finally show "permutations_of_multiset A \<subseteq> rev ` permutations_of_multiset A" .
next
  show "rev ` permutations_of_multiset A \<subseteq> permutations_of_multiset A"
    unfolding permutations_of_multiset_def by auto
qed

lemma length_finite_permutations_of_multiset:
  "xs \<in> permutations_of_multiset A \<Longrightarrow> length xs = size A"
  by (auto simp: permutations_of_multiset_def)

lemma permutations_of_multiset_lists: "permutations_of_multiset A \<subseteq> lists (set_mset A)"
  by (auto simp: permutations_of_multiset_def)

lemma finite_permutations_of_multiset [simp]: "finite (permutations_of_multiset A)"
proof (rule finite_subset)
  show "permutations_of_multiset A \<subseteq> {xs. set xs \<subseteq> set_mset A \<and> length xs = size A}"
    by (auto simp: permutations_of_multiset_def)
  show "finite {xs. set xs \<subseteq> set_mset A \<and> length xs = size A}"
    by (rule finite_lists_length_eq) simp_all
qed

lemma permutations_of_multiset_not_empty [simp]: "permutations_of_multiset A \<noteq> {}"
proof -
  from ex_mset[of A] obtain xs where "mset xs = A" ..
  thus ?thesis by (auto simp: permutations_of_multiset_def)
qed

lemma permutations_of_multiset_image:
  "permutations_of_multiset (image_mset f A) = map f ` permutations_of_multiset A"
proof safe
  fix xs assume A: "xs \<in> permutations_of_multiset (image_mset f A)"
  from ex_mset[of A] obtain ys where ys: "mset ys = A" ..
  with A have "mset xs = mset (map f ys)"
    by (simp add: permutations_of_multiset_def)
  then obtain \<sigma> where \<sigma>: "\<sigma> permutes {..<length (map f ys)}" "permute_list \<sigma> (map f ys) = xs"
    by (rule mset_eq_permutation)
  with ys have "xs = map f (permute_list \<sigma> ys)"
    by (simp add: permute_list_map)
  moreover from \<sigma> ys have "permute_list \<sigma> ys \<in> permutations_of_multiset A"
    by (simp add: permutations_of_multiset_def)
  ultimately show "xs \<in> map f ` permutations_of_multiset A" by blast
qed (auto simp: permutations_of_multiset_def)

subsection \<open>Cardinality of permutations\<close>

text \<open>
  In this section, we prove some basic facts about the number of permutations of a multiset.
\<close>

context
begin

private lemma multiset_prod_fact_insert:
  "(\<Prod>y\<in>set_mset (A+{#x#}). fact (count (A+{#x#}) y)) =
     (count A x + 1) * (\<Prod>y\<in>set_mset A. fact (count A y))"
proof -
  have "(\<Prod>y\<in>set_mset (A+{#x#}). fact (count (A+{#x#}) y)) =
          (\<Prod>y\<in>set_mset (A+{#x#}). (if y = x then count A x + 1 else 1) * fact (count A y))"
    by (intro prod.cong) simp_all
  also have "\<dots> = (count A x + 1) * (\<Prod>y\<in>set_mset (A+{#x#}). fact (count A y))"
    by (simp add: prod.distrib)
  also have "(\<Prod>y\<in>set_mset (A+{#x#}). fact (count A y)) = (\<Prod>y\<in>set_mset A. fact (count A y))"
    by (intro prod.mono_neutral_right) (auto simp: not_in_iff)
  finally show ?thesis .
qed

private lemma multiset_prod_fact_remove:
  "x \<in># A \<Longrightarrow> (\<Prod>y\<in>set_mset A. fact (count A y)) =
                   count A x * (\<Prod>y\<in>set_mset (A-{#x#}). fact (count (A-{#x#}) y))"
  using multiset_prod_fact_insert[of "A - {#x#}" x] by simp

lemma card_permutations_of_multiset_aux:
  "card (permutations_of_multiset A) * (\<Prod>x\<in>set_mset A. fact (count A x)) = fact (size A)"
proof (induction A rule: multiset_remove_induct)
  case (remove A)
  have "card (permutations_of_multiset A) =
          card (\<Union>x\<in>set_mset A. (#) x ` permutations_of_multiset (A - {#x#}))"
    by (simp add: permutations_of_multiset_nonempty remove.hyps)
  also have "\<dots> = (\<Sum>x\<in>set_mset A. card (permutations_of_multiset (A - {#x#})))"
    by (subst card_UN_disjoint) (auto simp: card_image)
  also have "\<dots> * (\<Prod>x\<in>set_mset A. fact (count A x)) =
               (\<Sum>x\<in>set_mset A. card (permutations_of_multiset (A - {#x#})) *
                 (\<Prod>y\<in>set_mset A. fact (count A y)))"
    by (subst sum_distrib_right) simp_all
  also have "\<dots> = (\<Sum>x\<in>set_mset A. count A x * fact (size A - 1))"
  proof (intro sum.cong refl)
    fix x assume x: "x \<in># A"
    have "card (permutations_of_multiset (A - {#x#})) * (\<Prod>y\<in>set_mset A. fact (count A y)) =
            count A x * (card (permutations_of_multiset (A - {#x#})) *
              (\<Prod>y\<in>set_mset (A - {#x#}). fact (count (A - {#x#}) y)))" (is "?lhs = _")
      by (subst multiset_prod_fact_remove[OF x]) simp_all
    also note remove.IH[OF x]
    also from x have "size (A - {#x#}) = size A - 1" by (simp add: size_Diff_submset)
    finally show "?lhs = count A x * fact (size A - 1)" .
  qed
  also have "(\<Sum>x\<in>set_mset A. count A x * fact (size A - 1)) =
                size A * fact (size A - 1)"
    by (simp add: sum_distrib_right size_multiset_overloaded_eq)
  also from remove.hyps have "\<dots> = fact (size A)"
    by (cases "size A") auto
  finally show ?case .
qed simp_all

theorem card_permutations_of_multiset:
  "card (permutations_of_multiset A) = fact (size A) div (\<Prod>x\<in>set_mset A. fact (count A x))"
  "(\<Prod>x\<in>set_mset A. fact (count A x) :: nat) dvd fact (size A)"
  by (simp_all flip: card_permutations_of_multiset_aux[of A])

lemma card_permutations_of_multiset_insert_aux:
  "card (permutations_of_multiset (A + {#x#})) * (count A x + 1) =
      (size A + 1) * card (permutations_of_multiset A)"
proof -
  note card_permutations_of_multiset_aux[of "A + {#x#}"]
  also have "fact (size (A + {#x#})) = (size A + 1) * fact (size A)" by simp
  also note multiset_prod_fact_insert[of A x]
  also note card_permutations_of_multiset_aux[of A, symmetric]
  finally have "card (permutations_of_multiset (A + {#x#})) * (count A x + 1) *
                    (\<Prod>y\<in>set_mset A. fact (count A y)) =
                (size A + 1) * card (permutations_of_multiset A) *
                    (\<Prod>x\<in>set_mset A. fact (count A x))" by (simp only: mult_ac)
  thus ?thesis by (subst (asm) mult_right_cancel) simp_all
qed

lemma card_permutations_of_multiset_remove_aux:
  assumes "x \<in># A"
  shows   "card (permutations_of_multiset A) * count A x =
             size A * card (permutations_of_multiset (A - {#x#}))"
proof -
  from assms have A: "A - {#x#} + {#x#} = A" by simp
  from assms have B: "size A = size (A - {#x#}) + 1"
    by (subst A [symmetric], subst size_union) simp
  show ?thesis
    using card_permutations_of_multiset_insert_aux[of "A - {#x#}" x, unfolded A] assms
    by (simp add: B)
qed

lemma real_card_permutations_of_multiset_remove:
  assumes "x \<in># A"
  shows   "real (card (permutations_of_multiset (A - {#x#}))) =
             real (card (permutations_of_multiset A) * count A x) / real (size A)"
  using assms by (subst card_permutations_of_multiset_remove_aux[OF assms]) auto

lemma real_card_permutations_of_multiset_remove':
  assumes "x \<in># A"
  shows   "real (card (permutations_of_multiset A)) =
             real (size A * card (permutations_of_multiset (A - {#x#}))) / real (count A x)"
  using assms by (subst card_permutations_of_multiset_remove_aux[OF assms, symmetric]) simp

end

subsection \<open>Permutations of a set\<close>

definition permutations_of_set :: "'a set \<Rightarrow> 'a list set" where
  "permutations_of_set A = {xs. set xs = A \<and> distinct xs}"

lemma permutations_of_set_altdef:
  "finite A \<Longrightarrow> permutations_of_set A = permutations_of_multiset (mset_set A)"
  by (auto simp add: permutations_of_set_def permutations_of_multiset_def mset_set_set
        in_multiset_in_set [symmetric] mset_eq_mset_set_imp_distinct)

lemma permutations_of_setI [intro]:
  assumes "set xs = A" "distinct xs"
  shows   "xs \<in> permutations_of_set A"
  using assms unfolding permutations_of_set_def by simp

lemma permutations_of_setD:
  assumes "xs \<in> permutations_of_set A"
  shows   "set xs = A" "distinct xs"
  using assms unfolding permutations_of_set_def by simp_all

lemma permutations_of_set_lists: "permutations_of_set A \<subseteq> lists A"
  unfolding permutations_of_set_def by auto

lemma permutations_of_set_empty [simp]: "permutations_of_set {} = {[]}"
  by (auto simp: permutations_of_set_def)

lemma UN_set_permutations_of_set [simp]:
  "finite A \<Longrightarrow> (\<Union>xs\<in>permutations_of_set A. set xs) = A"
  using finite_distinct_list by (auto simp: permutations_of_set_def)

lemma permutations_of_set_infinite:
  "\<not>finite A \<Longrightarrow> permutations_of_set A = {}"
  by (auto simp: permutations_of_set_def)

lemma permutations_of_set_nonempty:
  "A \<noteq> {} \<Longrightarrow> permutations_of_set A =
                  (\<Union>x\<in>A. (\<lambda>xs. x # xs) ` permutations_of_set (A - {x}))"
  by (cases "finite A")
     (simp_all add: permutations_of_multiset_nonempty mset_set_empty_iff mset_set_Diff
                    permutations_of_set_altdef permutations_of_set_infinite)

lemma permutations_of_set_singleton [simp]: "permutations_of_set {x} = {[x]}"
  by (subst permutations_of_set_nonempty) auto

lemma permutations_of_set_doubleton:
  "x \<noteq> y \<Longrightarrow> permutations_of_set {x,y} = {[x,y], [y,x]}"
  by (subst permutations_of_set_nonempty)
     (simp_all add: insert_Diff_if insert_commute)

lemma rev_permutations_of_set [simp]:
  "rev ` permutations_of_set A = permutations_of_set A"
  by (cases "finite A") (simp_all add: permutations_of_set_altdef permutations_of_set_infinite)

lemma length_finite_permutations_of_set:
  "xs \<in> permutations_of_set A \<Longrightarrow> length xs = card A"
  by (auto simp: permutations_of_set_def distinct_card)

lemma finite_permutations_of_set [simp]: "finite (permutations_of_set A)"
  by (cases "finite A") (simp_all add: permutations_of_set_infinite permutations_of_set_altdef)

lemma permutations_of_set_empty_iff [simp]:
  "permutations_of_set A = {} \<longleftrightarrow> \<not>finite A"
  unfolding permutations_of_set_def using finite_distinct_list[of A] by auto

lemma card_permutations_of_set [simp]:
  "finite A \<Longrightarrow> card (permutations_of_set A) = fact (card A)"
  by (simp add: permutations_of_set_altdef card_permutations_of_multiset del: One_nat_def)

lemma permutations_of_set_image_inj:
  assumes inj: "inj_on f A"
  shows   "permutations_of_set (f ` A) = map f ` permutations_of_set A"
  by (cases "finite A")
     (simp_all add: permutations_of_set_infinite permutations_of_set_altdef
                    permutations_of_multiset_image mset_set_image_inj inj finite_image_iff)

lemma permutations_of_set_image_permutes:
  "\<sigma> permutes A \<Longrightarrow> map \<sigma> ` permutations_of_set A = permutations_of_set A"
  by (subst permutations_of_set_image_inj [symmetric])
     (simp_all add: permutes_inj_on permutes_image)

subsection \<open>Code generation\<close>

text \<open>
  First, we give code an implementation for permutations of lists.
\<close>

declare length_remove1 [termination_simp]

fun permutations_of_list_impl where
  "permutations_of_list_impl xs = (if xs = [] then [[]] else
     List.bind (remdups xs) (\<lambda>x. map ((#) x) (permutations_of_list_impl (remove1 x xs))))"

fun permutations_of_list_impl_aux where
  "permutations_of_list_impl_aux acc xs = (if xs = [] then [acc] else
     List.bind (remdups xs) (\<lambda>x. permutations_of_list_impl_aux (x#acc) (remove1 x xs)))"

declare permutations_of_list_impl_aux.simps [simp del]
declare permutations_of_list_impl.simps [simp del]

lemma permutations_of_list_impl_Nil [simp]:
  "permutations_of_list_impl [] = [[]]"
  by (simp add: permutations_of_list_impl.simps)

lemma permutations_of_list_impl_nonempty:
  "xs \<noteq> [] \<Longrightarrow> permutations_of_list_impl xs =
     List.bind (remdups xs) (\<lambda>x. map ((#) x) (permutations_of_list_impl (remove1 x xs)))"
  by (subst permutations_of_list_impl.simps) simp_all

lemma set_permutations_of_list_impl:
  "set (permutations_of_list_impl xs) = permutations_of_multiset (mset xs)"
  by (induction xs rule: permutations_of_list_impl.induct)
     (subst permutations_of_list_impl.simps,
      simp_all add: permutations_of_multiset_nonempty set_list_bind)

lemma distinct_permutations_of_list_impl:
  "distinct (permutations_of_list_impl xs)"
  by (induction xs rule: permutations_of_list_impl.induct,
      subst permutations_of_list_impl.simps)
     (auto intro!: distinct_list_bind simp: distinct_map o_def disjoint_family_on_def)

lemma permutations_of_list_impl_aux_correct':
  "permutations_of_list_impl_aux acc xs =
     map (\<lambda>xs. rev xs @ acc) (permutations_of_list_impl xs)"
  by (induction acc xs rule: permutations_of_list_impl_aux.induct,
      subst permutations_of_list_impl_aux.simps, subst permutations_of_list_impl.simps)
     (auto simp: map_list_bind intro!: list_bind_cong)

lemma permutations_of_list_impl_aux_correct:
  "permutations_of_list_impl_aux [] xs = map rev (permutations_of_list_impl xs)"
  by (simp add: permutations_of_list_impl_aux_correct')

lemma distinct_permutations_of_list_impl_aux:
  "distinct (permutations_of_list_impl_aux acc xs)"
  by (simp add: permutations_of_list_impl_aux_correct' distinct_map
        distinct_permutations_of_list_impl inj_on_def)

lemma set_permutations_of_list_impl_aux:
  "set (permutations_of_list_impl_aux [] xs) = permutations_of_multiset (mset xs)"
  by (simp add: permutations_of_list_impl_aux_correct set_permutations_of_list_impl)

declare set_permutations_of_list_impl_aux [symmetric, code]

value [code] "permutations_of_multiset {#1,2,3,4::int#}"

text \<open>
  Now we turn to permutations of sets. We define an auxiliary version with an
  accumulator to avoid having to map over the results.
\<close>
function permutations_of_set_aux where
  "permutations_of_set_aux acc A =
     (if \<not>finite A then {} else if A = {} then {acc} else
        (\<Union>x\<in>A. permutations_of_set_aux (x#acc) (A - {x})))"
by auto
termination by (relation "Wellfounded.measure (card \<circ> snd)") (simp_all add: card_gt_0_iff)

lemma permutations_of_set_aux_altdef:
  "permutations_of_set_aux acc A = (\<lambda>xs. rev xs @ acc) ` permutations_of_set A"
proof (cases "finite A")
  assume "finite A"
  thus ?thesis
  proof (induction A arbitrary: acc rule: finite_psubset_induct)
    case (psubset A acc)
    show ?case
    proof (cases "A = {}")
      case False
      note [simp del] = permutations_of_set_aux.simps
      from psubset.hyps False
        have "permutations_of_set_aux acc A =
                (\<Union>y\<in>A. permutations_of_set_aux (y#acc) (A - {y}))"
        by (subst permutations_of_set_aux.simps) simp_all
      also have "\<dots> = (\<Union>y\<in>A. (\<lambda>xs. rev xs @ acc) ` (\<lambda>xs. y # xs) ` permutations_of_set (A - {y}))"
        apply (rule arg_cong [of _ _ Union], rule image_cong)
         apply (simp_all add: image_image)
        apply (subst psubset)
         apply auto
        done
      also from False have "\<dots> = (\<lambda>xs. rev xs @ acc) ` permutations_of_set A"
        by (subst (2) permutations_of_set_nonempty) (simp_all add: image_UN)
      finally show ?thesis .
    qed simp_all
  qed
qed (simp_all add: permutations_of_set_infinite)

declare permutations_of_set_aux.simps [simp del]

lemma permutations_of_set_aux_correct:
  "permutations_of_set_aux [] A = permutations_of_set A"
  by (simp add: permutations_of_set_aux_altdef)

text \<open>
  In another refinement step, we define a version on lists.
\<close>
declare length_remove1 [termination_simp]

fun permutations_of_set_aux_list where
  "permutations_of_set_aux_list acc xs =
     (if xs = [] then [acc] else
        List.bind xs (\<lambda>x. permutations_of_set_aux_list (x#acc) (List.remove1 x xs)))"

definition permutations_of_set_list where
  "permutations_of_set_list xs = permutations_of_set_aux_list [] xs"

declare permutations_of_set_aux_list.simps [simp del]

lemma permutations_of_set_aux_list_refine:
  assumes "distinct xs"
  shows   "set (permutations_of_set_aux_list acc xs) = permutations_of_set_aux acc (set xs)"
  using assms
  by (induction acc xs rule: permutations_of_set_aux_list.induct)
     (subst permutations_of_set_aux_list.simps,
      subst permutations_of_set_aux.simps,
      simp_all add: set_list_bind)

text \<open>
  The permutation lists contain no duplicates if the inputs contain no duplicates.
  Therefore, these functions can easily be used when working with a representation of
  sets by distinct lists.
  The same approach should generalise to any kind of set implementation that supports
  a monadic bind operation, and since the results are disjoint, merging should be cheap.
\<close>
lemma distinct_permutations_of_set_aux_list:
  "distinct xs \<Longrightarrow> distinct (permutations_of_set_aux_list acc xs)"
  by (induction acc xs rule: permutations_of_set_aux_list.induct)
     (subst permutations_of_set_aux_list.simps,
      auto intro!: distinct_list_bind simp: disjoint_family_on_def
         permutations_of_set_aux_list_refine permutations_of_set_aux_altdef)

lemma distinct_permutations_of_set_list:
    "distinct xs \<Longrightarrow> distinct (permutations_of_set_list xs)"
  by (simp add: permutations_of_set_list_def distinct_permutations_of_set_aux_list)

lemma permutations_of_list:
    "permutations_of_set (set xs) = set (permutations_of_set_list (remdups xs))"
  by (simp add: permutations_of_set_aux_correct [symmetric]
        permutations_of_set_aux_list_refine permutations_of_set_list_def)

lemma permutations_of_list_code [code]:
  "permutations_of_set (set xs) = set (permutations_of_set_list (remdups xs))"
  "permutations_of_set (List.coset xs) =
     Code.abort (STR ''Permutation of set complement not supported'')
       (\<lambda>_. permutations_of_set (List.coset xs))"
  by (simp_all add: permutations_of_list)

value [code] "permutations_of_set (set ''abcd'')"

end


(**
  * Author: Alasdair Armstrong
**)

theory Fixpoint
  imports Main
begin

context order
begin

definition endo_galois_connection :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "endo_galois_connection f g \<equiv> \<forall>x y. (f x \<le> y) \<longleftrightarrow> (x \<le> g y)"

definition endo_lower_adjoint :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "endo_lower_adjoint f \<equiv> \<exists>g. endo_galois_connection f g"

definition endo_upper_adjoint :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "endo_upper_adjoint g \<equiv> \<exists>f. endo_galois_connection f g"

lemma endo_deflation: "endo_galois_connection f g \<Longrightarrow> f (g y) \<le> y"
  by (metis endo_galois_connection_def le_less)

lemma endo_inflation: "endo_galois_connection f g \<Longrightarrow> x \<le> g (f x)"
  by (metis endo_galois_connection_def le_less)

(* Sledgehammer can't seem to use mono due to it's sort constraints *)
definition isotone :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "isotone f \<equiv> \<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"

lemma isotone_is_mono: "isotone f \<Longrightarrow> mono f"
  by (metis (hide_lams, mono_tags) order_class.isotone_def order_class.mono_def)

lemma isotoneD: "\<lbrakk>isotone f; x \<le> y\<rbrakk> \<Longrightarrow> f x \<le> f y"
  by (metis isotone_def)

definition idempotent :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "idempotent f \<equiv> f \<circ> f = f"

lemma endo_lower_iso: "endo_galois_connection f g \<Longrightarrow> isotone f"
  by (metis endo_galois_connection_def endo_inflation isotone_def order_trans)

lemma endo_upper_iso: "endo_galois_connection f g \<Longrightarrow> isotone g"
  by (metis (lifting) endo_deflation endo_galois_connection_def isotone_def order_trans)

lemma endo_lower_comp: "endo_galois_connection f g \<Longrightarrow> f \<circ> g \<circ> f = f"
proof
  fix x
  assume "endo_galois_connection f g"
  thus "(f \<circ> g \<circ> f) x = f x"
    by (metis comp_apply endo_deflation endo_galois_connection_def endo_inflation isotoneD less_le less_le_not_le endo_lower_iso endo_upper_adjoint_def)
qed

lemma endo_upper_comp: "endo_galois_connection f g \<Longrightarrow> g \<circ> f \<circ> g = g"
proof
  fix x
  assume "endo_galois_connection f g"
  thus "(g \<circ> f \<circ> g) x = g x"
    by (metis (full_types) antisym endo_deflation endo_inflation isotone_def o_apply endo_upper_iso)
qed

lemma endo_upper_idempotency1: "endo_galois_connection f g \<Longrightarrow> idempotent (f \<circ> g)"
  by (metis idempotent_def o_assoc endo_upper_comp)

lemma endo_upper_idempotency2: "endo_galois_connection f g \<Longrightarrow> idempotent (g \<circ> f)"
  by (metis idempotent_def o_assoc endo_lower_comp)

lemma endo_galois_comp: assumes g1: "endo_galois_connection F G" and g2 :"endo_galois_connection H K"
  shows "endo_galois_connection (F \<circ> H) (K \<circ> G)"
  by (smt g1 g2 endo_galois_connection_def o_apply)

lemma endo_galois_id: "endo_galois_connection id id" by (metis endo_galois_connection_def id_def)

lemma endo_galois_isotone1: "endo_galois_connection f g \<Longrightarrow> isotone (g \<circ> f)"
  by (smt endo_galois_connection_def endo_inflation isotoneD isotone_def o_apply order_trans endo_upper_iso)

lemma endo_galois_isotone2: "endo_galois_connection f g \<Longrightarrow> isotone (f \<circ> g)"
  by (metis isotone_def endo_lower_iso o_apply endo_upper_iso)

lemma endo_cancel: assumes g: "endo_galois_connection f g" shows "f (g x) \<le> g (f x)"
  by (metis assms endo_deflation endo_inflation order_trans)

lemma endo_cancel_cor1: assumes g: "endo_galois_connection f g"
  shows "(g x = g y) \<longleftrightarrow> (f (g x) = f (g y))"
  by (metis assms endo_upper_comp o_apply)

lemma endo_cancel_cor2: assumes g: "endo_galois_connection f g"
  shows "(f x = f y) \<longleftrightarrow> (g (f x) = g (f y))"
  by (metis assms endo_lower_comp o_apply)

lemma endo_semi_inverse1: "endo_galois_connection f g \<Longrightarrow> f x = f (g (f x))"
  by (metis o_def endo_lower_comp)

lemma endo_semi_inverse2: "endo_galois_connection f g \<Longrightarrow> g x = g (f (g x))"
  by (metis o_def endo_upper_comp)

lemma endo_universal_mapping_property1:
  assumes a: "isotone g" and b: "\<forall>x. x \<le> g (f x)"
  and c: "\<forall>x y. (x \<le> g y) \<longrightarrow> (f x \<le> y)"
  shows "endo_galois_connection f g"
  by (metis a b c endo_galois_connection_def isotoneD order_trans)

lemma endo_universal_mapping_property2:
  assumes a: "isotone f" and b: "\<forall>x. f (g x) \<le> x"
  and c: "\<forall>x y. (f x \<le> y) \<longrightarrow> (x \<le> g y)"
  shows "endo_galois_connection f g"
  by (metis a b c endo_galois_connection_def isotoneD order_trans)

lemma endo_galois_ump2: "endo_galois_connection f g = (isotone f \<and> (\<forall>y. f (g y) \<le> y) \<and> (\<forall>x y. f x \<le> y \<longrightarrow> x \<le> g y))"
  by (metis endo_deflation endo_galois_connection_def endo_lower_iso endo_universal_mapping_property2)

lemma endo_galois_ump1: "endo_galois_connection f g = (isotone g \<and> (\<forall>x. x \<le> g (f x)) \<and> (\<forall>x y. x \<le> g y \<longrightarrow> f x \<le> y))"
  by (metis endo_galois_connection_def endo_inflation endo_universal_mapping_property1 endo_upper_iso)

(* +------------------------------------------------------------------------+
   | Theorem 4.10(a)                                                        |
   +------------------------------------------------------------------------+ *)

lemma endo_ore_galois:
  assumes"\<forall>x. x \<le> g (f x)" and "\<forall>x. f (g x) \<le> x"
  and "isotone f" and  "isotone g"
  shows "endo_galois_connection f g"
  by (metis assms isotoneD order_trans endo_universal_mapping_property1)

(* +------------------------------------------------------------------------+
   | Theorems 4.32(a) and 4.32(b)                                           |
   +------------------------------------------------------------------------+ *)

lemma endo_perfect1: "endo_galois_connection f g \<Longrightarrow> g (f x) = x \<longleftrightarrow> x \<in> range g"
  by (metis (full_types) image_iff range_eqI endo_semi_inverse2)

lemma endo_perfect2: "endo_galois_connection f g \<Longrightarrow> f (g x) = x \<longleftrightarrow> x \<in> range f"
  by (metis (full_types) image_iff range_eqI endo_semi_inverse1)

end

definition pleq :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
  "pleq f g \<equiv> \<forall>x. f x \<le> g x"

definition galois_connection :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" where
  "galois_connection f g \<equiv> \<forall>x y. (f x \<le> y) \<longleftrightarrow> (x \<le> g y)"

lemma galoisD: "galois_connection f g \<Longrightarrow> \<forall>x y. (f x \<le> y) \<longleftrightarrow> (x \<le> g y)"
  by (simp add: galois_connection_def)

lemma rev_galoisD: "galois_connection f g \<Longrightarrow> \<forall>x y.  (x \<le> g y) \<longleftrightarrow> (f x \<le> y)"
  by (simp add: galois_connection_def)

definition lower_adjoint :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> bool" where
  "lower_adjoint f \<equiv> \<exists>g. galois_connection f g"

definition upper_adjoint :: "('b::order \<Rightarrow> 'a::order) \<Rightarrow> bool" where
  "upper_adjoint g \<equiv> \<exists>f. galois_connection f g"

lemma deflation: "galois_connection f g \<Longrightarrow> f (g y) \<le> y"
  by (metis galois_connection_def le_less)

lemma deflationD: "galois_connection f g \<Longrightarrow> \<forall>y. f (g y) \<le> y"
  by (metis galois_connection_def le_less)

lemma inflation: "galois_connection f g \<Longrightarrow> x \<le> g (f x)"
  by (metis galois_connection_def le_less)

lemma inflationD: "galois_connection f g \<Longrightarrow> \<forall>x. x \<le> g (f x)"
  by (metis galois_connection_def le_less)

definition idempotent :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "idempotent f \<equiv> f \<circ> f = f"

lemma lower_iso: "galois_connection f g \<Longrightarrow> mono f"
  apply (frule galoisD)
  apply (auto simp add: mono_def)
  apply (drule inflationD)
  apply (erule_tac x = y in allE) back
  by (metis order_trans)

lemma upper_iso: "galois_connection f g \<Longrightarrow> mono g"
  apply (frule rev_galoisD)
  apply (auto simp add: mono_def)
  apply (drule deflationD)
  apply (erule_tac x = x in allE)
  by (metis order_trans)

lemma lower_comp: "galois_connection f g \<Longrightarrow> f \<circ> g \<circ> f = f"
proof
  fix x
  assume "galois_connection f g"
  thus "(f \<circ> g \<circ> f) x = f x"
    apply (simp add: galois_connection_def)
    by (metis `galois_connection f g` lower_iso monoE order_class.order.antisym order_refl)
qed

lemma upper_comp: "galois_connection f g \<Longrightarrow> g \<circ> f \<circ> g = g"
proof
  fix x
  assume "galois_connection f g"
  thus "(g \<circ> f \<circ> g) x = g x"
    apply (simp add: galois_connection_def)
    by (metis `galois_connection f g` monoE order_class.order.antisym order_refl upper_iso)
qed

lemma upper_idempotency1: "galois_connection f g \<Longrightarrow> idempotent (f \<circ> g)"
  by (metis idempotent_def o_assoc upper_comp)

lemma upper_idempotency2: "galois_connection f g \<Longrightarrow> idempotent (g \<circ> f)"
  by (metis idempotent_def o_assoc lower_comp)

lemma galois_comp: assumes g1: "galois_connection F G" and g2 :"galois_connection H K"
  shows "galois_connection (F \<circ> H) (K \<circ> G)"
  by (smt g1 g2 galois_connection_def o_apply)

lemma galois_id: "galois_connection id id"
  by (simp add: galois_connection_def)

lemma galois_isotone1: "galois_connection f g \<Longrightarrow> mono (g \<circ> f)"
  by (smt galois_connection_def inflation monoD mono_def o_apply order_trans upper_iso)

lemma galois_isotone2: "galois_connection f g \<Longrightarrow> mono (f \<circ> g)"
  by (metis mono_def lower_iso o_apply upper_iso)

lemma point_id1: "galois_connection f g \<Longrightarrow> id \<sqsubseteq> g \<circ> f"
  by (metis inflation id_apply o_apply pleq_def)

lemma point_id2: "galois_connection f g \<Longrightarrow> f \<circ> g \<sqsubseteq> id"
  by (metis deflation id_apply o_apply pleq_def)

lemma point_cancel: assumes g: "galois_connection f g" shows "f \<circ> g \<sqsubseteq> g \<circ> f" using g
  by (simp add: galois_connection_def o_def pleq_def) (metis g monoE order_refl upper_iso)

lemma cancel: assumes g: "galois_connection f g" shows "f (g x) \<le> g (f x)"
  by (metis assms deflation inflation order_trans)

lemma cancel_cor1: assumes g: "galois_connection f g"
  shows "(g x = g y) \<longleftrightarrow> (f (g x) = f (g y))"
  by (metis assms upper_comp o_apply)

lemma cancel_cor2: assumes g: "galois_connection f g"
  shows "(f x = f y) \<longleftrightarrow> (g (f x) = g (f y))"
  by (metis assms lower_comp o_apply)

lemma semi_inverse1: "galois_connection f g \<Longrightarrow> f x = f (g (f x))"
  by (metis o_def lower_comp)

lemma semi_inverse2: "galois_connection f g \<Longrightarrow> g x = g (f (g x))"
  by (metis o_def upper_comp)

lemma universal_mapping_property1:
  assumes a: "mono g" and b: "\<forall>x. x \<le> g (f x)"
  and c: "\<forall>x y. (x \<le> g y) \<longrightarrow> (f x \<le> y)"
  shows "galois_connection f g"
  by (metis (full_types) a b c galois_connection_def monoD order_trans)

lemma universal_mapping_property2:
  assumes a: "mono f" and b: "\<forall>x. f (g x) \<le> x"
  and c: "\<forall>x y. (f x \<le> y) \<longrightarrow> (x \<le> g y)"
  shows "galois_connection f g"
  by (metis (full_types) a b c galois_connection_def monoD order_trans)

lemma galois_ump2: "galois_connection f g = (mono f \<and> (\<forall>y. f (g y) \<le> y) \<and> (\<forall>x y. f x \<le> y \<longrightarrow> x \<le> g y))"
  by (metis deflation galois_connection_def lower_iso universal_mapping_property2)

lemma galois_ump1: "galois_connection f g = (mono g \<and> (\<forall>x. x \<le> g (f x)) \<and> (\<forall>x y. x \<le> g y \<longrightarrow> f x \<le> y))"
  by (metis galois_connection_def inflation universal_mapping_property1 upper_iso)

(* +------------------------------------------------------------------------+
   | Theorem 4.10(a)                                                        |
   +------------------------------------------------------------------------+ *)

lemma ore_galois:
  assumes"\<forall>x. x \<le> g (f x)" and "\<forall>x. f (g x) \<le> x"
  and "mono f" and  "mono g"
  shows "galois_connection f g"
  by (metis assms monoD order_trans universal_mapping_property1)

(* +------------------------------------------------------------------------+
   | Theorems 4.32(a) and 4.32(b)                                           |
   +------------------------------------------------------------------------+ *)

lemma perfect1: "galois_connection f g \<Longrightarrow> g (f x) = x \<longleftrightarrow> x \<in> range g"
  by (metis (full_types) image_iff range_eqI semi_inverse2)

lemma perfect2: "galois_connection f g \<Longrightarrow> f (g x) = x \<longleftrightarrow> x \<in> range f"
  by (metis (full_types) image_iff range_eqI semi_inverse1)

(* Fixpoints *)

context order
begin

definition is_lpp :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "is_lpp x f \<equiv> f x \<le> x \<and> (\<forall>y. f y \<le> y \<longrightarrow> x \<le> y)"

definition is_gpp :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "is_gpp x f \<equiv> x \<le> f x \<and> (\<forall>y. y \<le> f y \<longrightarrow> y \<le> x)"

lemma lpp_unique: "\<lbrakk>is_lpp x f; is_lpp y f\<rbrakk> \<Longrightarrow> x = y"
  by (auto intro: antisym simp only: is_lpp_def)

lemma gpp_unique: "\<lbrakk>is_gpp x f; is_gpp y f\<rbrakk> \<Longrightarrow> x = y"
  by (auto intro: antisym simp only: is_gpp_def)

definition is_lfp :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "is_lfp x f \<equiv> f x = x \<and> (\<forall>y. f y = y \<longrightarrow> x \<le> y)"

definition is_gfp :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "is_gfp x f \<equiv> x = f x \<and> (\<forall>y. f y = y \<longrightarrow> y \<le> x)"

definition least_fixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<mu>") where
  "\<mu> f \<equiv> THE x. is_lfp x f"

notation least_fixpoint (binder "\<mu>" 10)

lemma lfp_eta: "(\<mu> x. f x) = \<mu> f" by simp

lemma lfp_equality: "is_lfp x f \<Longrightarrow> \<mu> f = x"
  by (metis (lifting) eq_iff is_lfp_def least_fixpoint_def the_equality)

lemma lpp_is_lfp: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> is_lpp x f \<Longrightarrow> is_lfp x f"
  by (auto intro: antisym simp add: is_lfp_def is_lpp_def)

definition greatest_fixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<nu>") where
  "\<nu> f \<equiv> THE x. is_gfp x f"

notation greatest_fixpoint (binder "\<nu>" 10)

lemma gfp_eta: "(\<nu> x. f x) = \<nu> f" by simp

lemma gfp_equality: "is_gfp x f \<Longrightarrow> \<nu> f = x"
  by (metis (lifting) eq_iff greatest_fixpoint_def is_gfp_def the_equality)

lemma gpp_is_gfp: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> is_gpp x f \<Longrightarrow> is_gfp x f"
  by (auto intro: antisym simp add: is_gfp_def is_gpp_def)

end

lemma continuity_mono:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "(\<And>X. Sup (f ` X) = f (Sup X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis Sup_le_iff antisym atMost_iff imageI order_refl)

lemma Inf_continuity_mono:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "(\<And>X. Inf (f ` X) = f (Inf X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis antisym atLeast_iff image_eqI le_Inf_iff order_refl)

definition (in order) directed :: "'a set \<Rightarrow> bool" where
  "directed X \<equiv> X \<noteq> {} \<and> (\<forall>x y. x \<in> X \<and> y \<in> X \<longrightarrow> (\<exists>z. x \<le> z \<and> y \<le> z))"

context complete_lattice
begin

lemma continuity_mono1: "(\<And>X. Sup (f ` X) = f (Sup X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis Sup_le_iff antisym atMost_iff imageI order_refl)

lemma continuity_mono2: "(\<And>X. Inf (f ` X) = f (Inf X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis (full_types) Inf_atLeastAtMost Inf_superset_mono atLeastatMost_subset_iff eq_refl image_mono)

lemma scott_continuity_mono: "(\<And>X. directed X \<Longrightarrow> Sup (f ` X) = f (Sup X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
proof -
  assume scott_continuity: "\<And>X. directed X \<Longrightarrow> Sup (f ` X) = f (Sup X)"

  {
    fix x y
    have "directed {x, y}"
    by (auto intro: exI[of _ "sup x y"] simp add: directed_def)
    hence "Sup (f ` {x, y}) = f (Sup {x, y})"
      by (metis scott_continuity)
    hence "sup (f x) (f y) = f (sup x y)"
      by auto
  }
  moreover assume "x \<le> y"
  ultimately show ?thesis
    by (metis le_iff_sup)
qed

lemma Inf_continuity_mono1: "(\<And>X. Inf (f ` X) = f (Inf X)) \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis antisym atLeast_iff image_eqI le_Inf_iff order_refl)

theorem knaster_tarski_lpp:
  assumes "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y)" shows "\<exists>!x. is_lpp x f"
proof
  let ?H = "{u. f u \<le> u}"
  let ?a = "Inf ?H"

  have "f ?a \<le> ?a"
  proof -
    have "\<forall>x\<in>?H. ?a \<le> x"
      by (auto intro: Inf_lower)
    hence "\<forall>x\<in>?H. f ?a \<le> f x"
      by (metis assms)
    hence "\<forall>x\<in>?H. f ?a \<le> x"
      by (metis (lifting) mem_Collect_eq order_trans)
    thus "f ?a \<le> ?a"
      by (metis Inf_greatest lfp_def)
  qed
  moreover show "\<And>x. is_lpp x f \<Longrightarrow> x = ?a"
    by (metis eq_iff is_lpp_def lfp_def lfp_greatest lfp_lowerbound)
  ultimately show "is_lpp ?a f"
    by (metis is_lpp_def lfp_def lfp_lowerbound)
qed

theorem knaster_tarski: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> \<exists>!x. is_lfp x f"
  by (metis knaster_tarski_lpp lfp_equality lpp_is_lfp)

corollary is_lfp_lfp [intro?]:
  "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> is_lfp (\<mu> f) f"
  by (metis knaster_tarski_lpp lfp_equality lpp_is_lfp)

theorem knaster_tarski_gpp:
  assumes "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y)" shows "\<exists>!x. is_gpp x f"
proof
  let ?H = "{u. u \<le> f u}"
  let ?a = "Sup ?H"

  have "?a \<le> f ?a"
  proof -
    have "\<forall>x\<in>?H. x \<le> ?a"
      by (metis Sup_upper)
    hence "\<forall>x\<in>?H. f x \<le> f ?a"
      by (metis assms)
    hence "\<forall>x\<in>?H. x \<le> f ?a"
      by (metis (lifting) mem_Collect_eq order_trans)
    thus "?a \<le> f ?a"
      by (metis Sup_least gfp_def)
  qed
  moreover show "\<And>x. is_gpp x f \<Longrightarrow> x = ?a"
    by (metis (lifting, full_types) Sup_upper calculation eq_iff is_gpp_def mem_Collect_eq)
  ultimately show "is_gpp ?a f"
    by (simp add: is_gpp_def) (metis (full_types) Sup_upper mem_Collect_eq)
qed

theorem knaster_tarski_gfp: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> \<exists>!x. is_gfp x f"
  by (metis gfp_equality gpp_is_gfp knaster_tarski_gpp)

corollary is_gfp_gfp [intro?]:
  "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> is_gfp (\<nu> f) f"
  by (metis gfp_equality knaster_tarski_gfp)

lemma fp_compute [simp]: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> f (\<mu> f) = \<mu> f"
  by (metis is_lfp_def is_lfp_lfp)

lemma gfp_compute [simp]: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> f (\<nu> f) = \<nu> f"
  by (metis is_gfp_def is_gfp_gfp)

lemma fp_induct [intro?]:
  assumes "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y)" and "f x \<le> x" shows "\<mu> f \<le> x"
  by (metis (full_types) assms is_lpp_def knaster_tarski_lpp lfp_equality lpp_is_lfp)

lemma gfp_induct [intro?]:
  assumes "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y)" and "x \<le> f x" shows "x \<le> \<nu> f"
  by (metis assms gpp_is_gfp is_gfp_gfp is_gpp_def knaster_tarski_gfp knaster_tarski_gpp)

primrec iter :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" where
  "iter f 0 x = x"
| "iter f (Suc n) x = f (iter f n x)"

lemma iter_mono: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> x \<le> y \<Longrightarrow> iter f n x \<le> iter f n y"
  by (induct n) simp_all

lemma iter_pp: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> f y \<le> y \<Longrightarrow> iter f n y \<le> y"
  apply (induct n)
  apply simp
  by (metis (full_types) iter.simps(2) order_trans)

lemma iter_plus: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> iter f n bot \<le> iter f (n + m) bot"
proof (induct n)
  case 0 thus ?case
    by auto
next
  case (Suc n)
  thus ?case
    by auto
qed

theorem kleene_lfp:
  assumes scott_continuity: "(\<And>X. directed X \<Longrightarrow> Sup (f ` X) = f (Sup X))"
  shows "\<mu> f = Sup {iter f n bot|n. True}"
proof -
  let ?C = "{iter f n bot|n. True}"
  let ?c = "Sup {iter f n bot|n. True}"

  have directed_C: "directed ?C"
    apply (auto simp add: directed_def)
    apply (rename_tac n m)
    apply (rule_tac x = "iter f (n + m) bot" in exI)
    apply auto
    apply (metis iter_plus scott_continuity scott_continuity_mono)
    by (metis add.commute iter_plus scott_continuity scott_continuity_mono)

  have "f ?c \<le> ?c"
  proof -
    have "f ?c = Sup (f ` ?C)"
      by (metis scott_continuity[OF directed_C])
    also have "... \<le> ?c"
      apply (rule Sup_mono)
      apply (auto simp add: image_def)
      apply (rule_tac x = "iter f (Suc n) bot" in exI)
      apply auto
      by (metis iter.simps(2))
    finally show ?thesis .
  qed

  moreover have "(\<forall>y. f y \<le> y \<longrightarrow> ?c \<le> y)"
  proof clarify
    fix y assume y_fp: "f y \<le> y"
    have "bot \<le> y"
      by (metis bot_least)
    hence "\<forall>n. iter f n bot \<le> iter f n y"
      by (metis scott_continuity scott_continuity_mono iter_mono)
     hence "\<forall>n. iter f n bot \<le> y"
      by (metis scott_continuity scott_continuity_mono iter_pp order_trans y_fp)
    thus "?c \<le> y"
      by (auto intro!: Sup_least)
  qed

  ultimately have "is_lpp ?c f"
    by (auto simp add: is_lpp_def)
  hence "is_lfp ?c f"
    by (metis (full_types) scott_continuity scott_continuity_mono lpp_is_lfp)
  thus "\<mu> f = ?c"
    by (metis lfp_equality)
qed

lemma kleene_gfp:
  assumes continuity: "(\<And>X. Inf (f ` X) = f (Inf X))"
  shows "\<nu> f = Inf {iter f n top|n. True}"
proof -
  let ?C = "{iter f n top|n. True}"
  let ?c = "Inf {iter f n top|n. True}"

  have "?c \<le> f ?c"
  proof -
    have "?c \<le> Inf (f ` ?C)"
      apply (rule Inf_mono)
      apply (auto simp add: image_def)
      apply (rule_tac x = "iter f (Suc n) top" in exI)
      apply auto
      by (metis iter.simps(2))
    also have "... \<le> f ?c"
      by (metis continuity eq_refl)
    finally show ?thesis .
  qed

  moreover have "(\<forall>y. y \<le> f y \<longrightarrow> y \<le> ?c)"
  proof clarify
    fix y assume y_fp: "y \<le> f y"
    have "y \<le> top"
     by (metis top_greatest)
    hence "\<forall>n. iter f n y \<le> iter f n top"
      by (metis continuity Inf_continuity_mono1 iter_mono)
    moreover have "\<forall>n. y \<le> iter f n y"
    proof clarify
      fix n show "y \<le> iter f n y" apply (induct n) apply simp_all
        apply (rule order_trans[of _ "f y"])
        apply (metis y_fp)
        apply (rule Inf_continuity_mono1[OF continuity])
        by auto
    qed
    ultimately have "\<forall>n. y \<le> iter f n top"
      by (metis order_trans)
    thus "y \<le> ?c"
      by (auto intro!: Inf_greatest)
  qed

  ultimately have "is_gpp ?c f"
    by (auto simp add: is_gpp_def)
  hence "is_gfp ?c f"
    by (metis (full_types) Inf_continuity_mono1 continuity gpp_is_gfp)
  thus "\<nu> f = ?c"
    by (metis gfp_equality)
qed

lemma gfp_equality_var [intro?]: "\<lbrakk>f x = x; \<And>y. f y = y \<Longrightarrow> y \<le> x\<rbrakk> \<Longrightarrow> x = \<nu> f"
  by (metis gfp_equality is_gfp_def)

lemma lfp_equality_var [intro?]: "\<lbrakk>f x = x; \<And>y. f y = y \<Longrightarrow> x \<le> y\<rbrakk> \<Longrightarrow> x = \<mu> f"
  by (metis is_lfp_def lfp_equality)

theorem endo_fixpoint_fusion [simp]:
  assumes upper_ex: "endo_lower_adjoint f"
  and hiso: "isotone h" and kiso: "isotone k"
  and comm: "f\<circ>h = k\<circ>f"
  shows "f (\<mu> h) = \<mu> k"
proof
  show "k (f (\<mu> h)) = f (\<mu> h)"
    by (metis comm fp_compute hiso isotone_def o_eq_dest_lhs)
next
  fix y assume ky: "k y = y"
  obtain g where conn: "endo_galois_connection f g" by (metis endo_lower_adjoint_def upper_ex)
  have "\<mu> h \<le> g y" using isotoneD[OF hiso]
  proof (rule fp_induct)
    have "f (g y) \<le> y" by (metis conn endo_deflation)
    hence "f (h (g y)) \<le> y" by (metis comm kiso ky isotoneD o_def)
    thus "h (g y) \<le> g y" by (metis conn endo_galois_connection_def)
  qed
  thus "f (\<mu> h) \<le> y" by (metis conn endo_galois_connection_def)
qed

theorem endo_greatest_fixpoint_fusion [simp]:
  assumes lower_ex: "endo_upper_adjoint g"
  and hiso: "isotone h" and kiso: "isotone k"
  and comm: "g\<circ>h = k\<circ>g"
  shows "g (\<nu> h) = \<nu> k"
proof
  show "k (g (\<nu> h)) = g (\<nu> h)"
    by (metis comm gfp_compute hiso isotone_def o_eq_dest_lhs)
next
  fix y assume ky: "k y = y"
  obtain f where conn: "endo_galois_connection f g" by (metis lower_ex endo_upper_adjoint_def)
  have "f y \<le> \<nu> h" using isotoneD[OF hiso]
  proof (rule gfp_induct)
    have "y \<le> g (f y)" by (metis conn endo_inflation)
    hence "y \<le> g (h (f y))" by (metis (full_types) comm comp_apply isotoneD kiso ky)
    thus "f y \<le> h (f y)" by (metis conn endo_galois_connection_def)
  qed
  thus "y \<le> g (\<nu> h)" by (metis conn endo_galois_connection_def)
qed

end

theorem fixpoint_fusion [simp]:
  fixes k :: "'b::complete_lattice \<Rightarrow> 'b"
  and h :: "'a::complete_lattice \<Rightarrow> 'a"
  and f :: "'a \<Rightarrow> 'b"
  assumes upper_ex: "lower_adjoint f"
  and hiso: "mono h" and kiso: "mono k"
  and comm: "f\<circ>h = k\<circ>f"
  shows "f (\<mu> h) = \<mu> k"
proof
  show "k (f (\<mu> h)) = f (\<mu> h)" using monoD[OF hiso]
    by (metis comm fp_compute o_eq_dest_lhs)
next
  fix y :: "'b" assume ky: "k y = y"
  obtain g where conn: "galois_connection f g" by (metis lower_adjoint_def upper_ex)
  have "\<mu> h \<le> g y"
  proof (rule fp_induct)
    fix x y :: 'a assume "x \<le> y" thus "h x \<le> h y"
      by (rule monoD[OF hiso])
  next
    have "f (g y) \<le> y" by (metis conn deflation)
    hence "f (h (g y)) \<le> y" by (metis comm kiso ky monoD o_def)
    thus "h (g y) \<le> g y" by (metis conn galois_connection_def)
  qed
  thus "f (\<mu> h) \<le> y" by (metis conn galois_connection_def)
qed

theorem greatest_fixpoint_fusion [simp]:
  fixes k :: "'b::complete_lattice \<Rightarrow> 'b"
  and h :: "'a::complete_lattice \<Rightarrow> 'a"
  and f :: "'a \<Rightarrow> 'b"
  assumes lower_ex: "upper_adjoint g"
  and hiso: "mono h" and kiso: "mono k"
  and comm: "g\<circ>h = k\<circ>g"
  shows "g (\<nu> h) = \<nu> k"
proof
  show "k (g (\<nu> h)) = g (\<nu> h)" using monoD[OF hiso]
    by (metis (full_types) comm comp_apply gfp_compute)
next
  fix y assume ky: "k y = y"
  obtain f where conn: "galois_connection f g" by (metis lower_ex upper_adjoint_def)
  have "f y \<le> \<nu> h"
  proof (rule gfp_induct)
    fix x y :: 'a assume "x \<le> y" thus "h x \<le> h y"
      by (rule monoD[OF hiso])
  next
    have "y \<le> g (f y)" by (metis conn inflation)
    hence "y \<le> g (h (f y))" by (metis (full_types) comm comp_apply monoD kiso ky)
    thus "f y \<le> h (f y)" by (metis conn galois_connection_def)
  qed
  thus "y \<le> g (\<nu> h)" by (metis conn galois_connection_def)
qed

definition join_preserving :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> bool" where
  "join_preserving f \<equiv> \<forall>X. Sup (f ` X) = f (Sup X)"

definition meet_preserving :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) \<Rightarrow> bool" where
  "meet_preserving g \<equiv> \<forall>X. Inf (g ` X) = g (Inf X)"

(* +------------------------------------------------------------------------+
   | Theorems 4.25(a) and 4.25(b)                                           |
   +------------------------------------------------------------------------+ *)

lemma (in complete_lattice) Sup_eq_equiv: "Sup A = x \<longleftrightarrow> (\<forall>z. (x \<le> z \<longleftrightarrow> (\<forall>y\<in>A. y \<le> z)))"
  apply default
  apply (metis Sup_le_iff)
  by (metis (full_types) Sup_le_iff Sup_upper le_iff_inf less_infI2 less_le order_refl)

lemma (in complete_lattice) Inf_eq_equiv: "Inf A = x \<longleftrightarrow> (\<forall>z. (z \<le> x \<longleftrightarrow> (\<forall>y\<in>A. z \<le> y)))"
  apply default
  apply (metis Inf_greatest Inf_lower order_trans)
  by (metis Inf_atLeast Inf_lower Inf_superset_mono atLeast_def mem_Collect_eq order.antisym subsetI)

lemma lower_adjoint_Sup:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  assumes "Sup X = x" and "lower_adjoint f" shows "Sup (f ` X) = f x" using assms
  apply (simp add: Sup_eq_equiv lower_adjoint_def)
  apply (erule exE)
  apply (simp add: galois_ump2 mono_def)
  apply (erule conjE)+
  by (metis (mono_tags, hide_lams) SUP_le_iff SUP_upper eq_iff order.trans order_refl)

lemma lower_preserves_join: "lower_adjoint f \<Longrightarrow> join_preserving f"
  by (metis join_preserving_def lower_adjoint_Sup)

theorem suprema_galois: "galois_connection f g = (join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y))"
proof (intro iffI conjI)
  assume "galois_connection f g"
  hence "lower_adjoint f"
    by (metis lower_adjoint_def)
  thus "join_preserving f"
    by (rule lower_preserves_join)
  from `galois_connection f g`
  show "\<forall>y. Sup {x. f x \<le> y} = g y"
    by (simp add: Sup_eq_equiv galois_ump2 mono_def) (metis (full_types) order_trans)
next
  assume "join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)"
  hence f_jp: "join_preserving f" and a2: "\<And>y. Sup {x. f x \<le> y} = g y"
    by auto
  have f_iso: "mono f"
    apply (rule monoI)
    apply (rule continuity_mono) back
    apply (metis f_jp join_preserving_def)
    by simp
  show "galois_connection f g"
  proof (simp add: galois_connection_def)
    have "\<forall>x y. (f x \<le> y) \<longrightarrow> (x \<le> g y)"
      using a2 by (auto simp only: Sup_eq_equiv)
    moreover have "\<forall>x y. (x \<le> g y) \<longrightarrow> (f x \<le> y)"
    proof (intro impI allI)
      fix x y
      assume gr: "x \<le> g y"
      show "f x \<le> y"
      proof -
        have lem: "Sup (f ` {x. f x \<le> y}) \<le> y"
          by (rule Sup_least) auto

        have "f x \<le> y \<Longrightarrow> x \<le> Sup {z. f z \<le> y}"
          by (metis `join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` gr)
        moreover have "x \<le> Sup {z. f z \<le> y} \<Longrightarrow> f x \<le> f (Sup {z. f z \<le> y})"
          by (metis f_iso monoD)
        moreover have "(f x \<le> f (Sup {z. f z \<le> y})) = (f x \<le> Sup (f ` {z. f z \<le> y}))"
          by (metis (full_types) `join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` join_preserving_def)
        moreover have "... \<Longrightarrow> f x \<le> y" using lem
          by (metis order_trans)
        ultimately show ?thesis
          by (metis `join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` gr)
      qed
    qed
    ultimately show "\<forall>x y. (f x \<le> y) = (x \<le> g y)"
      by auto
  qed
qed

lemma lower_is_jp: "lower_adjoint f \<longleftrightarrow> join_preserving f"
proof
  assume "lower_adjoint f" thus "join_preserving f"
    by (metis lower_preserves_join)
next
  assume "join_preserving f"
  moreover hence "\<exists>g. \<forall>y. Sup {x. f x \<le> y} = g y"
    by auto
  ultimately show "lower_adjoint f"
    by (metis (full_types) lower_adjoint_def suprema_galois)
qed

context complete_lattice begin

definition endo_join_preserving :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "endo_join_preserving f \<equiv> \<forall>X. Sup (f ` X) = f (Sup X)"

definition endo_meet_preserving :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "endo_meet_preserving g \<equiv> \<forall>X. Inf (g ` X) = g (Inf X)"

(* +------------------------------------------------------------------------+
   | Theorems 4.25(a) and 4.25(b)                                           |
   +------------------------------------------------------------------------+ *)

lemma endo_lower_adjoint_Sup: "Sup X = x \<Longrightarrow> endo_lower_adjoint f \<Longrightarrow> Sup (f ` X) = f x"
  apply (simp add: Sup_eq_equiv endo_lower_adjoint_def)
  apply (erule exE)
  apply (simp add: endo_galois_ump2 isotone_def)
  apply (erule conjE)+
proof -
  fix g :: "'a \<Rightarrow> 'a"
  assume a1: "\<forall>z. (x \<le> z) = (\<forall>y\<in>X. y \<le> z)"
  assume a2: "\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"
  assume a3: "\<forall>y. f (g y) \<le> y"
  assume a4: "\<forall>x y. f x \<le> y \<longrightarrow> x \<le> g y"
  have f5: "\<forall>x\<^sub>0 x\<^sub>1 x. (\<not> SUPREMUM x\<^sub>0 x\<^sub>1 \<le> (x\<Colon>'a) \<or> (\<forall>b_x. (b_x\<Colon>'a) \<notin> x\<^sub>0 \<or> x\<^sub>1 b_x \<le> x)) \<and> ((\<exists>e_x. e_x \<in> x\<^sub>0 \<and> \<not> x\<^sub>1 e_x \<le> x) \<or> SUPREMUM x\<^sub>0 x\<^sub>1 \<le> x)" by (metis (no_types) local.SUP_le_iff)
  obtain sk\<^sub>0 :: "'a \<Rightarrow> 'a" where "x \<le> g (SUPREMUM X f)" using a1 a4 by (simp add: local.SUP_upper)
  hence "f x \<le> SUPREMUM X f" using a2 a3 local.order_trans by blast
  thus "(SUP x:X. f x) = f x" using a1 a2 f5 by (metis (no_types) local.eq_iff)
qed

lemma endo_lower_preserves_join: "endo_lower_adjoint f \<Longrightarrow> endo_join_preserving f"
  by (metis endo_join_preserving_def endo_lower_adjoint_Sup)

theorem endo_suprema_galois: "endo_galois_connection f g = (endo_join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y))"
proof (intro iffI conjI)
  assume "endo_galois_connection f g"
  hence "endo_lower_adjoint f"
    by (metis endo_lower_adjoint_def)
  thus "endo_join_preserving f"
    by (rule endo_lower_preserves_join)
  from `endo_galois_connection f g`
  show "\<forall>y. Sup {x. f x \<le> y} = g y"
    by (simp add: Sup_eq_equiv endo_galois_ump2 isotone_def) (metis (full_types) order_trans)
next
  assume "endo_join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)"
  hence f_jp: "endo_join_preserving f" and a2: "\<And>y. Sup {x. f x \<le> y} = g y"
    by auto
  hence f_iso: "isotone f"
    by (metis (mono_tags) continuity_mono1 endo_join_preserving_def isotone_def)
  show "endo_galois_connection f g"
  proof (simp add: endo_galois_connection_def)
    have "\<forall>x y. (f x \<le> y) \<longrightarrow> (x \<le> g y)"
      using a2 by (auto simp only: Sup_eq_equiv)
    moreover have "\<forall>x y. (x \<le> g y) \<longrightarrow> (f x \<le> y)"
    proof (intro impI allI)
      fix x y
      assume gr: "x \<le> g y"
      show "f x \<le> y"
      proof -
        have lem: "Sup (f ` {x. f x \<le> y}) \<le> y"
          by (metis (full_types) SUP_def SUP_le_iff mem_Collect_eq)

        have "f x \<le> y \<Longrightarrow> x \<le> Sup {z. f z \<le> y}"
          by (metis `endo_join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` gr)
        moreover have "x \<le> Sup {z. f z \<le> y} \<Longrightarrow> f x \<le> f (Sup {z. f z \<le> y})"
          by (metis f_iso isotoneD)
        moreover have "(f x \<le> f (Sup {z. f z \<le> y})) = (f x \<le> Sup (f ` {z. f z \<le> y}))"
          by (metis (full_types) `endo_join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` endo_join_preserving_def)
        moreover have "... \<Longrightarrow> f x \<le> y" using lem
          by (metis order_trans)
        ultimately show ?thesis
          by (metis `endo_join_preserving f \<and> (\<forall>y. Sup {x. f x \<le> y} = g y)` gr)
      qed
    qed
    ultimately show "\<forall>x y. (f x \<le> y) = (x \<le> g y)"
      by auto
  qed
qed

lemma endo_lower_is_jp: "endo_lower_adjoint f \<longleftrightarrow> endo_join_preserving f"
proof
  assume "endo_lower_adjoint f" thus "endo_join_preserving f"
    by (metis endo_lower_preserves_join)
next
  assume "endo_join_preserving f"
  moreover hence "\<exists>g. \<forall>y. Sup {x. f x \<le> y} = g y"
    by auto
  ultimately show "endo_lower_adjoint f"
    by (metis (full_types) endo_lower_adjoint_def endo_suprema_galois)
qed

lemma endo_upper_adjoint_Inf: "Inf X = x \<Longrightarrow> endo_upper_adjoint f \<Longrightarrow> Inf (f ` X) = f x"
  apply (simp add: Inf_eq_equiv endo_upper_adjoint_def)
  apply (erule exE)
  apply (simp add: endo_galois_ump2 isotone_def)
  apply (erule conjE)+
proof -
  fix fa :: "'a \<Rightarrow> 'a"
  assume a1: "\<forall>z. (z \<le> x) = (\<forall>y\<in>X. z \<le> y)"
  assume a2: "\<forall>x y. x \<le> y \<longrightarrow> fa x \<le> fa y"
  assume a3: "\<forall>y. fa (f y) \<le> y"
  assume a4: "\<forall>x y. fa x \<le> y \<longrightarrow> x \<le> f y"
  have f5: "\<forall>x\<^sub>0 x\<^sub>1 x. (\<not> (x\<^sub>0\<Colon>'a) \<le> INFIMUM x\<^sub>1 x \<or> (\<forall>b_x. (b_x\<Colon>'a) \<notin> x\<^sub>1 \<or> x\<^sub>0 \<le> x b_x)) \<and> ((\<exists>e_x. e_x \<in> x\<^sub>1 \<and> \<not> x\<^sub>0 \<le> x e_x) \<or> x\<^sub>0 \<le> INFIMUM x\<^sub>1 x)" by (metis (no_types) local.le_INF_iff)
  have "\<forall>x\<^sub>2\<^sub>6 x\<^sub>2\<^sub>7. \<not> x\<^sub>2\<^sub>6 \<le> fa (f x\<^sub>2\<^sub>7) \<or> x\<^sub>2\<^sub>6 \<le> x\<^sub>2\<^sub>7" using a3 local.order_trans by blast
  then obtain sk\<^sub>0 :: "'a \<Rightarrow> 'a" where "fa (INFIMUM X f) \<le> x" using a1 a2 by (metis local.INF_lower)
  thus "(INF x:X. f x) = f x" using a1 a3 a4 f5 by (metis local.eq_iff)
qed

lemma endo_upper_preserves_meet: "endo_upper_adjoint f \<Longrightarrow> endo_meet_preserving f"
  by (metis endo_meet_preserving_def endo_upper_adjoint_Inf)

theorem endo_infima_galois: "endo_galois_connection f g = (endo_meet_preserving g \<and> (\<forall>y. Inf {x. y \<le> g x} = f y))"
proof (intro iffI conjI)
  assume "endo_galois_connection f g"
  hence "endo_upper_adjoint g"
    by (metis endo_upper_adjoint_def)
  thus "endo_meet_preserving g"
    by (rule endo_upper_preserves_meet)
  from `endo_galois_connection f g`
  show "\<forall>y. Inf {x. y \<le> g x} = f y"
    by (simp add: Inf_eq_equiv endo_galois_ump1 isotone_def) (metis (full_types) order_trans)
next
  assume "endo_meet_preserving g \<and> (\<forall>y. Inf {x. y \<le> g x} = f y)"
  hence f_jp: "endo_meet_preserving g" and a2: "\<And>y. Inf {x. y \<le> g x} = f y"
    by auto
  hence f_iso: "isotone g"
    by (metis (mono_tags) continuity_mono2 endo_meet_preserving_def isotone_def)
  show "endo_galois_connection f g"
  proof (simp add: endo_galois_connection_def)
    have "\<forall>x y. (x \<le> g y) \<longrightarrow> (f x \<le> y)"
      using a2 by (metis Inf_lower mem_Collect_eq)
    moreover have "\<forall>x y. (f x \<le> y) \<longrightarrow> (x \<le> g y)"
    proof (intro impI allI)
      fix x y
      assume gr: "f x \<le> y"
      thus "x \<le> g y"
      proof -
        have lem: "x \<le> Inf (g ` {y. x \<le> g y})"
          by (metis (full_types) INF_def INF_greatest mem_Collect_eq)

        also have "... \<le> g y"
          by (metis (mono_tags) `endo_meet_preserving g \<and> (\<forall>y. Inf {x. y \<le> g x} = f y)` endo_meet_preserving_def f_iso gr isotoneD)

        finally show ?thesis .
      qed
    qed
    ultimately show "\<forall>x y. (f x \<le> y) = (x \<le> g y)"
      by auto
  qed
qed

(* Dual theorem *)
lemma endo_upper_is_mp: "endo_upper_adjoint g \<longleftrightarrow> endo_meet_preserving g"
proof
  assume "endo_upper_adjoint g" thus "endo_meet_preserving g"
    by (metis endo_upper_preserves_meet)
next
  assume "endo_meet_preserving g"
  moreover hence "\<exists>f. \<forall>x. Inf {y. x \<le> g y} = f x"
    by auto
  ultimately show "endo_upper_adjoint g"
    by (metis endo_infima_galois endo_upper_adjoint_def)
qed

end

end