(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory ExampleSystemPolicyFlows
imports
  Noninterference
  "Access.ExampleSystem"
begin

subsection \<open>Example 1 -- similar to Sys1 in ../access-control/ExampleSystem.thy\<close>

subsubsection \<open>Definitions\<close>

datatype Sys3Labels = UT3 | T3 | EP3 | IRQ3

definition Sys3AuthGraph_aux :: "Sys3Labels subject_label auth_graph"
where
  "Sys3AuthGraph_aux \<equiv>
   { (OrdinaryLabel (UT3), auth.SyncSend, OrdinaryLabel (EP3)),
     (OrdinaryLabel (UT3), auth.Reset, OrdinaryLabel (EP3)),
     (OrdinaryLabel (T3), auth.Receive, OrdinaryLabel (EP3)),
     (OrdinaryLabel (T3), auth.Reset, OrdinaryLabel (EP3)) }"

definition Sys3AuthGraph :: "Sys3Labels subject_label auth_graph"
where
  "Sys3AuthGraph \<equiv> complete_AuthGraph Sys3AuthGraph_aux {OrdinaryLabel (T3),
                                                         OrdinaryLabel (UT3)}"

definition Sys3PolicyFlows :: "(Sys3Labels partition \<times> Sys3Labels partition) set"
where
  "Sys3PolicyFlows \<equiv>
   { (Partition UT3, Partition UT3),
     (Partition UT3, Partition EP3),
     (Partition UT3, Partition T3),
     (Partition T3, Partition T3),
     (Partition T3, Partition UT3),
     (Partition T3, Partition EP3),
     (Partition EP3, Partition UT3),
     (Partition EP3, Partition EP3),
     (Partition EP3, Partition T3),
     (Partition IRQ3, Partition IRQ3),
     (PSched, Partition EP3),
     (PSched, Partition UT3),
     (PSched, Partition T3),
     (PSched, Partition IRQ3),
     (PSched, PSched) }"

subsubsection \<open>Generalisations\<close>

definition Sys3Reads where
  "Sys3Reads \<equiv> { (OrdinaryLabel (UT3)), (OrdinaryLabel (EP3)), (OrdinaryLabel (T3)) }"

definition Sys3Affects where
  "Sys3Affects \<equiv> { (OrdinaryLabel (UT3)), (OrdinaryLabel (EP3)), (OrdinaryLabel (T3)) }"

lemma Sys3Reads_correct_fw : "\<lbrakk>x \<in> subjectReads Sys3AuthGraph (OrdinaryLabel (l)); l \<in> {T3, UT3, EP3}\<rbrakk> \<Longrightarrow> x \<in> Sys3Reads"
  apply (induct x rule:subjectReads.induct)
         apply (auto simp:Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def Sys3Reads_def)
  done

lemma Sys3Affects_correct_fw : "\<lbrakk>x \<in> subjectAffects Sys3AuthGraph (OrdinaryLabel (l)); l \<in> {T3, UT3}\<rbrakk> \<Longrightarrow> x \<in> Sys3Affects"
  apply (induct x rule:subjectAffects.induct)
        apply (auto simp:Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def Sys3Affects_def)
  done

subsubsection \<open>UT3\<close>

lemma Sys3UT3Reads_correct_bw : "x \<in> Sys3Reads \<Longrightarrow> x \<in> subjectReads Sys3AuthGraph (OrdinaryLabel (UT3))"
  apply (simp add: Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def Sys3Reads_def)
  apply (erule disjE)
   (* UT3 reads UT3 *)
   apply simp
  (* UT3 reads EP3 *)
  apply (erule disjE)
   apply (rule_tac auth = SyncSend in reads_ep)
    apply (simp)
    apply (simp add:insertI1)
  (* UT3 reads T3 *)
  apply (rule_tac auth = SyncSend and ep = "OrdinaryLabel (EP3)" and a = "OrdinaryLabel (UT3)" in read_sync_ep_read_receivers)
     apply (simp)
     apply (simp)
    apply (rule_tac auth = SyncSend in reads_ep)
    apply (simp)
    apply (rule insertI1)
    apply (simp add: insertI1)
  done

lemma Sys3UT3Affects_correct_bw : "x \<in> Sys3Affects \<Longrightarrow> x \<in> subjectAffects Sys3AuthGraph (OrdinaryLabel (UT3))"
  apply (simp add:Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def Sys3Affects_def)
  apply (erule disjE)
   (* UT3 affects UT3 *)
   apply (simp add:affects_lrefl)
  (* UT3 affects EP3 *)
  apply (erule disjE)
   apply (rule_tac auth=SyncSend in affects_ep)
    apply simp
   apply (simp add:insertI1)
  (* UT3 affects T3 *)
  apply (rule_tac auth=SyncSend and l' = "OrdinaryLabel (T3)" and ep="OrdinaryLabel (EP3)" in affects_send)
     apply (simp_all add:insertI1)
  done

subsubsection \<open>T3\<close>

lemma Sys3T3Reads_correct_bw : "x \<in> Sys3Reads \<Longrightarrow> x \<in> subjectReads Sys3AuthGraph (OrdinaryLabel (T3))"
  apply (simp add: Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def Sys3Reads_def)
  apply (erule disjE)
   (* T3 reads UT3 *)
   apply (rule_tac auth = Receive and ep = "OrdinaryLabel (EP3)" and a = "OrdinaryLabel (T3)" in read_sync_ep_read_senders)
      apply (simp)
     apply (simp)
    apply (rule_tac auth = Receive in reads_ep)
     apply (simp)
     apply (simp add:insertI1)
   apply (simp add: insertI1)
   (* T3 reads EP3 *)
  apply (erule disjE)
  apply (rule_tac auth = Receive in reads_ep)
    apply (simp)
    apply (simp add:insertI1)
   (* T3 reads T3 *)
  apply simp
  done

lemma Sys3T3Affects_correct_bw : "x \<in> Sys3Affects \<Longrightarrow> x \<in> subjectAffects Sys3AuthGraph (OrdinaryLabel (T3))"
  apply (simp add:Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def Sys3Affects_def)
  apply (erule disjE)
   (* T3 affects UT3 *)
   apply simp
   apply (rule_tac l = "OrdinaryLabel (T3)" and l' = "OrdinaryLabel (UT3)" and ep="OrdinaryLabel (EP3)" in affects_recv)
    apply (simp_all add:insertI1)
  (* T3 affects EP3 *)
  apply (erule disjE)
   apply (rule_tac auth=Receive in affects_ep)
    apply simp
   apply (simp add:insertI1)
  (* T3 affects T3 *)
  apply (simp add:affects_lrefl)
  done

subsubsection \<open>EP3\<close>

definition Sys3EP3Affects :: "(Sys3Labels subject_label) set"
where
  "Sys3EP3Affects \<equiv> { OrdinaryLabel (EP3) }"

lemma Sys3EP3Reads_correct_bw : "x \<in> Sys3Reads \<Longrightarrow> x \<in> subjectReads Sys3AuthGraph (OrdinaryLabel (EP3))"
  apply (simp add: Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def Sys3Reads_def)
  apply (erule disjE)
   (* EP3 reads UT3 *)
   apply simp
   apply (rule_tac a = "OrdinaryLabel (T3)" and auth=Receive and ep = "OrdinaryLabel (EP3)" and b = "OrdinaryLabel (UT3)" in read_sync_ep_read_senders)
      apply (simp)
     apply (simp add:insertI1)
    apply simp
   apply simp
  (* EP3 reads EP3 *)
  apply (erule disjE)
   apply simp
  (* EP3 reads T3 *)
  apply (rule_tac a = "OrdinaryLabel (UT3)" and auth = SyncSend and ep = "OrdinaryLabel (EP3)" and a = "OrdinaryLabel (T3)" in read_sync_ep_read_receivers)
     apply simp_all
  done

lemma Sys3EP3Affects_correct_fw : "x \<in> subjectAffects Sys3AuthGraph (OrdinaryLabel (EP3)) \<Longrightarrow> x \<in> Sys3EP3Affects"
  apply (induct x rule:subjectAffects.induct)
        apply (auto simp:Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def Sys3EP3Affects_def)
  done

lemma Sys3EP3Affects_correct_bw : "x \<in> Sys3EP3Affects \<Longrightarrow> x \<in> subjectAffects Sys3AuthGraph (OrdinaryLabel (EP3))"
  by (simp add:Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def Sys3EP3Affects_def affects_lrefl)

lemma Sys3EP3Affects_correct : "subjectAffects Sys3AuthGraph (OrdinaryLabel (EP3)) = Sys3EP3Affects"
  apply (rule subset_antisym)
   apply (simp_all add:subsetI Sys3EP3Affects_correct_fw Sys3EP3Affects_correct_bw)
  done

subsubsection \<open>Generalisations pt2\<close>

lemma Sys3Reads_correct : "l \<in> {T3, UT3, EP3} \<Longrightarrow> subjectReads Sys3AuthGraph (OrdinaryLabel (l)) = Sys3Reads"
  by (auto simp:subsetI Sys3Reads_correct_fw Sys3UT3Reads_correct_bw Sys3T3Reads_correct_bw Sys3EP3Reads_correct_bw)

lemma Sys3Affects_correct : "l \<in> {T3, UT3} \<Longrightarrow> subjectAffects Sys3AuthGraph (OrdinaryLabel (l)) = Sys3Affects"
  by (auto simp:subsetI Sys3Affects_correct_fw Sys3UT3Affects_correct_bw Sys3T3Affects_correct_bw)

subsubsection \<open>IRQ3\<close>

lemma IRQ3Reads : " d \<in> subjectReads Sys3AuthGraph (OrdinaryLabel (IRQ3)) \<Longrightarrow> d = OrdinaryLabel (IRQ3)"
  apply (simp add: Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def)
  apply (induct d rule: subjectReads.induct, auto)
  done

lemma IRQ3Affects : "d \<in> subjectAffects Sys3AuthGraph (OrdinaryLabel (IRQ3)) \<Longrightarrow> d = OrdinaryLabel (IRQ3)"
  apply (simp add: Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def)
  apply (induct d rule: subjectAffects.induct, auto)
  done

lemma IRQ3ReadsAndAffects :
  "\<lbrakk> d \<in> subjectAffects Sys3AuthGraph (OrdinaryLabel (l))
   ; d \<in> subjectReads Sys3AuthGraph (OrdinaryLabel (IRQ3))
   \<rbrakk> \<Longrightarrow> l = IRQ3"
  apply (drule IRQ3Reads)
  apply (simp add: Sys3AuthGraph_def Sys3AuthGraph_aux_def complete_AuthGraph_def)
  apply (erule subjectAffects.cases, auto)
  done

subsubsection \<open>Policy flows\<close>

lemma Sys3_policyFlows_correct_fw : "(a,b) \<in> policyFlows Sys3AuthGraph \<Longrightarrow> (a,b) \<in> Sys3PolicyFlows"
  apply (induct a b rule:policyFlows.induct)
   apply (simp add:partsSubjectAffects_def label_can_affect_partition_def)
   (* Partition l *)
   apply (erule imageE)
   apply simp
   apply (case_tac "x \<in> {T3, UT3, EP3}")
    (* x in {T3, UT3, EP3} *)
    apply (simp add:Sys3Reads_correct Sys3Reads_def)
    apply (case_tac "l \<in> {T3, UT3}")
     (* l in {T3, UT3} *)
     apply (simp add:Sys3Affects_correct Sys3Affects_def Sys3PolicyFlows_def)
     apply (erule exE)
     apply ((erule disjE)+, simp, simp, simp)+
    (* l not in {T3, UT3} *)
    apply (simp)
    apply (case_tac l)
    apply (simp, simp, simp)
       apply (auto simp:Sys3PolicyFlows_def)[1]
     apply (simp add:Sys3PolicyFlows_def)
    apply (erule exE)
    apply (erule conjE, drule IRQ3Affects)
    apply (blast)
    (* x not in {T3, UT3, EP3} *)
    apply (case_tac x)
    apply (simp, simp, simp, simp)
   apply (erule exE)
   apply (erule conjE)
      apply (frule IRQ3ReadsAndAffects, assumption)
   apply (simp add: Sys3PolicyFlows_def)
   (* PSched *)
   apply (case_tac d, simp add: Sys3PolicyFlows_def)
  apply (rename_tac a)
  apply (case_tac a)
  apply (auto simp: Sys3PolicyFlows_def)
  done

lemma Sys3_policyFlows_correct_bw : "(a,b) \<in> Sys3PolicyFlows \<Longrightarrow> (a,b) \<in> policyFlows Sys3AuthGraph"
  apply (simp add:Sys3PolicyFlows_def)
  (* All UT3/T3 cases *)
  apply (erule disjE, simp, rule policy_affects, simp add: partsSubjectAffects_def label_can_affect_partition_def, rule imageI, simp add: Sys3Affects_correct Sys3Reads_correct Sys3Affects_def Sys3Reads_def, blast)+
  (* All EP3 cases *)
  apply (erule disjE,simp, rule policy_affects, simp add: partsSubjectAffects_def label_can_affect_partition_def, rule imageI, simp add: Sys3EP3Affects_correct Sys3Reads_correct Sys3Reads_def Sys3EP3Affects_def)+
   (* IRQ3 case *)
   apply (rule_tac x = "OrdinaryLabel (IRQ3)" in exI)
   apply (rule conjI)
   apply (rule affects_lrefl)
  apply (rule reads_lrefl)
  (* All PSched cases *)
  apply (erule disjE, simp add: PSched_flows_to_all)+
  apply (simp add: PSched_flows_to_all)
  done

lemma Sys3_policyFlows_correct : "policyFlows Sys3AuthGraph = Sys3PolicyFlows"
  by (auto simp:Sys3_policyFlows_correct_fw Sys3_policyFlows_correct_bw)

end


theory ValueSimilarity
imports Value CValue Pointwise
begin

text \<open>
This theory formalizes Section 3 of \<^cite>\<open>"functionspaces"\<close>. Their domain $D$ is our type @{typ Value},
their domain $E$ is our type @{typ CValue} and $A$ corresponds to @{typ "(C \<rightarrow> CValue)"}.

In our case, the construction of the domains was taken care of by the HOLCF package
(\<^cite>\<open>"holcf"\<close>), so where \<^cite>\<open>"functionspaces"\<close> refers to elements of the domain approximations
$D_n$ resp. $E_n$, these are just elements of @{typ Value} resp. @{typ CValue} here. Therefore the
\emph{n-injection} $\phi_n^E \colon E_n \to E$ is the identity here.

The projections correspond to the take-functions generated by the HOLCF package:
\begin{alignstar}
\psi_n^E &\colon E \to E_n &\text{ corresponds to }&&@{term CValue_take}\<open>::\<close>&@{typeof "CValue_take :: nat \<Rightarrow> CValue \<rightarrow> CValue" } \\
\psi_n^A &\colon A \to A_n &\text{ corresponds to }&&@{term C_to_CValue_take}\<open>::\<close>&@{typeof "C_to_CValue_take :: nat \<Rightarrow> (C \<rightarrow> CValue) \<rightarrow> (C \<rightarrow> CValue)"} \\
\psi_n^D &\colon D \to D_n &\text{ corresponds to }&&@{term Value_take}\<open>::\<close>&@{typeof Value_take}.
\end{alignstar}

The syntactic overloading of $e(a)(c)$ to mean either $\mathrm{ |mathsf{Ap}}_{E_n}^|bot$ or $\mathrm{ |mathsf{AP}}_{E}^|bot$
turns into our non-overloaded \<open>_ \<down>CFn _\<close>\<open>::\<close>@{typeof "(\<down>CFn)"}.
\<close>

text \<open>
To have our presentation closer to \<^cite>\<open>"functionspaces"\<close>, we introduce some notation:
\<close>

notation Value_take ("\<psi>\<^sup>D\<^bsub>_\<^esub>")
notation C_to_CValue_take ("\<psi>\<^sup>A\<^bsub>_\<^esub>")
notation CValue_take ("\<psi>\<^sup>E\<^bsub>_\<^esub>")

subsubsection \<open>A note about section 2.3\<close>

text \<open>
Section 2.3 of  \<^cite>\<open>"functionspaces"\<close> contains equations (2) and (3) which do not hold in general.
We demonstrate that fact here using our corresponding definition, but the counter-example carries
over to the original formulation. Lemma (2) is a generalisation of (3) to the resourced semantics,
so the counter-example for (3) is the simpler and more educating:
\<close>

lemma counter_example:
  assumes "Equation (3)": "\<And> n d d'. \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(d \<down>Fn d') = \<psi>\<^sup>D\<^bsub>Suc n\<^esub>\<cdot>d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d'"
  shows "False"
proof-
  define n :: nat where "n = 1"
  define d where "d = Fn\<cdot>(\<Lambda> e. (e \<down>Fn \<bottom>))"
  define d' where "d' = Fn\<cdot>(\<Lambda> _. Fn\<cdot>(\<Lambda> _. \<bottom>))"
  have "Fn\<cdot>(\<Lambda> _. \<bottom>) = \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(d \<down>Fn d')"
    by (simp add: d_def d'_def n_def cfun_map_def)
  also
  have "\<dots> = \<psi>\<^sup>D\<^bsub>Suc n\<^esub>\<cdot>d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d'"
    using "Equation (3)".
  also have "\<dots> = \<bottom>"
    by (simp add: d_def d'_def n_def)
  finally show False by simp
qed

text \<open>
For completeness, and to avoid making false assertions, the counter-example to equation (2):
\<close>

lemma counter_example2:
  assumes "Equation (2)": "\<And> n e a c. \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>((e \<down>CFn a)\<cdot>c) = (\<psi>\<^sup>E\<^bsub>Suc n\<^esub>\<cdot>e \<down>CFn \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>a)\<cdot>c"
  shows "False"
proof-
  define n :: nat where "n = 1"
  define e where "e = CFn\<cdot>(\<Lambda> e r. (e\<cdot>r \<down>CFn \<bottom>)\<cdot>r)"
  define a :: "C \<rightarrow> CValue" where "a = (\<Lambda> _ . CFn\<cdot>(\<Lambda> _ _. CFn\<cdot>(\<Lambda> _ _. \<bottom>)))"
  fix c :: C
  have "CFn\<cdot>(\<Lambda> _ _. \<bottom>) = \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>((e \<down>CFn a)\<cdot>c)"
    by (simp add: e_def a_def n_def cfun_map_def)
  also
  have "\<dots> = (\<psi>\<^sup>E\<^bsub>Suc n\<^esub>\<cdot>e \<down>CFn \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>a)\<cdot>c"
    using "Equation (2)".
  also have "\<dots> = \<bottom>"
    by (simp add: e_def a_def n_def)
  finally show False by simp
qed

text \<open>A suitable substitute for the lemma can be found in 4.3.5 (1) in \<^cite>\<open>"fullabstraction"\<close>,
which in our setting becomes the following (note the extra invocation of @{term "Value_take n"} on
the left hand side):
\<close>

lemma "Abramsky 4,3,5 (1)":
  "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d') = \<psi>\<^sup>D\<^bsub>Suc n\<^esub>\<cdot>d \<down>Fn \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d'"
  by (cases d) (auto simp add: Value.take_take)

text \<open>
The problematic equations are used in the proof of the only-if direction of proposition 9 in
\<^cite>\<open>"functionspaces"\<close>. It can be fixed by applying take-induction, which inserts the
extra call to @{term "Value_take n"} in the right spot.
\<close>

subsubsection \<open>Working with @{typ Value} and @{typ CValue}\<close>

text \<open>Combined case distinguishing and induction rules.\<close>

lemma value_CValue_cases:
  obtains
  "x = \<bottom>" "y = \<bottom>" |
  f where "x = Fn\<cdot>f" "y = \<bottom>" |
  g where "x = \<bottom>" "y = CFn\<cdot>g" |
  f g where "x = Fn\<cdot>f" "y = CFn \<cdot> g" |
  b\<^sub>1 where "x = B\<cdot>(Discr b\<^sub>1)" "y = \<bottom>" |
  b\<^sub>1 g where "x = B\<cdot>(Discr b\<^sub>1)" "y = CFn\<cdot>g" |
  b\<^sub>1 b\<^sub>2 where "x = B\<cdot>(Discr b\<^sub>1)" "y = CB\<cdot>(Discr b\<^sub>2)" |
  f b\<^sub>2 where "x = Fn\<cdot>f" "y = CB\<cdot>(Discr b\<^sub>2)" |
  b\<^sub>2 where "x = \<bottom>" "y = CB\<cdot>(Discr b\<^sub>2)"
  by (metis CValue.exhaust Discr_undiscr Value.exhaust)

lemma Value_CValue_take_induct:
  assumes "adm (case_prod P)"
  assumes "\<And> n. P (\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x) (\<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y)"
  shows "P x y"
proof-
  have "case_prod P (\<Squnion>n. (\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x, \<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y))"
    by (rule admD[OF \<open>adm (case_prod P)\<close> ch2ch_Pair[OF ch2ch_Rep_cfunL[OF Value.chain_take] ch2ch_Rep_cfunL[OF C_to_CValue_chain_take]]])
       (simp add: assms(2))
  hence "case_prod P (x,y)"
    by (simp add: lub_Pair[OF ch2ch_Rep_cfunL[OF Value.chain_take] ch2ch_Rep_cfunL[OF C_to_CValue_chain_take]]
                  Value.reach C_to_CValue_reach)
  thus ?thesis by simp
qed

subsubsection \<open>Restricted similarity is defined recursively\<close>

text \<open>The base case\<close>

inductive similar'_base :: "Value \<Rightarrow> CValue \<Rightarrow> bool" where
  bot_similar'_base[simp,intro]: "similar'_base \<bottom> \<bottom>"

inductive_cases [elim!]:
   "similar'_base x y"

text \<open>The inductive case\<close>

inductive similar'_step :: "(Value \<Rightarrow> CValue \<Rightarrow> bool) \<Rightarrow> Value \<Rightarrow> CValue \<Rightarrow> bool" for s where
  bot_similar'_step[intro!]: "similar'_step s \<bottom> \<bottom>" |
  bool_similar'_step[intro]: "similar'_step s (B\<cdot>b) (CB\<cdot>b)" |
  Fun_similar'_step[intro]: "(\<And> x y . s x (y\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> s (f\<cdot>x) (g\<cdot>y\<cdot>C\<^sup>\<infinity>)) \<Longrightarrow> similar'_step s (Fn\<cdot>f) (CFn\<cdot>g)"

inductive_cases [elim!]:
   "similar'_step s x \<bottom>"
   "similar'_step s \<bottom> y"
   "similar'_step s (B\<cdot>f) (CB\<cdot>g)"
   "similar'_step s (Fn\<cdot>f) (CFn\<cdot>g)"

text \<open>
We now create the restricted similarity relation, by primitive recursion over @{term n}.

This cannot be done using an inductive definition, as it would not be monotone.
\<close>

fun similar' where
 "similar' 0 = similar'_base" |
 "similar' (Suc n) = similar'_step (similar' n)"
declare similar'.simps[simp del]

abbreviation similar'_syn  ("_ \<triangleleft>\<triangleright>\<^bsub>_\<^esub> _" [50,50,50] 50)
  where "similar'_syn x n y \<equiv> similar' n x y"

lemma similar'_botI[intro!,simp]: "\<bottom> \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<bottom>"
  by (cases n) (auto simp add: similar'.simps)

lemma similar'_FnI[intro]:
  assumes "\<And>x y.  x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> g\<cdot>y\<cdot>C\<^sup>\<infinity>"
  shows "Fn\<cdot>f \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> CFn\<cdot>g"
using assms by (auto simp add: similar'.simps)

lemma similar'_FnE[elim!]:
  assumes "Fn\<cdot>f \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> CFn\<cdot>g"
  assumes "(\<And>x y.  x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> g\<cdot>y\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> P"
  shows P
using assms by (auto simp add: similar'.simps)

lemma bot_or_not_bot':
  "x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y \<Longrightarrow> (x = \<bottom> \<longleftrightarrow> y = \<bottom>)"
  by (cases n) (auto simp add: similar'.simps elim: similar'_base.cases similar'_step.cases)

lemma similar'_bot[elim_format, elim!]:
    "\<bottom> \<triangleleft>\<triangleright>\<^bsub>n\<^esub> x \<Longrightarrow> x = \<bottom>"
    "y \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<bottom> \<Longrightarrow> y = \<bottom>"
by (metis bot_or_not_bot')+

lemma similar'_typed[simp]:
  "\<not> B\<cdot>b \<triangleleft>\<triangleright>\<^bsub>n\<^esub> CFn\<cdot>g"
  "\<not> Fn\<cdot>f \<triangleleft>\<triangleright>\<^bsub>n\<^esub> CB\<cdot>b"
  by (cases n, auto simp add: similar'.simps elim: similar'_base.cases similar'_step.cases)+

lemma similar'_bool[simp]:
  "B\<cdot>b\<^sub>1 \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> CB\<cdot>b\<^sub>2 \<longleftrightarrow> b\<^sub>1 = b\<^sub>2"
  by (auto simp add: similar'.simps elim: similar'_base.cases similar'_step.cases)

subsubsection \<open>Moving up and down the similarity relations\<close>

text \<open>
These correspond to Lemma 7 in |cite{functionspaces}.
\<close>

lemma similar'_down: "d \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e"
  and similar'_up: "d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>Suc n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e"
proof (induction n arbitrary: d e)
  case (Suc n) case 1 with  Suc
  show ?case
    by (cases d e rule:value_CValue_cases) auto
next
  case (Suc n) case 2 with Suc
  show ?case
    by (cases d e rule:value_CValue_cases) auto
qed auto

text \<open>
A generalisation of the above, doing multiple steps at once.
\<close>

lemma similar'_up_le: "n \<le> m \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e"
  by (induction rule: dec_induct )
     (auto dest: similar'_up simp add: Value.take_take CValue.take_take min_absorb2)

lemma similar'_down_le: "n \<le> m \<Longrightarrow> \<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e"
  by (induction rule: inc_induct )
     (auto dest: similar'_down simp add: Value.take_take CValue.take_take min_absorb1)

lemma similar'_take: "d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> e \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>d \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>e"
  apply (drule similar'_up)
  apply (drule similar'_down)
  apply (simp add: Value.take_take CValue.take_take)
  done

subsubsection \<open>Admissibility\<close>

text \<open>
A technical prerequisite for induction is admissibility of the predicate, i.e.\ that the predicate
holds for the limit of a chain, given that it holds for all elements.
\<close>

lemma similar'_base_adm: "adm (\<lambda> x. similar'_base (fst x) (snd x))"
proof (rule admI, goal_cases)
  case (1 Y)
  then have "Y = (\<lambda> _ . \<bottom>)" by (metis prod.exhaust fst_eqD inst_prod_pcpo similar'_base.simps snd_eqD)
  thus ?case by auto
qed

lemma similar'_step_adm:
  assumes "adm (\<lambda> x. s (fst x) (snd x))"
  shows "adm (\<lambda> x. similar'_step s (fst x) (snd x))"
proof (rule admI, goal_cases)
  case prems: (1 Y)
  from \<open>chain Y\<close>
  have "chain (\<lambda> i. fst (Y i))" by (rule ch2ch_fst)
  thus ?case
  proof(cases rule: Value_chainE)
  case bot
    hence *: "\<And> i. fst (Y i) = \<bottom>" by metis
    with prems(2)[unfolded split_beta]
    have "\<And>i. snd (Y i) = \<bottom>" by auto
    hence "Y = (\<lambda> i. (\<bottom>, \<bottom>))" using * by (metis surjective_pairing)
    thus ?thesis by auto
  next
  case (B n b)
    hence "\<forall>i. fst (Y (i + n)) = B\<cdot>b" by (metis add.commute not_add_less1)
    with prems(2)
    have "\<forall>i. Y (i + n) = (B\<cdot>b, CB\<cdot>b)"
      apply auto
      apply (erule_tac x = "i + n" in allE)
      apply (erule_tac x = "i" in allE)
      apply (erule similar'_step.cases)
      apply auto
      by (metis fst_conv old.prod.exhaust snd_conv)
    hence "similar'_step s (fst (\<Squnion> i. Y (i + n))) (snd (\<Squnion> i. Y (i + n)))" by auto
    thus ?thesis
      by (simp add: lub_range_shift[OF \<open>chain Y\<close>])
  next
    fix n
    fix Y'
    assume "chain Y'" and "(\<lambda>i. fst (Y i)) = (\<lambda> m. (if m < n then \<bottom> else Fn\<cdot>(Y' (m-n))))"
    hence Y': "\<And> i. fst (Y (i+n)) = Fn\<cdot>(Y' i)" by (metis add_diff_cancel_right' not_add_less2)
    with prems(2)[unfolded split_beta]
    have "\<And>i. \<exists> g'. snd (Y (i+n)) = CFn\<cdot>g'"
      by -(erule_tac x = "i + n" in allE, auto elim!: similar'_step.cases)
    then obtain Y'' where Y'': "\<And> i. snd (Y (i+n)) = CFn\<cdot>(Y'' i)" by metis
    from prems(1) have "\<And>i. Y i \<sqsubseteq> Y (Suc i)"
      by (simp add: po_class.chain_def)
    then have *: "\<And>i. Y (i + n) \<sqsubseteq> Y (Suc i + n)"
      by simp
    have "chain Y''"
      apply (rule chainI)
      apply (rule iffD1[OF CValue.inverts(1)])
      apply (subst (1 2) Y''[symmetric])
      apply (rule snd_monofun)
      apply (rule *)
      done

    have "similar'_step s (Fn\<cdot>(\<Squnion> i. (Y' i))) (CFn \<cdot> (\<Squnion> i. Y'' i))"
    proof (rule Fun_similar'_step)
      fix x y
      from prems(2) Y' Y''
      have "\<And>i. similar'_step s (Fn\<cdot>(Y' i)) (CFn\<cdot>(Y'' i))" by metis
      moreover
      assume "s x (y\<cdot>C\<^sup>\<infinity>)"
      ultimately
      have "\<And>i. s (Y' i\<cdot>x) (Y'' i\<cdot>y\<cdot>C\<^sup>\<infinity>)" by auto
      hence "case_prod s (\<Squnion> i. ((Y' i)\<cdot>x, (Y'' i)\<cdot>y\<cdot>C\<^sup>\<infinity>))"
        apply -
        apply (rule admD[OF adm_case_prod[where P = "\<lambda>_ . s", OF assms]])
        apply (simp add:  \<open>chain Y'\<close>  \<open>chain Y''\<close>)
        apply simp
        done
      thus "s ((\<Squnion> i. Y' i)\<cdot>x) ((\<Squnion> i. Y'' i)\<cdot>y\<cdot>C\<^sup>\<infinity>)"
        by (simp add: lub_Pair  ch2ch_Rep_cfunL contlub_cfun_fun  \<open>chain Y'\<close>  \<open>chain Y''\<close>)
    qed
    hence "similar'_step s (fst (\<Squnion> i. Y (i+n))) (snd (\<Squnion> i. Y (i+n)))"
      by (simp add: Y' Y''
          cont2contlubE[OF cont_fst chain_shift[OF prems(1)]]  cont2contlubE[OF cont_snd chain_shift[OF prems(1)]]
           contlub_cfun_arg[OF \<open>chain Y''\<close>] contlub_cfun_arg[OF \<open>chain Y'\<close>])
    thus "similar'_step s (fst (\<Squnion> i. Y i)) (snd (\<Squnion> i. Y i))"
      by (simp add: lub_range_shift[OF \<open>chain Y\<close>])
  qed
qed

lemma similar'_adm: "adm (\<lambda>x. fst x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> snd x)"
  by (induct n) (auto simp add: similar'.simps intro: similar'_base_adm similar'_step_adm)

lemma similar'_admI: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. f x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> g x)"
  by (rule adm_subst[OF _ similar'_adm, where t = "\<lambda>x. (f x, g x)", simplified]) auto

subsubsection \<open>The real similarity relation\<close>

text \<open>
This is the goal of the theory: A relation between @{typ Value} and @{typ CValue}.
\<close>

definition similar :: "Value \<Rightarrow> CValue \<Rightarrow> bool" (infix "\<triangleleft>\<triangleright>" 50) where
  "x \<triangleleft>\<triangleright> y \<longleftrightarrow> (\<forall>n. \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y)"

lemma similarI:
  "(\<And> n. \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y) \<Longrightarrow> x \<triangleleft>\<triangleright> y"
  unfolding similar_def by blast

lemma similarE:
  "x \<triangleleft>\<triangleright> y \<Longrightarrow> \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y"
  unfolding similar_def by blast

lemma similar_bool[simp]: "B\<cdot>b \<triangleleft>\<triangleright> CB\<cdot>b"
  by (rule similarI, case_tac n, auto)

lemma [elim_format, elim!]: "x \<triangleleft>\<triangleright> \<bottom> \<Longrightarrow> x = \<bottom>"
  unfolding similar_def
  apply (cases x)
  apply auto
  apply (erule_tac x = "Suc 0" in allE, auto)+
  done

lemma [elim_format, elim!]: "x \<triangleleft>\<triangleright> CB\<cdot>b \<Longrightarrow> x = B\<cdot>b"
  unfolding similar_def
  apply (cases x)
  apply auto
  apply (erule_tac x = "Suc 0" in allE, auto)+
  done

lemma [elim_format, elim!]: "\<bottom> \<triangleleft>\<triangleright> y \<Longrightarrow> y = \<bottom>"
  unfolding similar_def
  apply (cases y)
  apply auto
  apply (erule_tac x = "Suc 0" in allE, auto)+
  done

lemma [elim_format, elim!]: "B\<cdot>b \<triangleleft>\<triangleright> y \<Longrightarrow> y = CB\<cdot>b"
  unfolding similar_def
  apply (cases y)
  apply auto
  apply (erule_tac x = "Suc 0" in allE, auto)+
  done

lemma take_similar'_similar:
  assumes "x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y"
  shows  "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y"
proof(rule similarI)
  fix m
  from assms
  have "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y" by (rule similar'_take)
  moreover
  have "n \<le> m \<or> m \<le> n" by auto
  ultimately
  show "\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>(\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x) \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>(\<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>y)"
    by (auto elim: similar'_up_le similar'_down_le dest: similar'_take
        simp add: min_absorb2 min_absorb1 Value.take_take CValue.take_take)
qed

lemma bot_or_not_bot:
  "x \<triangleleft>\<triangleright> y \<Longrightarrow> (x = \<bottom> \<longleftrightarrow> y = \<bottom>)"
  by (cases x y rule:value_CValue_cases) auto

lemma bool_or_not_bool:
  "x \<triangleleft>\<triangleright> y \<Longrightarrow> (x = B\<cdot>b) \<longleftrightarrow> (y = CB\<cdot>b)"
  by (cases x y rule:value_CValue_cases) auto

lemma slimilar_bot_cases[consumes 1, case_names bot bool Fn]:
  assumes "x \<triangleleft>\<triangleright> y"
  obtains "x = \<bottom>" "y = \<bottom>" |
  b where "x = B\<cdot>(Discr b)" "y = CB\<cdot>(Discr b)" |
  f g where "x = Fn\<cdot>f" "y = CFn \<cdot> g"
using assms
by (metis CValue.exhaust Value.exhaust bool_or_not_bool bot_or_not_bot discr.exhaust)

lemma similar_adm: "adm (\<lambda>x. fst x \<triangleleft>\<triangleright> snd x)"
  unfolding similar_def
  by (intro adm_lemmas similar'_admI cont2cont)

lemma similar_admI: "cont f \<Longrightarrow> cont g \<Longrightarrow> adm (\<lambda>x. f x \<triangleleft>\<triangleright> g x)"
  by (rule adm_subst[OF _ similar_adm, where t = "\<lambda>x. (f x, g x)", simplified]) auto

text \<open>
Having constructed the relation we can how show that it indeed is the desired relation,
relating $|bot$ with $|bot$ and functions with functions, if they take related arguments to related values.
This corresponds to Proposition 9 in |cite{functionspaces}.
\<close>

lemma similar_nice_def: "x \<triangleleft>\<triangleright> y \<longleftrightarrow> (x = \<bottom> \<and> y = \<bottom> \<or> (\<exists> b. x = B\<cdot>(Discr b) \<and> y = CB\<cdot>(Discr b)) \<or> (\<exists> f g. x = Fn\<cdot>f \<and> y = CFn\<cdot>g \<and> (\<forall> a b. a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity> \<longrightarrow> f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>)))"
  (is "?L \<longleftrightarrow> ?R")
proof
  assume "?L"
  thus "?R"
  proof (cases x y rule:slimilar_bot_cases)
    case bot thus ?thesis by simp
  next
    case bool thus ?thesis by simp
  next
    case (Fn f g)
    note \<open>?L\<close>[unfolded Fn]
    have "\<forall>a b. a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity> \<longrightarrow> f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>"
    proof(intro impI allI)
      fix a b
      assume "a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity>"

      show "f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>"
      proof(rule similarI)
        fix n
        have "adm (\<lambda>(b, a). \<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>b) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(g\<cdot>a\<cdot>C\<^sup>\<infinity>))"
          by (intro adm_case_prod similar'_admI cont2cont)
        thus "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>a) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(g\<cdot>b\<cdot>C\<^sup>\<infinity>)"
        proof (induct a b rule: Value_CValue_take_induct[consumes 1])
          txt \<open>This take induction is required to avoid the wrong equation shown above.\<close>
          fix m

          from \<open>a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity>\<close>
          have "\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a \<triangleleft>\<triangleright>\<^bsub>m\<^esub> \<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>(b\<cdot>C\<^sup>\<infinity>)" by (rule similarE)
          hence "\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a \<triangleleft>\<triangleright>\<^bsub>max m n\<^esub> \<psi>\<^sup>E\<^bsub>m\<^esub>\<cdot>(b\<cdot>C\<^sup>\<infinity>)" by (rule similar'_up_le[rotated]) auto
          moreover
          from \<open>Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g\<close>
          have "\<psi>\<^sup>D\<^bsub>Suc (max m n)\<^esub>\<cdot>(Fn\<cdot>f) \<triangleleft>\<triangleright>\<^bsub>Suc (max m n)\<^esub> \<psi>\<^sup>E\<^bsub>Suc (max m n)\<^esub>\<cdot>(CFn\<cdot>g)" by (rule similarE)
          ultimately
          have "\<psi>\<^sup>D\<^bsub>max m n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>max m n\<^esub>\<cdot>(\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a))) \<triangleleft>\<triangleright>\<^bsub>max m n\<^esub> \<psi>\<^sup>E\<^bsub>max m n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>A\<^bsub>max m n\<^esub>\<cdot>(\<psi>\<^sup>A\<^bsub>m\<^esub>\<cdot>b))\<cdot>C\<^sup>\<infinity>)"
            by auto
          hence " \<psi>\<^sup>D\<^bsub>max m n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a)) \<triangleleft>\<triangleright>\<^bsub>max m n\<^esub> \<psi>\<^sup>E\<^bsub>max m n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>A\<^bsub>m\<^esub>\<cdot>b)\<cdot>C\<^sup>\<infinity>)"
            by (simp add: Value.take_take cfun_map_map CValue.take_take ID_def eta_cfun min_absorb2 min_absorb1)
          thus "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>m\<^esub>\<cdot>a)) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>A\<^bsub>m\<^esub>\<cdot>b)\<cdot>C\<^sup>\<infinity>)"
            by (rule similar'_down_le[rotated]) auto
        qed
      qed
    qed
    thus ?thesis unfolding Fn by simp
  qed
next
  assume "?R"
  thus "?L"
  proof(elim conjE disjE exE ssubst)
    show "\<bottom> \<triangleleft>\<triangleright> \<bottom>" by simp
  next
    fix b
    show "B\<cdot>(Discr b) \<triangleleft>\<triangleright> CB\<cdot>(Discr b)" by simp
  next
    fix f g
    assume imp: "\<forall>a b. a \<triangleleft>\<triangleright> b\<cdot>C\<^sup>\<infinity> \<longrightarrow> f\<cdot>a \<triangleleft>\<triangleright> g\<cdot>b\<cdot>C\<^sup>\<infinity>"
    show "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
    proof (rule similarI)
      fix n
      show "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(Fn\<cdot>f) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(CFn\<cdot>g)"
      proof(cases n)
        case 0 thus ?thesis by simp
      next
        case (Suc n)
        { fix x y
          assume "x \<triangleleft>\<triangleright>\<^bsub>n\<^esub> y\<cdot>C\<^sup>\<infinity>"
          hence "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x \<triangleleft>\<triangleright> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(y\<cdot>C\<^sup>\<infinity>)" by (rule take_similar'_similar)
          hence "f\<cdot>(\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x) \<triangleleft>\<triangleright> g\<cdot>(\<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y)\<cdot>C\<^sup>\<infinity>" using imp by auto
          hence "\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>(f\<cdot>(\<psi>\<^sup>D\<^bsub>n\<^esub>\<cdot>x)) \<triangleleft>\<triangleright>\<^bsub>n\<^esub> \<psi>\<^sup>E\<^bsub>n\<^esub>\<cdot>(g\<cdot>(\<psi>\<^sup>A\<^bsub>n\<^esub>\<cdot>y)\<cdot>C\<^sup>\<infinity>)"
            by (rule similarE)
        }
        with Suc
        show ?thesis by auto
      qed
    qed
  qed
qed

lemma similar_FnI[intro]:
  assumes "\<And>x y.  x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright> g\<cdot>y\<cdot>C\<^sup>\<infinity>"
  shows "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
by (metis assms similar_nice_def)

lemma similar_FnD[elim!]:
  assumes "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
  assumes "x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity>"
  shows "f\<cdot>x \<triangleleft>\<triangleright> g\<cdot>y\<cdot>C\<^sup>\<infinity>"
using assms
by (subst (asm) similar_nice_def) auto

lemma similar_FnE[elim!]:
  assumes "Fn\<cdot>f \<triangleleft>\<triangleright> CFn\<cdot>g"
  assumes "(\<And>x y.  x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity> \<Longrightarrow> f\<cdot>x \<triangleleft>\<triangleright> g\<cdot>y\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> P"
  shows P
by (metis assms similar_FnD)

subsubsection \<open>The similarity relation lifted pointwise to functions.\<close>

abbreviation fun_similar :: "('a::type \<Rightarrow> Value) \<Rightarrow> ('a \<Rightarrow> (C \<rightarrow> CValue)) \<Rightarrow> bool"  (infix "\<triangleleft>\<triangleright>\<^sup>*" 50) where
  "fun_similar \<equiv> pointwise (\<lambda>x y. x \<triangleleft>\<triangleright> y\<cdot>C\<^sup>\<infinity>)"

lemma fun_similar_fmap_bottom[simp]: "\<bottom> \<triangleleft>\<triangleright>\<^sup>* \<bottom>"
  by auto

lemma fun_similarE[elim]:
  assumes "m \<triangleleft>\<triangleright>\<^sup>* m'"
  assumes "(\<And>x. (m  x) \<triangleleft>\<triangleright> (m' x)\<cdot>C\<^sup>\<infinity>) \<Longrightarrow> Q"
  shows Q
  using assms unfolding pointwise_def by blast

end


(* Author: Alexander Maletzky *)

section \<open>Degree Sections of Power-Products\<close>

theory Degree_Section
  imports Polynomials.MPoly_PM
begin

definition deg_sect :: "'x set \<Rightarrow> nat \<Rightarrow> ('x::countable \<Rightarrow>\<^sub>0 nat) set"
  where "deg_sect X d = .[X] \<inter> {t. deg_pm t = d}"

definition deg_le_sect :: "'x set \<Rightarrow> nat \<Rightarrow> ('x::countable \<Rightarrow>\<^sub>0 nat) set"
  where "deg_le_sect X d = (\<Union>d0\<le>d. deg_sect X d0)"

lemma deg_sectI: "t \<in> .[X] \<Longrightarrow> deg_pm t = d \<Longrightarrow> t \<in> deg_sect X d"
  by (simp add: deg_sect_def)

lemma deg_sectD:
  assumes "t \<in> deg_sect X d"
  shows "t \<in> .[X]" and "deg_pm t = d"
  using assms by (simp_all add: deg_sect_def)

lemma deg_le_sect_alt: "deg_le_sect X d = .[X] \<inter> {t. deg_pm t \<le> d}"
  by (auto simp: deg_le_sect_def deg_sect_def)

lemma deg_le_sectI: "t \<in> .[X] \<Longrightarrow> deg_pm t \<le> d \<Longrightarrow> t \<in> deg_le_sect X d"
  by (simp add: deg_le_sect_alt)

lemma deg_le_sectD:
  assumes "t \<in> deg_le_sect X d"
  shows "t \<in> .[X]" and "deg_pm t \<le> d"
  using assms by (simp_all add: deg_le_sect_alt)

lemma deg_sect_zero [simp]: "deg_sect X 0 = {0}"
  by (auto simp: deg_sect_def zero_in_PPs)

lemma deg_sect_empty: "deg_sect {} d = (if d = 0 then {0} else {})"
  by (auto simp: deg_sect_def)

lemma deg_sect_singleton [simp]: "deg_sect {x} d = {Poly_Mapping.single x d}"
  by (auto simp: deg_sect_def deg_pm_single PPs_singleton)

lemma deg_le_sect_zero [simp]: "deg_le_sect X 0 = {0}"
  by (auto simp: deg_le_sect_def)

lemma deg_le_sect_empty [simp]: "deg_le_sect {} d = {0}"
  by (auto simp: deg_le_sect_alt varnum_eq_zero_iff)

lemma deg_le_sect_singleton: "deg_le_sect {x} d = Poly_Mapping.single x ` {..d}"
  by (auto simp: deg_le_sect_alt deg_pm_single PPs_singleton)

lemma deg_sect_mono: "X \<subseteq> Y \<Longrightarrow> deg_sect X d \<subseteq> deg_sect Y d"
  by (auto simp: deg_sect_def dest: PPs_mono)

lemma deg_le_sect_mono_1: "X \<subseteq> Y \<Longrightarrow> deg_le_sect X d \<subseteq> deg_le_sect Y d"
  by (auto simp: deg_le_sect_alt dest: PPs_mono)

lemma deg_le_sect_mono_2: "d1 \<le> d2 \<Longrightarrow> deg_le_sect X d1 \<subseteq> deg_le_sect X d2"
  by (auto simp: deg_le_sect_alt)

lemma zero_in_deg_le_sect: "0 \<in> deg_le_sect n d"
  by (simp add: deg_le_sect_alt zero_in_PPs)

lemma deg_sect_disjoint: "d1 \<noteq> d2 \<Longrightarrow> deg_sect X d1 \<inter> deg_sect Y d2 = {}"
  by (auto simp: deg_sect_def)

lemma deg_le_sect_deg_sect_disjoint: "d1 < d2 \<Longrightarrow> deg_le_sect Y d1 \<inter> deg_sect X d2 = {}"
  by (auto simp: deg_sect_def deg_le_sect_alt)

lemma deg_sect_insert:
  "deg_sect (insert x X) d = (\<Union>d0\<le>d. (+) (Poly_Mapping.single x (d - d0)) ` deg_sect X d0)"
    (is "?A = ?B")
proof (rule set_eqI)
  fix t
  show "t \<in> ?A \<longleftrightarrow> t \<in> ?B"
  proof
    assume "t \<in> ?A"
    hence "t \<in> .[insert x X]" and "deg_pm t = d" by (rule deg_sectD)+
    from this(1) obtain e tx where "tx \<in> .[X]" and t: "t = Poly_Mapping.single x e + tx"
      by (rule PPs_insertE)
    have "e + deg_pm tx = deg_pm t" by (simp add: t deg_pm_plus deg_pm_single)
    hence "e + deg_pm tx = d" by (simp only: \<open>deg_pm t = d\<close>)
    hence "deg_pm tx \<in> {..d}" and e: "e = d - deg_pm tx" by simp_all
    from \<open>tx \<in> .[X]\<close> refl have "tx \<in> deg_sect X (deg_pm tx)" by (rule deg_sectI)
    hence "t \<in> (+) (Poly_Mapping.single x (d - deg_pm tx)) ` deg_sect X (deg_pm tx)"
      unfolding t e by (rule imageI)
    with \<open>deg_pm tx \<in> {..d}\<close> show "t \<in> ?B" ..
  next
    assume "t \<in> ?B"
    then obtain d0 where "d0 \<in> {..d}" and "t \<in> (+) (Poly_Mapping.single x (d - d0)) ` deg_sect X d0" ..
    from this(2) obtain s where s: "s \<in> deg_sect X d0"
      and t: "t = Poly_Mapping.single x (d - d0) + s" (is "t = ?s + s") ..
    show "t \<in> ?A"
    proof (rule deg_sectI)
      have "?s \<in> .[insert x X]" by (rule PPs_closed_single, simp)
      from s have "s \<in> .[X]" by (rule deg_sectD)
      also have "... \<subseteq> .[insert x X]" by (rule PPs_mono, blast)
      finally have "s \<in> .[insert x X]" .
      with \<open>?s \<in> .[insert x X]\<close> show "t \<in> .[insert x X]" unfolding t by (rule PPs_closed_plus)
    next
      from s have "deg_pm s = d0" by (rule deg_sectD)
      moreover from \<open>d0 \<in> {..d}\<close> have "d0 \<le> d" by simp
      ultimately show "deg_pm t = d" by (simp add: t deg_pm_single deg_pm_plus)
    qed
  qed
qed

lemma deg_le_sect_Suc: "deg_le_sect X (Suc d) = deg_le_sect X d \<union> deg_sect X (Suc d)"
  by (simp add: deg_le_sect_def atMost_Suc Un_commute)

lemma deg_le_sect_Suc_2:
  "deg_le_sect X (Suc d) = insert 0 (\<Union>x\<in>X. (+) (Poly_Mapping.single x 1) ` deg_le_sect X d)"
    (is "?A = ?B")
proof -
  have eq1: "{Suc 0..Suc d} = Suc ` {..d}" by (simp add: image_Suc_atMost)
  have "insert 0 {1..Suc d} = {..Suc d}" by fastforce
  hence "?A = (\<Union>d0\<in>insert 0 {1..Suc d}. deg_sect X d0)" by (simp add: deg_le_sect_def)
  also have "... = insert 0 (\<Union>d0\<le>d. deg_sect X (Suc d0))" by (simp add: eq1)
  also have "... = insert 0 (\<Union>d0\<le>d. (\<Union>x\<in>X. (+) (Poly_Mapping.single x 1) ` deg_sect X d0))"
    by (simp only: deg_sect_Suc)
  also have "... = insert 0 (\<Union>x\<in>X. (+) (Poly_Mapping.single x 1) ` (\<Union>d0\<le>d. deg_sect X d0))"
    by fastforce
  also have "... = ?B" by (simp only: deg_le_sect_def)
  finally show ?thesis .
qed

lemma finite_deg_sect:
  assumes "finite X"
  shows "finite ((deg_sect X d)::('x::countable \<Rightarrow>\<^sub>0 nat) set)"
proof (induct d)
  case 0
  show ?case by simp
next
  case (Suc d)
  with assms show ?case by (simp add: deg_sect_Suc)
qed

corollary finite_deg_le_sect: "finite X \<Longrightarrow> finite ((deg_le_sect X d)::('x::countable \<Rightarrow>\<^sub>0 nat) set)"
  by (simp add: deg_le_sect_def finite_deg_sect)

lemma keys_subset_deg_le_sectI:
  assumes "p \<in> P[X]" and "poly_deg p \<le> d"
  shows "keys p \<subseteq> deg_le_sect X d"
proof
  fix t
  assume "t \<in> keys p"
  also from assms(1) have "... \<subseteq> .[X]" by (rule PolysD)
  finally have "t \<in> .[X]" .
  from \<open>t \<in> keys p\<close> have "deg_pm t \<le> poly_deg p" by (rule poly_deg_max_keys)
  from this assms(2) have "deg_pm t \<le> d" by (rule le_trans)
  with \<open>t \<in> .[X]\<close> show "t \<in> deg_le_sect X d" by (rule deg_le_sectI)
qed

lemma binomial_symmetric_plus: "(n + k) choose n = (n + k) choose k"
  by (metis add_diff_cancel_left' binomial_symmetric le_add1)

lemma card_deg_sect:
  assumes "finite X" and "X \<noteq> {}"
  shows "card (deg_sect X d) = (d + (card X - 1)) choose (card X - 1)"
  using assms
proof (induct X arbitrary: d)
  case empty
  thus ?case by simp
next
  case (insert x X)
  from insert(1, 2) have eq1: "card (insert x X) = Suc (card X)" by simp
  show ?case
  proof (cases "X = {}")
    case True
    thus ?thesis by simp
  next
    case False
    with insert.hyps(1) have "0 < card X" by (simp add: card_gt_0_iff)
    let ?f = "\<lambda>d0. Poly_Mapping.single x (d - d0)"
    from False have eq2: "card (deg_sect X d0) = d0 + (card X - 1) choose (card X - 1)" for d0
      by (rule insert.hyps)
    have "finite {..d}" by simp
    moreover from insert.hyps(1) have "\<forall>d0\<in>{..d}. finite ((+) (?f d0) ` deg_sect X d0)"
      by (simp add: finite_deg_sect)
    moreover have "\<forall>d0\<in>{..d}. \<forall>d1\<in>{..d}. d0 \<noteq> d1 \<longrightarrow>
                          ((+) (?f d0) ` deg_sect X d0) \<inter> ((+) (?f d1) ` deg_sect X d1) = {}"
    proof (intro ballI impI, rule ccontr)
      fix d1 d2 :: nat
      assume "d1 \<noteq> d2"
      assume "((+) (?f d1) ` deg_sect X d1) \<inter> ((+) (?f d2) ` deg_sect X d2) \<noteq> {}"
      then obtain t where "t \<in> ((+) (?f d1) ` deg_sect X d1) \<inter> ((+) (?f d2) ` deg_sect X d2)"
        by blast
      hence t1: "t \<in> (+) (?f d1) ` deg_sect X d1" and t2: "t \<in> (+) (?f d2) ` deg_sect X d2" by simp_all
      from t1 obtain s1 where "s1 \<in> deg_sect X d1" and s1: "t = ?f d1 + s1" ..
      from this(1) have "s1 \<in> .[X]" by (rule deg_sectD)
      hence "keys s1 \<subseteq> X" by (rule PPsD)
      with insert.hyps(2) have eq3: "lookup s1 x = 0" by (auto simp: in_keys_iff)
      from t2 obtain s2 where "s2 \<in> deg_sect X d2" and s2: "t = ?f d2 + s2" ..
      from this(1) have "s2 \<in> .[X]" by (rule deg_sectD)
      hence "keys s2 \<subseteq> X" by (rule PPsD)
      with insert.hyps(2) have eq4: "lookup s2 x = 0" by (auto simp: in_keys_iff)
      from s2 have "lookup (?f d1 + s1) x = lookup (?f d2 + s2) x" by (simp only: s1)
      hence "d - d1 = d - d2" by (simp add: lookup_add eq3 eq4)
      moreover assume "d1 \<in> {..d}" and "d2 \<in> {..d}"
      ultimately have "d1 = d2" by simp
      with \<open>d1 \<noteq> d2\<close> show False ..
    qed
    ultimately have "card (deg_sect (insert x X) d) =
                       (\<Sum>d0\<le>d. card ((+) (monomial (d - d0) x) ` deg_sect X d0))"
      unfolding deg_sect_insert by (rule card_UN_disjoint)
    also from refl have "... = (\<Sum>d0\<le>d. card (deg_sect X d0))"
    proof (rule sum.cong)
      fix d0
      have "inj_on ((+) (monomial (d - d0) x)) (deg_sect X d0)" by (rule, rule add_left_imp_eq)
      thus "card ((+) (monomial (d - d0) x) ` deg_sect X d0) = card (deg_sect X d0)"
        by (rule card_image)
    qed
    also have "... = (\<Sum>d0\<le>d. (card X - 1) + d0 choose (card X - 1))" by (simp only: eq2 add.commute)
    also have "... = (\<Sum>d0\<le>d. (card X - 1) + d0 choose d0)" by (simp only: binomial_symmetric_plus)
    also have "... = Suc ((card X - 1) + d) choose d" by (rule sum_choose_lower)
    also from \<open>0 < card X\<close> have "... = d + (card (insert x X) - 1) choose d"
      by (simp add: eq1 add.commute)
    also have "... = d + (card (insert x X) - 1) choose (card (insert x X) - 1)"
      by (fact binomial_symmetric_plus)
    finally show ?thesis .
  qed
qed

corollary card_deg_sect_Suc:
  assumes "finite X"
  shows "card (deg_sect X (Suc d)) = (d + card X) choose (Suc d)"
proof (cases "X = {}")
  case True
  thus ?thesis by (simp add: deg_sect_empty)
next
  case False
  with assms have "0 < card X" by (simp add: card_gt_0_iff)
  from assms False have "card (deg_sect X (Suc d)) = (Suc d + (card X - 1)) choose (card X - 1)"
    by (rule card_deg_sect)
  also have "... = (Suc d + (card X - 1)) choose (Suc d)" by (rule sym, rule binomial_symmetric_plus)
  also from \<open>0 < card X\<close> have "... = (d + card X) choose (Suc d)" by simp
  finally show ?thesis .
qed

corollary card_deg_le_sect:
  assumes "finite X"
  shows "card (deg_le_sect X d) = (d + card X) choose card X"
proof (induct d)
  case 0
  show ?case by simp
next
  case (Suc d)
  from assms have "finite (deg_le_sect X d)" by (rule finite_deg_le_sect)
  moreover from assms have "finite (deg_sect X (Suc d))" by (rule finite_deg_sect)
  moreover from lessI have "deg_le_sect X d \<inter> deg_sect X (Suc d) = {}"
    by (rule deg_le_sect_deg_sect_disjoint)
  ultimately have "card (deg_le_sect X (Suc d)) = card (deg_le_sect X d) + card (deg_sect X (Suc d))"
    unfolding deg_le_sect_Suc by (rule card_Un_disjoint)
  also from assms have "... = (Suc d + card X) choose Suc d"
    by (simp add: Suc.hyps card_deg_sect_Suc binomial_symmetric_plus[of d])
  also have "... = (Suc d + card X) choose card X" by (rule binomial_symmetric_plus)
  finally show ?case .
qed

end (* theory *)


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2021-2022 Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *)

section \<open> Alternative definitions of uniformity \<close>

theory UniformSpace_ZF_2 imports UniformSpace_ZF
begin

text\<open> The \<open>UniformSpace_ZF\<close> theory defines uniform spaces based on entourages (also called surroundings
  sometimes). In this theory we consider an alternative definition based of the
  notion of uniform covers.
  \<close>

subsection\<open> Uniform covers \<close>

text\<open> Given a set $X$ we can consider collections of subsets of $X$ whose unions are equal to $X$.
  Any such collection is called a cover of $X$. We can define relation on the set of covers
  of $X$, called "star refinement" (definition below). A collection of covers is a
  "family of uniform covers" if it is a filter with respect to the start refinement ordering.
  A member of such family is called a "uniform cover", but one has to remember that this notion
  has meaning only in the contexts a the whole family of uniform covers. Looking at a specific cover
  in isolation we can not say whether it is a uniform cover or not.  \<close>

text\<open> The set of all covers of $X$ is called \<open>Covers(X)\<close>. \<close>

definition
  "Covers(X) \<equiv> {P \<in> Pow(Pow(X)). \<Union>P = X}"

text\<open>A cover of a nonempty set must have a nonempty member.\<close>

lemma cover_nonempty: assumes "X\<noteq>0" "P \<in> Covers(X)"
  shows "\<exists>U\<in>P. U\<noteq>0"
  using assms unfolding Covers_def by blast

text\<open> A "star" of $R$ with respect to $\mathcal{R}$ is the union of all $S\in \mathcal{R}$ that
  intersect $R$. \<close>

definition
  "Star(R,\<R>) \<equiv> \<Union>{S\<in>\<R>. S\<inter>R \<noteq> 0}"

text\<open>An element of $\mathcal{R}$ is a subset of its star with respect to $\mathcal{R}$. \<close>

lemma element_subset_star: assumes "U\<in>P" shows "U \<subseteq> Star(U,P)"
  using assms unfolding Star_def by auto

text\<open>An alternative formula for star of a singleton.\<close>

lemma star_singleton: shows "(\<Union>{V\<times>V. V\<in>P})``{x} = Star({x},P)"
  unfolding Star_def by blast

text\<open>Star of a larger set is larger.\<close>

lemma star_mono: assumes "U\<subseteq>V" shows "Star(U,P) \<subseteq> Star(V,P)"
  using assms unfolding Star_def by blast

text\<open>In particular, star of a set is larger than star of any singleton in that set.\<close>

corollary star_single_mono: assumes "x\<in>U" shows "Star({x},P) \<subseteq> Star(U,P)"
  using assms star_mono by auto

text\<open>A cover $\mathcal{R}$ (of $X$) is said to be a "barycentric refinement" of a cover $\mathcal{C}$
  iff for every $x\in X$ the star of $\{x\}$ in $\mathcal{R}$ is contained
  in some $C\in \mathcal{C}$. \<close>

definition
  IsBarycentricRefinement ("_ <\<^sup>B _" 90)
  where "P <\<^sup>B Q \<equiv> \<forall>x\<in>\<Union>P.\<exists>U\<in>Q.  Star({x},P) \<subseteq> U"

text\<open>A cover is a barycentric refinement of the collection of stars of the singletons
  $\{x \}$ as $x$ ranges over $X$.\<close>

lemma singl_star_bary:
  assumes "P \<in> Covers(X)" shows "P <\<^sup>B {Star({x},P). x\<in>X}"
  using assms unfolding Covers_def IsBarycentricRefinement_def by blast

text\<open> A cover $\mathcal{R}$ is a "star refinement" of a cover $\mathcal{C}$  iff
  for each $R\in \mathcal{R}$ there is a $C\in \mathcal{C}$ such that the star of $R$ with
  respect to $\mathcal{R}$ is contained in $C$. \<close>

definition
  IsStarRefinement ("_ <\<^sup>* _" 90)
  where "P <\<^sup>* Q \<equiv> \<forall>U\<in>P.\<exists>V\<in>Q. Star(U,P) \<subseteq> V"

text\<open>Every cover star-refines the trivial cover $\{ X\}$. \<close>

lemma cover_stref_triv: assumes "P \<in> Covers(X)" shows "P <\<^sup>* {X}"
  using assms unfolding Star_def IsStarRefinement_def Covers_def by auto

text\<open>Star refinement implies barycentric refinement. \<close>

lemma star_is_bary: assumes "Q\<in>Covers(X)" and "Q <\<^sup>* P"
  shows "Q <\<^sup>B P"
proof -
  from assms(1) have "\<Union>Q = X" unfolding Covers_def by simp
  { fix x assume "x\<in>X"
    with \<open>\<Union>Q = X\<close> obtain R where "R\<in>Q" and "x\<in>R" by auto
    with assms(2) obtain U where "U\<in>P" and "Star(R,Q) \<subseteq> U"
      unfolding IsStarRefinement_def by auto
    from \<open>x\<in>R\<close> \<open>Star(R,Q) \<subseteq> U\<close> have "Star({x},Q) \<subseteq> U"
      using star_single_mono by blast
    with \<open>U\<in>P\<close> have "\<exists>U\<in>P. Star({x},Q) \<subseteq> U" by auto
 } with \<open>\<Union>Q = X\<close> show ?thesis unfolding IsBarycentricRefinement_def
    by simp
qed

text\<open> Barycentric refinement of a barycentric refinement is a star refinement. \<close>

lemma bary_bary_star:
  assumes "P\<in>Covers(X)" "Q\<in>Covers(X)" "R\<in>Covers(X)" "P <\<^sup>B Q" "Q <\<^sup>B R" "X\<noteq>0"
  shows "P <\<^sup>* R"
proof -
  { fix U assume "U\<in>P"
    { assume "U = 0"
      then have "Star(U,P) = 0" unfolding Star_def by simp
      from assms(6,3) obtain V where "V\<in>R" using cover_nonempty by auto
      with \<open>Star(U,P) = 0\<close> have "\<exists>V\<in>R. Star(U,P) \<subseteq> V" by auto
    }
    moreover
    { assume "U\<noteq>0"
      then obtain x\<^sub>0 where "x\<^sub>0\<in>U" by auto
      with assms(1,2,5) \<open>U\<in>P\<close> obtain V where "V\<in>R" and "Star({x\<^sub>0},Q) \<subseteq> V"
        unfolding Covers_def IsBarycentricRefinement_def by auto
      have "Star(U,P) \<subseteq> V"
      proof -
        { fix W assume "W\<in>P" and "W\<inter>U \<noteq> 0"
          from \<open>W\<inter>U \<noteq> 0\<close> obtain x where "x\<in>W\<inter>U" by auto
          with assms(2) \<open>U\<in>P\<close> have  "x\<in>\<Union>P" by auto
          with assms(4) obtain C where "C\<in>Q" and "Star({x},P) \<subseteq> C"
            unfolding IsBarycentricRefinement_def by blast
          with \<open>U\<in>P\<close> \<open>W\<in>P\<close> \<open>x\<in>W\<inter>U\<close> \<open>x\<^sub>0\<in>U\<close> \<open>Star({x\<^sub>0},Q) \<subseteq> V\<close> have "W\<subseteq>V"
            unfolding Star_def by blast
        } then show "Star(U,P) \<subseteq> V" unfolding Star_def by auto
      qed
      with \<open>V\<in>R\<close> have "\<exists>V\<in>R. Star(U,P) \<subseteq> V" by auto
    }
    ultimately have "\<exists>V\<in>R. Star(U,P) \<subseteq> V" by auto
  } then show "P <\<^sup>* R" unfolding IsStarRefinement_def by simp
qed

text\<open>The notion of a filter defined in \<open>Topology_ZF_4\<close> is not sufficiently general to use it to
  define uniform covers, so we write the conditions directly. A nonempty
  collection $\Theta$ of covers of $X$ is a family of uniform covers if

  a) if $\mathcal{R} \in \Theta$ and $\mathcal{C}$ is any cover of $X$ such that $\mathcal{R}$ is
  a star refinement of $\mathcal{C}$, then $\mathcal{C} \in \Theta$.

  b) For any $\mathcal{C},\mathcal{D} \in \Theta$ there is some $\mathcal{R}\in\Theta$
  such that $\mathcal{R}$ is a star refinement of both $\mathcal{C}$ and $\mathcal{R}$.

  This departs slightly from the definition in Wikipedia that requires that $\Theta$ contains the
  trivial cover $\{ X\}$. As we show in lemma \<open>unicov_contains_trivial\<close> below we don't loose
  anything by weakening the definition this way.
  \<close>

definition
  AreUniformCovers ("_ {are uniform covers of} _" 90)
  where "\<Theta> {are uniform covers of} X \<equiv>  \<Theta> \<subseteq> Covers(X) \<and> \<Theta>\<noteq>0 \<and>
  (\<forall>\<R>\<in>\<Theta>.\<forall>\<C>\<in>Covers(X). ((\<R> <\<^sup>* \<C>) \<longrightarrow> \<C>\<in>\<Theta>)) \<and>
  (\<forall>\<C>\<in>\<Theta>.\<forall>\<D>\<in>\<Theta>.\<exists>\<R>\<in>\<Theta>.(\<R> <\<^sup>* \<C>) \<and> (\<R> <\<^sup>* \<D>))"

text\<open>A family of uniform covers contain the trivial cover $\{ X\}$.\<close>

lemma unicov_contains_triv: assumes "\<Theta> {are uniform covers of} X"
  shows "{X} \<in> \<Theta>"
proof -
  from assms obtain \<R> where "\<R>\<in>\<Theta>" unfolding AreUniformCovers_def by blast
  with assms show ?thesis using cover_stref_triv
    unfolding AreUniformCovers_def Covers_def by auto
qed

text\<open>If $\Theta$ are uniform covers of $X$ then we can recover $X$ from $\Theta$ by taking
  $\bigcup\bigcup \Theta$. \<close>

lemma space_from_unicov: assumes "\<Theta> {are uniform covers of} X" shows "X = \<Union>\<Union>\<Theta>"
proof
  from assms show "X \<subseteq> \<Union>\<Union>\<Theta>" using unicov_contains_triv
    unfolding AreUniformCovers_def by auto
  from assms show "\<Union>\<Union>\<Theta> \<subseteq> X" unfolding AreUniformCovers_def Covers_def
    by auto
qed

text\<open> Every uniform cover has a star refinement. \<close>

lemma unicov_has_star_ref:
  assumes "\<Theta> {are uniform covers of} X" and "P\<in>\<Theta>"
  shows "\<exists>Q\<in>\<Theta>. (Q <\<^sup>* P)"
  using assms unfolding AreUniformCovers_def by blast

text\<open> In particular, every uniform cover has a barycentric refinement. \<close>

corollary unicov_has_bar_ref:
  assumes "\<Theta> {are uniform covers of} X" and "P\<in>\<Theta>"
  shows "\<exists>Q\<in>\<Theta>. (Q <\<^sup>B P)"
proof -
  from assms obtain Q where "Q\<in>\<Theta>" and "Q <\<^sup>* P"
    using unicov_has_star_ref by blast
  with assms show ?thesis
    unfolding AreUniformCovers_def using star_is_bary by blast
qed

text\<open> From the definition of uniform covers we know that if a uniform cover $P$
  is a star-refinement of a cover $Q$ then $Q$ is in a uniform cover. The next lemma
  shows that in order for $Q$ to be a uniform cover it is sufficient that $P$ is a
  barycentric refinement of $Q$. \<close>

lemma unicov_bary_cov:
  assumes "\<Theta> {are uniform covers of} X" "P\<in>\<Theta>" "Q \<in> Covers(X)" "P <\<^sup>B Q" and "X\<noteq>0"
  shows "Q\<in>\<Theta>"
proof -
  from assms(1,2) obtain R where "R\<in>\<Theta>" and "R <\<^sup>B P"
    using unicov_has_bar_ref by blast
  from assms(1,2,3) \<open>R\<in>\<Theta>\<close> have
    "P \<in> Covers(X)" "Q \<in> Covers(X)" "R \<in> Covers(X)"
    unfolding AreUniformCovers_def by auto
  with assms(1,3,4,5) \<open>R\<in>\<Theta>\<close> \<open>R <\<^sup>B P\<close> show ?thesis
    using bary_bary_star unfolding AreUniformCovers_def by auto
qed

text\<open> A technical lemma to simplify proof of the \<open>uniformity_from_unicov\<close> theorem. \<close>

lemma star_ref_mem: assumes "U\<in>P" "P<\<^sup>*Q" and "\<Union>{W\<times>W. W\<in>Q} \<subseteq> A"
  shows "U\<times>U \<subseteq> A"
proof -
  from assms(1,2) obtain W where "W\<in>Q" and "\<Union>{S\<in>P. S\<inter>U \<noteq> 0} \<subseteq> W"
    unfolding IsStarRefinement_def Star_def by auto
  with assms(1,3) show "U\<times>U \<subseteq> A" by blast
qed

text\<open>An identity related to square (in the sense of composition) of a relation of the
  form $\bigcup \{U\times U : U\in P\}$.
  I am amazed that Isabelle can see that this is true without an explicit proof, I can't. \<close>

lemma rel_square_starr: shows
  "(\<Union>{U\<times>U. U\<in>P}) O (\<Union>{U\<times>U. U\<in>P}) = \<Union>{U\<times>Star(U,P). U\<in>P}"
  unfolding Star_def by blast

text\<open> An identity similar to \<open>rel_square_starr\<close> but with \<open>Star\<close> on the left side of the Cartesian
  product: \<close>

lemma rel_square_starl: shows
  "(\<Union>{U\<times>U. U\<in>P}) O (\<Union>{U\<times>U. U\<in>P}) = \<Union>{Star(U,P)\<times>U. U\<in>P}"
  unfolding Star_def by blast

text\<open>A somewhat technical identity about the square of a symmetric relation: \<close>

lemma rel_sq_image:
  assumes "W = converse(W)"  "domain(W) \<subseteq> X"
  shows "Star({x},{W``{t}. t\<in>X}) = (W O W)``{x}"
proof
  have I: "Star({x},{W``{t}. t\<in>X}) = \<Union>{S\<in>{W``{t}. t\<in>X}. x\<in>S}"
    unfolding Star_def by auto
  { fix y assume "y \<in> Star({x},{W``{t}. t\<in>X})"
    with I obtain S where "y\<in>S" "x\<in>S" "S \<in> {W``{t}. t\<in>X}" by auto
    from \<open>S \<in> {W``{t}. t\<in>X}\<close> obtain t where "t\<in>X" and "S = W``{t}"
      by auto
    with \<open>x\<in>S\<close> \<open>y\<in>S\<close> have "\<langle>t,x\<rangle> \<in> W" and "\<langle>t,y\<rangle> \<in> W"
      by auto
    from \<open>\<langle>t,x\<rangle> \<in> W\<close> have "\<langle>x,t\<rangle> \<in> converse(W)" by auto
    with assms(1) \<open>\<langle>t,y\<rangle> \<in> W\<close> have "y \<in> (W O W)``{x}"
      using rel_compdef by auto
  } then show "Star({x},{W``{t}. t\<in>X}) \<subseteq> (W O W)``{x}"
    by blast
  { fix y assume "y\<in>(W O W)``{x}"
    then obtain t where "\<langle>x,t\<rangle> \<in> W" and "\<langle>t,y\<rangle> \<in> W"
      using rel_compdef by auto
    from assms(2) \<open>\<langle>t,y\<rangle> \<in> W\<close> have "t\<in>X" by auto
    from \<open>\<langle>x,t\<rangle> \<in> W\<close> have "\<langle>t,x\<rangle> \<in> converse(W)" by auto
    with assms(1) I \<open>\<langle>t,y\<rangle> \<in> W\<close> \<open>t\<in>X\<close> have "y \<in> Star({x},{W``{t}. t\<in>X})"
      by auto
  } then show "(W O W)``{x} \<subseteq> Star({x},{W``{t}. t\<in>X})"
    by blast
qed

text\<open> Given a family of uniform covers of $X$ we can create a uniformity on $X$ by taking the supersets
  of $\bigcup \{A\times A: A\in P \}$ as $P$ ranges over the uniform covers. The next definition
  specifies the operation creating entourages from uniform covers. \<close>

definition
  "UniformityFromUniCov(X,\<Theta>) \<equiv> Supersets(X\<times>X,{\<Union>{U\<times>U. U\<in>P}. P\<in>\<Theta>})"

text\<open>For any member $P$ of a cover $\Theta$ the set $\bigcup \{U\times U : U\in P\}$
  is a member of \<open>UniformityFromUniCov(X,\<Theta>)\<close>. \<close>

lemma basic_unif: assumes "\<Theta> \<subseteq> Covers(X)" "P\<in>\<Theta>"
  shows "\<Union>{U\<times>U. U\<in>P} \<in> UniformityFromUniCov(X,\<Theta>)"
  using assms unfolding UniformityFromUniCov_def Supersets_def Covers_def
  by blast

text\<open>If $\Theta$ is a family of uniform covers of $X$ then
  \<open>UniformityFromUniCov(X,\<Theta>)\<close> is a uniformity on $X$ \<close>

theorem uniformity_from_unicov:
  assumes "\<Theta> {are uniform covers of} X" "X\<noteq>0"
  shows "UniformityFromUniCov(X,\<Theta>) {is a uniformity on} X"
proof -
  let ?\<Phi> = "UniformityFromUniCov(X,\<Theta>)"
  have "?\<Phi> {is a filter on} (X\<times>X)"
  proof -
    have "0 \<notin> ?\<Phi>"
    proof -
      { assume "0 \<in> ?\<Phi>"
        then obtain P where "P\<in>\<Theta>" and "0 = \<Union>{U\<times>U. U\<in>P}"
          unfolding UniformityFromUniCov_def Supersets_def by auto
        hence "\<Union>P = 0" by auto
        with assms \<open>P\<in>\<Theta>\<close> have False unfolding AreUniformCovers_def Covers_def
          by auto
      } thus ?thesis by auto
    qed
    moreover have "X\<times>X \<in> ?\<Phi>"
    proof -
      from assms have "X\<times>X \<in> {\<Union>{U\<times>U. U\<in>P}. P\<in>\<Theta>}"
        using unicov_contains_triv unfolding AreUniformCovers_def
        by auto
      then show ?thesis unfolding Supersets_def UniformityFromUniCov_def
        by blast
    qed
    moreover have "?\<Phi> \<subseteq> Pow(X\<times>X)"
      unfolding UniformityFromUniCov_def Supersets_def by auto
    moreover have "\<forall>A\<in>?\<Phi>.\<forall>B\<in>?\<Phi>. A\<inter>B \<in> ?\<Phi>"
    proof -
      { fix A B assume "A\<in>?\<Phi>" "B\<in>?\<Phi>"
        then have "A\<inter>B \<subseteq> X\<times>X" unfolding UniformityFromUniCov_def Supersets_def
          by auto
        from \<open>A\<in>?\<Phi>\<close> \<open>B\<in>?\<Phi>\<close> obtain P\<^sub>A P\<^sub>B where
          "P\<^sub>A\<in>\<Theta>" "P\<^sub>B\<in>\<Theta>" and I:"\<Union>{U\<times>U. U\<in>P\<^sub>A} \<subseteq> A"  "\<Union>{U\<times>U. U\<in>P\<^sub>B} \<subseteq> B"
          unfolding UniformityFromUniCov_def Supersets_def by auto
        from assms(1) \<open>P\<^sub>A\<in>\<Theta>\<close> \<open>P\<^sub>B\<in>\<Theta>\<close> obtain P
          where "P\<in>\<Theta>" and "P<\<^sup>*P\<^sub>A" and "P<\<^sup>*P\<^sub>B"
          unfolding AreUniformCovers_def by blast
        have "\<Union>{U\<times>U. U\<in>P} \<subseteq> A\<inter>B"
        proof -
          { fix U assume "U\<in>P"
            with \<open>P<\<^sup>*P\<^sub>A\<close>  \<open>P<\<^sup>*P\<^sub>B\<close> I have "U\<times>U \<subseteq> A" and "U\<times>U \<subseteq> B"
              using star_ref_mem by auto
          } thus ?thesis by blast
        qed
        with \<open>A\<inter>B \<subseteq> X\<times>X\<close> \<open>P\<in>\<Theta>\<close> have "A\<inter>B \<in> ?\<Phi>"
          unfolding Supersets_def UniformityFromUniCov_def by auto
      } thus ?thesis by auto
    qed
    moreover have
      "\<forall>B\<in>?\<Phi>.\<forall>C\<in>Pow(X\<times>X). B\<subseteq>C \<longrightarrow> C\<in>?\<Phi>"
    proof -
      { fix B C assume "B\<in>?\<Phi>" "C\<in>Pow(X\<times>X)" "B\<subseteq>C"
        from \<open>B\<in>?\<Phi>\<close> obtain P\<^sub>B where  "\<Union>{U\<times>U. U\<in>P\<^sub>B} \<subseteq> B" "P\<^sub>B\<in>\<Theta>"
          unfolding UniformityFromUniCov_def Supersets_def by auto
        with \<open>C\<in>Pow(X\<times>X)\<close> \<open>B\<subseteq>C\<close> have "C\<in>?\<Phi>"
          unfolding UniformityFromUniCov_def Supersets_def by blast
      } thus ?thesis by auto
    qed
    ultimately show ?thesis unfolding IsFilter_def by simp
  qed
  moreover have "\<forall>A\<in>?\<Phi>. id(X) \<subseteq> A \<and> (\<exists>B\<in>?\<Phi>. B O B \<subseteq> A) \<and> converse(A) \<in> ?\<Phi>"
  proof
    fix A assume "A\<in>?\<Phi>"
    then obtain P where "\<Union>{U\<times>U. U\<in>P} \<subseteq> A" "P\<in>\<Theta>"
      unfolding UniformityFromUniCov_def Supersets_def by auto
    have "id(X)\<subseteq>A"
    proof -
      from assms(1) \<open>P\<in>\<Theta>\<close> have "\<Union>P = X" unfolding AreUniformCovers_def Covers_def
        by auto
      with \<open>\<Union>{U\<times>U. U\<in>P} \<subseteq> A\<close> show ?thesis by auto
    qed
    moreover have "\<exists>B\<in>?\<Phi>. B O B \<subseteq> A"
    proof -
      from assms(1) \<open>P\<in>\<Theta>\<close> have "\<Union>{U\<times>U. U\<in>P} \<in> ?\<Phi>"
        unfolding AreUniformCovers_def Covers_def UniformityFromUniCov_def Supersets_def
        by auto
      from assms(1) \<open>P\<in>\<Theta>\<close> obtain Q where "Q\<in>\<Theta>" and  "Q <\<^sup>* P" using unicov_has_star_ref
        by blast
      let ?B = "\<Union>{U\<times>U. U\<in>Q}"
      from assms(1) \<open>Q\<in>\<Theta>\<close> have "?B \<in> ?\<Phi>"
        unfolding AreUniformCovers_def Covers_def UniformityFromUniCov_def Supersets_def
        by auto
      moreover have "?B O ?B \<subseteq> A"
      proof -
        have II: "?B O ?B = \<Union>{U\<times>Star(U,Q). U\<in>Q}" using rel_square_starr
          by simp
        have "\<forall>U\<in>Q. \<exists>V\<in>P. U\<times>Star(U,Q) \<subseteq> V\<times>V"
        proof
          fix U assume "U\<in>Q"
          with \<open>Q <\<^sup>* P\<close> obtain V where "V\<in>P" and "Star(U,Q) \<subseteq> V"
            unfolding IsStarRefinement_def by blast
          with \<open>U\<in>Q\<close> have "V\<in>P" and "U\<times>Star(U,Q) \<subseteq> V\<times>V" using element_subset_star
            by auto
          thus "\<exists>V\<in>P. U\<times>Star(U,Q) \<subseteq> V\<times>V" by auto
        qed
        hence "\<Union>{U\<times>Star(U,Q). U\<in>Q} \<subseteq> \<Union>{V\<times>V. V\<in>P}" by blast
        with \<open>\<Union>{V\<times>V. V\<in>P} \<subseteq> A\<close> have "\<Union>{U\<times>Star(U,Q). U\<in>Q} \<subseteq> A" by blast
        with II show ?thesis by simp
      qed
      ultimately show ?thesis by auto
    qed
    moreover from \<open>A\<in>?\<Phi>\<close> \<open>P\<in>\<Theta>\<close> \<open>\<Union>{U\<times>U. U\<in>P} \<subseteq> A\<close> have "converse(A) \<in> ?\<Phi>"
      unfolding AreUniformCovers_def UniformityFromUniCov_def Supersets_def
      by auto
    ultimately show "id(X) \<subseteq> A \<and> (\<exists>B\<in>?\<Phi>. B O B \<subseteq> A) \<and> converse(A) \<in> ?\<Phi>"
      by simp
  qed
  ultimately show "?\<Phi>  {is a uniformity on} X" unfolding IsUniformity_def
    by simp
qed

text\<open>Given a uniformity $\Phi$ on $X$ we can create a family of uniform covers by taking the
  collection of covers $P$ for which there exist an entourage $U\in \Phi$ such that
  for each $x\in X$, there is an $A\in P$ such that $U(\{ x\}) \subseteq A$. The next definition
  specifies the operation of creating a family of uniform covers from a uniformity. \<close>

definition
  "UniCovFromUniformity(X,\<Phi>) \<equiv> {P\<in>Covers(X). \<exists>U\<in>\<Phi>.\<forall>x\<in>X.\<exists>A\<in>P. U``({x}) \<subseteq> A}"

text\<open>When we convert the quantifiers into unions and intersections in the definition
  of \<open>UniCovFromUniformity\<close> we get an alternative definition of the operation
  that creates a family of uniform covers from a uniformity. Just a curiosity, not used anywhere.\<close>

lemma UniCovFromUniformityDef: assumes "X\<noteq>0"
  shows "UniCovFromUniformity(X,\<Phi>) = (\<Union>U\<in>\<Phi>.\<Inter>x\<in>X. {P\<in>Covers(X). \<exists>A\<in>P. U``({x}) \<subseteq> A})"
proof -
  have "{P\<in>Covers(X). \<exists>U\<in>\<Phi>.\<forall>x\<in>X.\<exists>A\<in>P. U``({x}) \<subseteq> A} =
  (\<Union>U\<in>\<Phi>.\<Inter>x\<in>X. {P\<in>Covers(X). \<exists>A\<in>P. U``({x}) \<subseteq> A})"
  proof
  { fix P assume "P\<in>{P\<in>Covers(X). \<exists>U\<in>\<Phi>.\<forall>x\<in>X.\<exists>A\<in>P. U``({x}) \<subseteq> A}"
    then have "P\<in>Covers(X)" and "\<exists>U\<in>\<Phi>.\<forall>x\<in>X.\<exists>A\<in>P. U``({x}) \<subseteq> A" by auto
    then obtain U where "U\<in>\<Phi>" and "\<forall>x\<in>X.\<exists>A\<in>P. U``({x}) \<subseteq> A" by auto
    with assms \<open>P\<in>Covers(X)\<close> have "P \<in> (\<Inter>x\<in>X. {P\<in>Covers(X). \<exists>A\<in>P. U``({x}) \<subseteq> A})"
      by auto
    with \<open>U\<in>\<Phi>\<close>  have "P\<in>(\<Union>U\<in>\<Phi>.\<Inter>x\<in>X. {P\<in>Covers(X). \<exists>A\<in>P. U``({x}) \<subseteq> A})"
      by blast
  } then show
    "{P\<in>Covers(X). \<exists>U\<in>\<Phi>.\<forall>x\<in>X.\<exists>A\<in>P. U``({x}) \<subseteq> A} \<subseteq>
    (\<Union>U\<in>\<Phi>.\<Inter>x\<in>X. {P\<in>Covers(X). \<exists>A\<in>P. U``({x}) \<subseteq> A})"
    using subset_iff by simp
  { fix P assume "P\<in>(\<Union>U\<in>\<Phi>.\<Inter>x\<in>X. {P\<in>Covers(X). \<exists>A\<in>P. U``({x}) \<subseteq> A})"
    then obtain U where "U\<in>\<Phi>" "P \<in> (\<Inter>x\<in>X. {P\<in>Covers(X). \<exists>A\<in>P. U``({x}) \<subseteq> A})"
      by auto
    with assms have "P\<in>Covers(X)" and "\<forall>x\<in>X.\<exists>A\<in>P. U``({x}) \<subseteq> A" by auto
    with \<open>U\<in>\<Phi>\<close> have "P\<in>{P\<in>Covers(X). \<exists>U\<in>\<Phi>.\<forall>x\<in>X.\<exists>A\<in>P. U``({x}) \<subseteq> A}"
      by auto
  } then show "(\<Union>U\<in>\<Phi>.\<Inter>x\<in>X. {P\<in>Covers(X). \<exists>A\<in>P. U``({x}) \<subseteq> A}) \<subseteq>
    {P\<in>Covers(X). \<exists>U\<in>\<Phi>.\<forall>x\<in>X.\<exists>A\<in>P. U``({x}) \<subseteq> A}" by auto
  qed
  then show ?thesis unfolding UniCovFromUniformity_def by simp
qed

text\<open>If $\Phi$ is a (diagonal) uniformity on $X$, then covers of the form
  $\{ W\{ x\} : x\in X\}$ are members of \<open>UniCovFromUniformity(X,\<Phi>)\<close>. \<close>

lemma cover_image:
  assumes "\<Phi> {is a uniformity on} X" "W\<in>\<Phi>"
  shows "{W``{x}. x\<in>X} \<in> UniCovFromUniformity(X,\<Phi>)"
proof -
  let ?P = "{W``{x}. x\<in>X}"
  have "?P \<in> Covers(X)"
  proof -
    from assms have "W \<subseteq> X\<times>X" and "?P \<in> Pow(Pow(X))"
      using entourage_props(1) by auto
    moreover have "\<Union>?P = X"
    proof
      from \<open>W \<subseteq> X\<times>X\<close> show "\<Union>?P \<subseteq> X" by auto
      from assms show "X \<subseteq> \<Union>?P" using neigh_not_empty(2) by auto
    qed
    ultimately show ?thesis unfolding Covers_def by simp
  qed
  moreover from assms(2) have "\<exists>W\<in>\<Phi>. \<forall>x\<in>X. \<exists>A\<in>?P. W``{x} \<subseteq> A"
    by auto
  ultimately show ?thesis unfolding UniCovFromUniformity_def
    by simp
qed

text\<open>If $\Phi$ is a (diagonal) uniformity on $X$, then every two elements
  of  \<open>UniCovFromUniformity(X,\<Phi>)\<close> have a common barycentric refinement.\<close>

lemma common_bar_refinemnt:
  assumes
    "\<Phi> {is a uniformity on} X"
    "\<Theta> = UniCovFromUniformity(X,\<Phi>)"
    "\<C>\<in>\<Theta>" "\<D>\<in>\<Theta>"
  shows "\<exists>\<R>\<in>\<Theta>.(\<R> <\<^sup>B \<C>) \<and> (\<R> <\<^sup>B \<D>)"
proof -
  from assms(2,3) obtain U where "U\<in>\<Phi>" and I: "\<forall>x\<in>X.\<exists>C\<in>\<C>. U``{x} \<subseteq> C"
    unfolding UniCovFromUniformity_def by auto
  from assms(2,4) obtain V where "V\<in>\<Phi>" and II: "\<forall>x\<in>X.\<exists>D\<in>\<D>. V``{x} \<subseteq> D"
    unfolding UniCovFromUniformity_def by auto
  from assms(1) \<open>U\<in>\<Phi>\<close> \<open>V\<in>\<Phi>\<close> have "U\<inter>V \<in> \<Phi>"
    unfolding IsUniformity_def IsFilter_def by auto
  with assms(1) obtain W where "W\<in>\<Phi>" and "W O W \<subseteq> U\<inter>V" and "W=converse(W)"
    using half_size_symm by blast
  from assms(1) \<open>W\<in>\<Phi>\<close> have "domain(W) \<subseteq> X"
    unfolding IsUniformity_def IsFilter_def by auto
  let ?P = "{W``{t}. t\<in>X}"
  have "?P\<in>\<Theta>" "?P <\<^sup>B \<C>" "?P <\<^sup>B \<D>"
  proof -
    from assms(1,2) \<open>W\<in>\<Phi>\<close> show "?P\<in>\<Theta>" using cover_image by simp
    with assms(2) have "\<Union>?P = X" unfolding UniCovFromUniformity_def Covers_def
      by simp
    { fix x assume "x\<in>X"
      from \<open>W=converse(W)\<close> \<open>domain(W) \<subseteq> X\<close> \<open>W O W \<subseteq> U\<inter>V\<close>
      have "Star({x},?P) \<subseteq> U``{x}" and "Star({x},?P) \<subseteq> V``{x}"
        using rel_sq_image by auto
      from \<open>x\<in>X\<close> I obtain C where "C\<in>\<C>" and "U``{x} \<subseteq> C"
        by auto
      with \<open>Star({x},?P) \<subseteq> U``{x}\<close> \<open>C\<in>\<C>\<close> have "\<exists>C\<in>\<C>. Star({x},?P) \<subseteq> C"
        by auto
      moreover
      from \<open>x\<in>X\<close> II obtain D where "D\<in>\<D>" and "V``{x} \<subseteq> D"
        by auto
      with \<open>Star({x},?P) \<subseteq> V``{x}\<close> \<open>D\<in>\<D>\<close> have "\<exists>D\<in>\<D>. Star({x},?P) \<subseteq> D"
        by auto
      ultimately have "\<exists>C\<in>\<C>. Star({x},?P) \<subseteq> C" and "\<exists>D\<in>\<D>. Star({x},?P) \<subseteq> D"
        by auto
    } hence "\<forall>x\<in>X. \<exists>C\<in>\<C>. Star({x},?P) \<subseteq> C" and "\<forall>x\<in>X.\<exists>D\<in>\<D>. Star({x},?P) \<subseteq> D"
      by auto
    with \<open>\<Union>?P = X\<close> show "?P <\<^sup>B \<C>" and "?P <\<^sup>B \<D>"
      unfolding IsBarycentricRefinement_def by auto
  qed
  thus ?thesis by auto
qed

text\<open>If $\Phi$ is a (diagonal) uniformity on $X$, then every element
  of  \<open>UniCovFromUniformity(X,\<Phi>)\<close> has a barycentric refinement there.\<close>

corollary bar_refinement_ex:
  assumes "\<Phi> {is a uniformity on} X" "\<Theta> = UniCovFromUniformity(X,\<Phi>)" "\<C> \<in> \<Theta>"
  shows "\<exists>\<R>\<in>\<Theta>. (\<R> <\<^sup>B \<C>)"
  using assms common_bar_refinemnt by blast

text\<open> If $\Phi$ is a (diagonal) uniformity on $X$, then \<open>UniCovFromUniformity(X,\<Phi>)\<close> is
  a family of uniform covers.\<close>

theorem unicov_from_uniformity: assumes "\<Phi> {is a uniformity on} X" and "X\<noteq>0"
  shows "UniCovFromUniformity(X,\<Phi>) {are uniform covers of} X"
proof -
  let ?\<Theta> = "UniCovFromUniformity(X,\<Phi>)"
  from assms(1) have "?\<Theta> \<subseteq> Covers(X)" unfolding UniCovFromUniformity_def
    by auto
  moreover
  from assms(1) have "{X} \<in> ?\<Theta>"
    unfolding Covers_def IsUniformity_def IsFilter_def UniCovFromUniformity_def
    by auto
  hence "?\<Theta> \<noteq> 0" by auto
  moreover have "\<forall>\<R>\<in>?\<Theta>.\<forall>\<C>\<in>Covers(X). ((\<R> <\<^sup>* \<C>) \<longrightarrow> \<C>\<in>?\<Theta>)"
  proof -
    { fix \<R> \<C> assume "\<R>\<in>?\<Theta>" "\<C>\<in>Covers(X)" "\<R> <\<^sup>* \<C>"
      have "\<C>\<in>?\<Theta>"
      proof -
        from \<open>\<R>\<in>?\<Theta>\<close> obtain U where "U\<in>\<Phi>" and I: "\<forall>x\<in>X.\<exists>R\<in>\<R>. U``({x}) \<subseteq> R"
          unfolding UniCovFromUniformity_def by auto
        { fix x assume "x\<in>X"
          with I obtain R where "R\<in>\<R>" and "U``({x}) \<subseteq> R" by auto
          from \<open>R\<in>\<R>\<close> \<open>\<R> <\<^sup>* \<C>\<close> obtain C where "C\<in>\<C>" and "Star(R,\<R>) \<subseteq> C"
            unfolding IsStarRefinement_def by auto
          with \<open>U``({x}) \<subseteq> R\<close> \<open>R\<in>\<R>\<close> have "U``({x}) \<subseteq> C"
            using element_subset_star by blast
          with \<open>C\<in>\<C>\<close> have "\<exists>C\<in>\<C>. U``({x}) \<subseteq> C" by auto
        } hence "\<forall>x\<in>X.\<exists>C\<in>\<C>. U``({x}) \<subseteq> C" by auto
        with \<open>U\<in>\<Phi>\<close> \<open>\<C>\<in>Covers(X)\<close> show ?thesis unfolding UniCovFromUniformity_def
          by auto
      qed
    } thus ?thesis by auto
  qed
  moreover have "\<forall>\<C>\<in>?\<Theta>.\<forall>\<D>\<in>?\<Theta>.\<exists>\<R>\<in>?\<Theta>.(\<R> <\<^sup>* \<C>) \<and> (\<R> <\<^sup>* \<D>)"
  proof -
    { fix \<C> \<D> assume "\<C>\<in>?\<Theta>" "\<D>\<in>?\<Theta>"
      with assms(1) obtain P where "P\<in>?\<Theta>" and "P <\<^sup>B \<C>" "P <\<^sup>B \<D>"
        using common_bar_refinemnt by blast
      from assms(1) \<open>P\<in>?\<Theta>\<close> obtain \<R> where "\<R>\<in>?\<Theta>" and "\<R> <\<^sup>B P"
        using bar_refinement_ex by blast
      from \<open>\<R>\<in>?\<Theta>\<close> \<open>P\<in>?\<Theta>\<close> \<open>\<C>\<in>?\<Theta>\<close> \<open>\<D>\<in>?\<Theta>\<close> have
        "P \<in> Covers(X)" "\<R> \<in> Covers(X)" "\<C> \<in> Covers(X)" "\<D> \<in> Covers(X)"
        unfolding UniCovFromUniformity_def by auto
      with assms(2) \<open>\<R> <\<^sup>B P\<close> \<open>P <\<^sup>B \<C>\<close> \<open>P <\<^sup>B \<D>\<close> have "\<R> <\<^sup>* \<C>" and "\<R> <\<^sup>* \<D>"
        using bary_bary_star by auto
      with \<open>\<R>\<in>?\<Theta>\<close> have "\<exists>\<R>\<in>?\<Theta>.(\<R> <\<^sup>* \<C>) \<and> (\<R> <\<^sup>* \<D>)" by auto
    } thus ?thesis by simp
  qed
  ultimately show ?thesis unfolding AreUniformCovers_def by simp
qed

text\<open> The \<open>UniCovFromUniformity\<close> operation is the inverse of \<open>UniformityFromUniCov\<close>. \<close>

theorem unicov_from_unif_inv: assumes "\<Theta> {are uniform covers of} X" "X\<noteq>0"
  shows "UniCovFromUniformity(X,UniformityFromUniCov(X,\<Theta>)) = \<Theta>"
proof
  let ?\<Phi> = "UniformityFromUniCov(X,\<Theta>)"
  let ?L = "UniCovFromUniformity(X,?\<Phi>)"
  from assms have I: "?\<Phi> {is a uniformity on} X"
    using uniformity_from_unicov by simp
  with assms(2) have II: "?L {are uniform covers of} X"
    using unicov_from_uniformity by simp
  { fix P assume "P\<in>?L"
    with I obtain Q where "Q\<in>?L" and "Q <\<^sup>B P"
      using bar_refinement_ex by blast
    from \<open>Q\<in>?L\<close> obtain U where "U\<in>?\<Phi>" and III:"\<forall>x\<in>X.\<exists>A\<in>Q. U``{x} \<subseteq> A"
      unfolding UniCovFromUniformity_def by auto
    from \<open>U\<in>?\<Phi>\<close> have "U \<in> Supersets(X\<times>X,{\<Union>{U\<times>U. U\<in>P}. P\<in>\<Theta>})"
      unfolding UniformityFromUniCov_def by simp
    then obtain B where "B\<subseteq>X\<times>X" "B\<subseteq>U" and "\<exists>C\<in>{\<Union>{U\<times>U. U\<in>P}. P\<in>\<Theta>}. C\<subseteq>B"
      unfolding Supersets_def by auto
    then obtain C where "C \<in> {\<Union>{U\<times>U. U\<in>P}. P\<in>\<Theta>}" and "C\<subseteq>B" by auto
    then obtain R where "R\<in>\<Theta>" and "C = \<Union>{V\<times>V. V\<in>R}" by auto
    with \<open>C\<subseteq>B\<close> \<open>B\<subseteq>U\<close> have "\<Union>{V\<times>V. V\<in>R} \<subseteq> U" by auto
    from assms(1) II \<open>P\<in>?L\<close> \<open>Q\<in>?L\<close> \<open>R\<in>\<Theta>\<close> have
      IV: "P\<in>Covers(X)" "Q\<in>Covers(X)" "R\<in>Covers(X)"
      unfolding AreUniformCovers_def by auto
    have "R <\<^sup>B Q"
    proof -
      { fix x assume "x\<in>X"
        with III obtain A where "A\<in>Q" and "U``{x} \<subseteq> A" by auto
        with \<open>\<Union>{V\<times>V. V\<in>R} \<subseteq> U\<close> have "(\<Union>{V\<times>V. V\<in>R})``{x} \<subseteq> A"
          by auto
        with \<open>A\<in>Q\<close> have "\<exists>A\<in>Q. Star({x},R) \<subseteq> A" using star_singleton by auto
      } then have "\<forall>x\<in>X. \<exists>A\<in>Q. Star({x},R) \<subseteq> A" by simp
      moreover from \<open>R\<in>Covers(X)\<close> have "\<Union>R = X" unfolding Covers_def
        by simp
      ultimately show ?thesis unfolding IsBarycentricRefinement_def
        by simp
    qed
    with assms(2) \<open>Q <\<^sup>B P\<close> IV have "R <\<^sup>* P" using bary_bary_star by simp
    with assms(1) \<open>R\<in>\<Theta>\<close> \<open>P\<in>Covers(X)\<close> have "P\<in>\<Theta>"
      unfolding AreUniformCovers_def by simp
  } thus "?L\<subseteq>\<Theta>" by auto
  { fix P assume "P\<in>\<Theta>"
    with assms(1) have "P \<in> Covers(X)"
      unfolding AreUniformCovers_def by auto
    from assms(1) \<open>P\<in>\<Theta>\<close> obtain Q where "Q \<in> \<Theta>" and "Q <\<^sup>B P"
      using unicov_has_bar_ref by blast
    let ?A = "\<Union>{V\<times>V. V\<in>Q}"
    have "?A \<in> ?\<Phi>"
    proof -
      from assms(1) \<open>Q\<in>\<Theta>\<close> have "?A \<subseteq> X\<times>X" and "?A \<in> {\<Union>{V\<times>V. V\<in>Q}. Q\<in>\<Theta>}"
        unfolding AreUniformCovers_def Covers_def by auto
      then show ?thesis
        using superset_gen unfolding UniformityFromUniCov_def
        by auto
    qed
    with I obtain B where "B\<in>?\<Phi>" "B O B \<subseteq> ?A" and "B=converse(B)"
      using half_size_symm by blast
    let ?R = "{B``{x}. x\<in>X}"
    from I II \<open>B\<in>?\<Phi>\<close> have "?R\<in>?L" and "\<Union>?R =X"
      using cover_image unfolding UniCovFromUniformity_def Covers_def
      by auto
    have "?R <\<^sup>B P"
    proof -
      { fix x assume "x\<in>X"
        from assms(1) \<open>Q \<in> \<Theta>\<close> have "\<Union>Q = X"
          unfolding AreUniformCovers_def Covers_def by auto
        with \<open>Q <\<^sup>B P\<close> \<open>x\<in>X\<close> obtain C where "C\<in>P" and "Star({x},Q) \<subseteq> C"
          unfolding IsBarycentricRefinement_def by auto
        from \<open>B=converse(B)\<close> I \<open>B\<in>?\<Phi>\<close> have "Star({x},?R) = (B O B)``{x}"
          using  uni_domain rel_sq_image by auto
        moreover from  \<open>(B O B) \<subseteq> ?A\<close> have "(B O B)``{x} \<subseteq> ?A``{x}" by blast
        moreover have "?A``{x} = Star({x},Q)" using star_singleton by simp
        ultimately have "Star({x},?R) \<subseteq> Star({x},Q)" by auto
        with \<open>Star({x},Q) \<subseteq> C\<close> \<open>C\<in>P\<close> have "\<exists>C\<in>P. Star({x},?R) \<subseteq> C"
          by auto
      } with \<open>\<Union>?R = X\<close> show ?thesis unfolding IsBarycentricRefinement_def
        by auto
    qed
    with assms(2) II \<open>P \<in> Covers(X)\<close> \<open>?R\<in>?L\<close> \<open>?R <\<^sup>B P\<close> have "P\<in>?L"
       using unicov_bary_cov by simp
  } thus "\<Theta>\<subseteq>?L" by auto
qed

text\<open>The \<open>UniformityFromUniCov\<close> operation is the inverse of \<open>UniCovFromUniformity\<close>. \<close>

theorem unif_from_unicov_inv: assumes "\<Phi> {is a uniformity on} X" "X\<noteq>0"
  shows "UniformityFromUniCov(X,UniCovFromUniformity(X,\<Phi>)) = \<Phi>"
proof
  let ?\<Theta> = "UniCovFromUniformity(X,\<Phi>)"
  let ?L = "UniformityFromUniCov(X,?\<Theta>)"
  from assms have I: "?\<Theta> {are uniform covers of} X"
    using unicov_from_uniformity by simp
  with assms have II: "?L {is a uniformity on} X"
    using uniformity_from_unicov by simp
  { fix A assume "A\<in>\<Phi>"
    with assms(1) obtain B where "B\<in>\<Phi>" "B O B \<subseteq> A" and "B = converse(B)"
      using half_size_symm by blast
    from assms(1) \<open>A\<in>\<Phi>\<close> have "A \<subseteq> X\<times>X" using uni_domain(1)
      by simp
    let ?P = "{B``{x}. x\<in>X}"
    from assms(1) \<open>B\<in>\<Phi>\<close> have "?P\<in>?\<Theta>" using cover_image
      by simp
    let ?C = "\<Union>{U\<times>U. U\<in>?P}"
    from I \<open>?P\<in>?\<Theta>\<close> have "?C\<in>?L"
      unfolding AreUniformCovers_def using basic_unif by blast
    from assms(1) \<open>B\<in>\<Phi>\<close> \<open>B = converse(B)\<close> \<open>B O B \<subseteq> A\<close> have "?C \<subseteq> A"
      using uni_domain(2) symm_sq_prod_image by simp
    with II \<open>A \<subseteq> X\<times>X\<close> \<open>?C\<in>?L\<close> have "A\<in>?L"
      unfolding IsUniformity_def IsFilter_def by simp
  } thus "\<Phi>\<subseteq>?L" by auto
  { fix A assume "A\<in>?L"
    with II have "A \<subseteq> X\<times>X" using entourage_props(1) by simp
    from \<open>A\<in>?L\<close> obtain P where "P\<in>?\<Theta>" and "\<Union>{U\<times>U. U\<in>P} \<subseteq> A"
      unfolding UniformityFromUniCov_def Supersets_def by blast
    from \<open>P\<in>?\<Theta>\<close> obtain B where "B\<in>\<Phi>" and III: "\<forall>x\<in>X. \<exists>V\<in>P. B``{x} \<subseteq> V"
      unfolding UniCovFromUniformity_def by auto
    have "B\<subseteq>A"
    proof -
      from assms(1) \<open>B\<in>\<Phi>\<close> have "B \<subseteq> \<Union>{B``{x}\<times>B``{x}. x\<in>X}"
        using entourage_props(1,2) refl_union_singl_image by simp
      moreover have "\<Union>{B``{x}\<times>B``{x}. x\<in>X} \<subseteq> A"
      proof -
        { fix x assume "x\<in>X"
          with III obtain V where "V\<in>P" and "B``{x} \<subseteq> V" by auto
          hence "B``{x}\<times>B``{x} \<subseteq> \<Union>{U\<times>U. U\<in>P}" by auto
        } hence "\<Union>{B``{x}\<times>B``{x}. x\<in>X} \<subseteq> \<Union>{U\<times>U. U\<in>P}" by blast
        with \<open>\<Union>{U\<times>U. U\<in>P} \<subseteq> A\<close> show ?thesis by blast
      qed
      ultimately show ?thesis by auto
    qed
    with assms(1) \<open>B\<in>\<Phi>\<close> \<open>A \<subseteq> X\<times>X\<close> have "A\<in>\<Phi>"
      unfolding IsUniformity_def IsFilter_def by simp
  } thus "?L\<subseteq>\<Phi>" by auto
qed

end


theory "HOLCF-Set-Nominal"
imports "HOLCF-Set" "HOLCF-Join" "Nominal-HOLCF"
begin

subsubsection {* Equivariance of @{theory "HOLCF-Set"} and @{theory "HOLCF-Join"} definitions *}

lemma subcpo_eqvt[eqvt]:
  fixes S :: "('a::cont_pt) set"
  assumes "subcpo S"
  shows "subcpo (\<pi> \<bullet> S)"
proof(rule subcpoI)
  fix Y :: "nat \<Rightarrow> 'a"
  assume "chain Y"
    hence "chain (-\<pi> \<bullet> Y)" by (rule chain_eqvt)
  moreover
  assume "\<And> i. Y i \<in> \<pi> \<bullet> S"
  hence "\<And> i. - \<pi> \<bullet> Y i \<in> S" by (metis (full_types) mem_permute_iff permute_minus_cancel(1))
  hence "\<And> i. (- \<pi> \<bullet> Y) i \<in> S" by (metis eqvt_apply permute_pure)
  ultimately
  have "(\<Squnion> i. (- \<pi> \<bullet> Y) i) \<in> S" by (metis subcpo.cpo[OF assms])
  hence "\<pi> \<bullet> (\<Squnion> i. (- \<pi> \<bullet> Y) i) \<in> \<pi> \<bullet> S"  by (metis mem_permute_iff)
  thus "(\<Squnion> i. Y i) \<in> \<pi> \<bullet> S"
    apply -
    apply (subst (asm) cont2contlubE[OF perm_cont `chain (-\<pi> \<bullet> Y)`])
    by (metis image_image permute_minus_cancel(1) permute_set_eq_image range_eqvt)
qed

lemma subpcpo_bot_eqvt[eqvt]:
  fixes S :: "('a::cont_pt) set"
  assumes "subpcpo_bot S b"
  shows "subpcpo_bot (\<pi> \<bullet> S) (\<pi> \<bullet> b)"
  apply (rule subpcpo_botI)
  apply (metis subcpo.cpo[OF subcpo_eqvt[OF subpcpo_is_subcpo[OF subpcpo_bot_is_subpcpo[OF assms]]]])
  apply (metis bottom_of_subpcpo_bot_there[OF assms] mem_permute_iff)
  apply (metis (full_types) bottom_of_subpcpo_bot_minimal[OF assms] eqvt_bound mem_permute_iff perm_cont_simp)
  done

lemma subpcpo_eqvt[eqvt]:
  fixes S :: "('a::cont_pt) set"
  assumes "subpcpo S"
  shows "subpcpo (\<pi> \<bullet> S)"
  by (rule subpcpo_bot_is_subpcpo[OF subpcpo_bot_eqvt[OF subpcpo_is_subpcpo_bot[OF assms]]])

lemma bottom_of_eqvt:
  assumes "subpcpo S"
  shows "\<pi> \<bullet> (bottom_of (S ::('a::cont_pt) set)) = bottom_of (\<pi> \<bullet> S)"
  by (rule bottom_of_subpcpo_bot[symmetric, OF subpcpo_bot_eqvt[OF  subpcpo_is_subpcpo_bot[OF assms]]])

lemma closed_on_eqvt:
  "closed_on S F \<Longrightarrow> closed_on (\<pi> \<bullet> S) (\<pi> \<bullet> F)"
  apply (rule closed_onI)
  apply (simp add: permute_set_def)
  by (metis closed_onE eqvt_apply)

lemma cont_eqvt[eqvt]:
  "cont (F::'a::cont_pt \<Rightarrow> 'b::cont_pt) \<Longrightarrow> cont (\<pi> \<bullet> F)"
  apply (rule contI)
  apply (drule_tac Y = "unpermute \<pi> Y" in contE)
  apply (auto intro: chain_eqvt simp add: unpermute_def)[1]
  apply (drule perm_is_lub_eqvt[of _ _ "\<pi>"])
  apply (subst (asm) eqvt_apply[of _ F])
  apply (subst (asm) lub_eqvt)
  apply (rule cpo)
  apply (auto intro: chain_eqvt simp add: unpermute_def)[1]
  apply perm_simp
  apply assumption
  done

lemma chain_on_eqvt:
  "chain_on (S::'a::cont_pt set) Y \<Longrightarrow> chain_on (\<pi> \<bullet> S) (\<pi> \<bullet> Y)"
  apply (rule chain_onI)
  apply (drule_tac i = i in chain_onE)
  apply (metis perm_cont_simp permute_fun_app_eq permute_pure)
  apply (drule_tac i = i in chain_on_is_on)
  by (metis (full_types) mem_permute_iff permute_fun_app_eq permute_pure)

lemma cont_on_eqvt:
  "cont_on S (F::'a::cont_pt \<Rightarrow> 'b::cont_pt) \<Longrightarrow> cont_on (\<pi> \<bullet> S) (\<pi> \<bullet> F)"
  apply (rule cont_onI)
  apply (drule_tac Y = "unpermute \<pi> Y" in cont_onE)
  apply (auto intro: chain_eqvt simp add: unpermute_def)[1]
  apply (metis chain_on_eqvt permute_minus_cancel(2))
  apply (drule perm_is_lub_eqvt[of _ _ "\<pi>"])
  apply (subst (asm) eqvt_apply[of _ F])
  apply (subst (asm) lub_eqvt)
  apply (rule cpo)
  apply (drule chain_on_is_chain)
  apply (auto intro: chain_eqvt simp add: unpermute_def)[1]
  apply perm_simp
  apply assumption
  done

lemma fix_on_cond_eqvt:
  assumes "fix_on_cond S (b::'a::cont_pt) F"
  shows "fix_on_cond (\<pi> \<bullet> S) (\<pi> \<bullet> b) (\<pi> \<bullet> F)"
proof
  from assms
  have pcpo1: "subpcpo S" and closed: "closed_on S F" and cont: "cont_on S F" and [simp]:"b = bottom_of S"
    by (metis fix_on_cond.cases)+

  show "subpcpo (\<pi> \<bullet> S)" by (rule subpcpo_eqvt[OF pcpo1])
  show "bottom_of (\<pi> \<bullet> S) = \<pi> \<bullet> b" by (simp add: bottom_of_eqvt[OF pcpo1, symmetric])
  show "closed_on (\<pi> \<bullet> S) (\<pi> \<bullet> F)" by (rule closed_on_eqvt[OF closed])
  show "cont_on (\<pi> \<bullet> S) (\<pi> \<bullet> F)" by (rule cont_on_eqvt[OF cont])
qed

lemma fix_on_eqvt:
  assumes "fix_on_cond S (b::'a::cont_pt) F"
  shows "\<pi> \<bullet> (fix_on' b F) = fix_on' (\<pi> \<bullet> b) (\<pi> \<bullet> F)"
proof-
  have permuted: "fix_on_cond (\<pi> \<bullet> S) (\<pi> \<bullet> b :: 'a ::cont_pt) (\<pi> \<bullet> F)"
    by (rule fix_on_cond_eqvt[OF assms])
  show ?thesis
    apply (rule parallel_fix_on_ind[OF assms permuted _ refl])
    apply (rule adm_is_adm_on)
    apply (rule adm_eq[OF cont_compose[OF perm_cont cont_fst] cont_snd])
    by auto
qed

lemma to_bot_eqvt[eqvt,simp]: "\<pi> \<bullet> to_bot (\<rho>::'a::{subpcpo_partition,cont_pt}) = to_bot (\<pi> \<bullet> \<rho>)"
proof(rule below_antisym)
  show "to_bot (\<pi> \<bullet> \<rho>) \<sqsubseteq> \<pi> \<bullet> to_bot \<rho>"
    by (metis perm_cont_simp to_bot_minimal unrelated)
  show "\<pi> \<bullet> to_bot \<rho> \<sqsubseteq> to_bot (\<pi> \<bullet> \<rho>)"
    by (metis eqvt_bound perm_cont_simp to_bot_minimal unrelated)
qed

lemma compatible_eqvt[eqvt]:
  "compatible (x::'a::cont_pt) y \<Longrightarrow> compatible (\<pi> \<bullet> x) (\<pi> \<bullet> y)"
  unfolding compatible_def
  by (metis empty_eqvt insert_eqvt perm_is_lub_simp)

lemma join_eqvt[simp,eqvt]:
  "\<pi> \<bullet> ((x::'a::{cont_pt}) \<squnion> y) = (\<pi> \<bullet> x) \<squnion> (\<pi> \<bullet> y)"
proof (cases "\<exists> z. {x, y} <<| z")
case False
  hence "\<not> (\<exists> z. {\<pi> \<bullet> x, \<pi> \<bullet> y} <<| z)" by (metis perm_is_lub_simp empty_eqvt insert_eqvt eqvt_bound)
  thus ?thesis using False unfolding cpo_class.join_def by auto
next
case True
  hence "\<exists> z. {\<pi> \<bullet> x, \<pi> \<bullet> y} <<| z" by (metis perm_is_lub_simp empty_eqvt insert_eqvt)
  thus ?thesis using True unfolding cpo_class.join_def by (auto simp add: empty_eqvt insert_eqvt)
qed
end