section \<open>Positional Determinacy of Parity Games\<close>

theory PositionalDeterminacy
imports
  Main
  AttractorStrategy
begin

context ParityGame begin

subsection \<open>Induction Step\<close>

text \<open>
  The proof of positional determinacy is by induction over the size of the finite set
  @{term "\<omega> ` V"}, the set of priorities.  The following lemma is the induction step.

  For now, we assume there are no deadends in the graph.  Later we will get rid of this assumption.
\<close>

lemma positional_strategy_induction_step:
  assumes "v \<in> V"
    and no_deadends: "\<And>v. v \<in> V \<Longrightarrow> \<not>deadend v"
    and IH: "\<And>(G :: ('a, 'b) ParityGame_scheme) v.
      \<lbrakk> card (\<omega>\<^bsub>G\<^esub> ` V\<^bsub>G\<^esub>) < card (\<omega> ` V); v \<in> V\<^bsub>G\<^esub>;
        ParityGame G;
        \<And>v. v \<in> V\<^bsub>G\<^esub> \<Longrightarrow> \<not>Digraph.deadend G v  \<rbrakk>
      \<Longrightarrow> \<exists>p. v \<in> ParityGame.winning_region G p"
  shows "\<exists>p. v \<in> winning_region p"
proof-
  text \<open>First, we determine the minimum priority and the player who likes it.\<close>
  define min_prio where "min_prio = Min (\<omega> ` V)"
  have "\<exists>p. winning_priority p min_prio" by auto
  then obtain p where p: "winning_priority p min_prio" by blast
  text \<open>Then we define the tentative winning region of player @{term "p**"}.
    The rest of the proof is to show that this is the complete winning region.
\<close>
  define W1 where "W1 = winning_region p**"
  text \<open>For this, we define several more sets of nodes.
    First, \<open>U\<close> is the tentative winning region of player @{term p}.
\<close>
  define U where "U = V - W1"
  define K where "K = U \<inter> (\<omega> -` {min_prio})"
  define V' where "V' = U - attractor p K"

  define G' where [simp]: "G' = subgame V'"
  interpret G': ParityGame G' using subgame_ParityGame by simp

  have U_equiv: "\<And>v. v \<in> V \<Longrightarrow> v \<in> U \<longleftrightarrow> v \<notin> winning_region p**"
    unfolding U_def W1_def by blast

  have "V' \<subseteq> V" unfolding U_def V'_def by blast
  hence [simp]: "V\<^bsub>G'\<^esub> = V'" unfolding G'_def by simp

  have "V\<^bsub>G'\<^esub> \<subseteq> V" "E\<^bsub>G'\<^esub> \<subseteq> E" "\<omega>\<^bsub>G'\<^esub> = \<omega>" unfolding G'_def by (simp_all add: subgame_\<omega>)
  have "G'.VV p = V' \<inter> VV p" unfolding G'_def using subgame_VV by simp

  have V_decomp: "V = attractor p K \<union> V' \<union> W1" proof-
    have "V \<subseteq> attractor p K \<union> V' \<union> W1"
      unfolding V'_def U_def by blast
    moreover have "attractor p K \<subseteq> V"
      using attractor_in_V[of K] unfolding K_def U_def by blast
    ultimately show ?thesis
      unfolding W1_def winning_region_def using \<open>V' \<subseteq> V\<close> by blast
  qed

  have G'_no_deadends: "\<And>v. v \<in> V\<^bsub>G'\<^esub> \<Longrightarrow> \<not>G'.deadend v" proof-
    fix v assume "v \<in> V\<^bsub>G'\<^esub>"
    hence *: "v \<in> U - attractor p K" using \<open>V\<^bsub>G'\<^esub> = V'\<close> V'_def by blast
    moreover hence "\<exists>w \<in> U. v\<rightarrow>w"
      using removing_winning_region_induces_no_deadends[of v "p**"] no_deadends U_equiv U_def
      by blast
    moreover have "\<And>w. \<lbrakk> v \<in> VV p**; v\<rightarrow>w \<rbrakk> \<Longrightarrow> w \<in> U"
      using * U_equiv winning_region_extends_VVp by blast
    ultimately have "\<exists>w \<in> V'. v\<rightarrow>w"
      using U_equiv winning_region_extends_VVp removing_attractor_induces_no_deadends V'_def
      by blast
    thus "\<not>G'.deadend v" using \<open>v \<in> V\<^bsub>G'\<^esub>\<close> \<open>V' \<subseteq> V\<close> by simp
  qed

  text \<open>
    By definition of @{term W1}, we obtain a winning strategy on @{term W1} for player @{term "p**"}.
\<close>
  obtain \<sigma>W1 where \<sigma>W1:
    "strategy p** \<sigma>W1" "\<And>v. v \<in> W1 \<Longrightarrow> winning_strategy p** \<sigma>W1 v"
    unfolding W1_def using merge_winning_strategies by blast

  {
    fix v assume "v \<in> V\<^bsub>G'\<^esub>"

    text \<open>Apply the induction hypothesis to get the winning strategy for @{term v} in @{term G'}.\<close>
    have G'_winning_strategy: "\<exists>p. v \<in> G'.winning_region p" proof-
      have "card (\<omega>\<^bsub>G'\<^esub> ` V\<^bsub>G'\<^esub>) < card (\<omega> ` V)" proof-
        { assume "min_prio \<in> \<omega>\<^bsub>G'\<^esub> ` V\<^bsub>G'\<^esub>"
          then obtain v where v: "v \<in> V\<^bsub>G'\<^esub>" "\<omega>\<^bsub>G'\<^esub> v = min_prio" by blast
          hence "v \<in> \<omega> -` {min_prio}" using \<open>\<omega>\<^bsub>G'\<^esub> = \<omega>\<close> by simp
          hence False using V'_def K_def attractor_set_base \<open>V\<^bsub>G'\<^esub> = V'\<close> v(1)
            by (metis DiffD1 DiffD2 IntI contra_subsetD)
        }
        hence "min_prio \<notin> \<omega>\<^bsub>G'\<^esub> ` V\<^bsub>G'\<^esub>" by blast
        moreover have "min_prio \<in> \<omega> ` V"
          unfolding min_prio_def using priorities_finite Min_in assms(1) by blast
        moreover have "\<omega>\<^bsub>G'\<^esub> ` V\<^bsub>G'\<^esub> \<subseteq> \<omega> ` V" unfolding G'_def by simp
        ultimately show ?thesis by (metis priorities_finite psubsetI psubset_card_mono)
      qed
      thus ?thesis using IH[of G'] \<open>v \<in> V\<^bsub>G'\<^esub>\<close> G'_no_deadends G'.ParityGame_axioms by blast
    qed

    text \<open>
      It turns out the winning region of player @{term "p**"} is empty, so we have a strategy
      for player @{term p}.
\<close>
    have "v \<in> G'.winning_region p" proof (rule ccontr)
      assume "\<not>?thesis"
      moreover obtain p' \<sigma> where p': "G'.strategy p' \<sigma>" "G'.winning_strategy p' \<sigma> v"
        using G'_winning_strategy unfolding G'.winning_region_def by blast
      ultimately have "p' \<noteq> p" using \<open>v \<in> V\<^bsub>G'\<^esub>\<close> unfolding G'.winning_region_def by blast
      hence "p' = p**" by (cases p; cases p') auto
      with p' have \<sigma>: "G'.strategy p** \<sigma>" "G'.winning_strategy p** \<sigma> v" by simp_all

      have "v \<in> winning_region p**" proof
        show "v \<in> V" using \<open>v \<in> V\<^bsub>G'\<^esub>\<close> \<open>V\<^bsub>G'\<^esub> \<subseteq> V\<close> by blast
        define \<sigma>' where "\<sigma>' = override_on (override_on \<sigma>_arbitrary \<sigma>W1 W1) \<sigma> V'"
        thus "strategy p** \<sigma>'"
          using valid_strategy_updates_set_strong valid_arbitrary_strategy \<sigma>W1(1)
                valid_strategy_supergame \<sigma>(1) G'_no_deadends \<open>V\<^bsub>G'\<^esub> = V'\<close>
          unfolding G'_def by blast
        show "winning_strategy p** \<sigma>' v"
        proof (rule winning_strategyI, rule ccontr)
          fix P assume "vmc_path G P v p** \<sigma>'"
          then interpret vmc_path G P v "p**" \<sigma>' .
          assume "\<not>winning_path p** P"
          text \<open>
            First we show that @{term P} stays in @{term V'}, because if it stays in @{term V'},
            then it conforms to @{term \<sigma>}, so it must be winning for @{term "p**"}.\<close>

          have "lset P \<subseteq> V'" proof (induct rule: vmc_path_lset_induction_closed_subset)
            fix v assume "v \<in> V'" "\<not>deadend v" "v \<in> VV p**"
            hence "v \<in> ParityGame.VV (subgame V') p**" by auto
            moreover have "\<not>G'.deadend v" using G'_no_deadends \<open>V\<^bsub>G'\<^esub> = V'\<close> \<open>v \<in> V'\<close> by blast
            ultimately have "\<sigma> v \<in> V'"
              using subgame_strategy_stays_in_subgame p'(1) \<open>p' = p**\<close>
              unfolding G'_def by blast
            thus "\<sigma>' v \<in> V' \<union> W1" unfolding \<sigma>'_def using \<open>v \<in> V'\<close> by simp
          next
            fix v w assume "v \<in> V'" "\<not>deadend v" "v \<in> VV p****" "v\<rightarrow>w"
            show "w \<in> V' \<union> W1" proof (rule ccontr)
              assume "w \<notin> V' \<union> W1"
              hence "w \<in> attractor p K" using V_decomp \<open>v\<rightarrow>w\<close> by blast
              hence "v \<in> attractor p K" using \<open>v \<in> VV p****\<close> attractor_set_VVp \<open>v\<rightarrow>w\<close> by auto
              thus False using \<open>v \<in> V'\<close> V'_def by blast
            qed
          next
            have "\<And>v. v \<in> W1 \<Longrightarrow> \<sigma>W1 v = \<sigma>' v" unfolding \<sigma>'_def V'_def U_def by simp
            thus "lset P \<inter> W1 = {}"
              using path_hits_winning_region_is_winning \<sigma>W1 \<open>\<not>winning_path p** P\<close>
              unfolding W1_def
              by blast
          next
            show "v \<in> V'" using \<open>V\<^bsub>G'\<^esub> = V'\<close> \<open>v \<in> V\<^bsub>G'\<^esub>\<close> by blast
          qed
          text \<open>This concludes the proof of @{term "lset P \<subseteq> V'"}.\<close>
          hence "G'.valid_path P" using subgame_valid_path by simp
          moreover have "G'.maximal_path P"
            using \<open>lset P \<subseteq> V'\<close> subgame_maximal_path \<open>V' \<subseteq> V\<close> by simp
          moreover have "G'.path_conforms_with_strategy p** P \<sigma>" proof-
            have "G'.path_conforms_with_strategy p** P \<sigma>'"
              using subgame_path_conforms_with_strategy \<open>V' \<subseteq> V\<close> \<open>lset P \<subseteq> V'\<close>
              by simp
            moreover have "\<And>v. v \<in> lset P \<Longrightarrow> \<sigma>' v = \<sigma> v" using \<open>lset P \<subseteq> V'\<close> \<sigma>'_def by auto
            ultimately show ?thesis
              using G'.path_conforms_with_strategy_irrelevant_updates by blast
          qed
          ultimately have "G'.winning_path p** P"
            using \<sigma>(2) G'.winning_strategy_def G'.valid_maximal_conforming_path_0 P_0 P_not_null
            by blast
          moreover have "G'.VV p**** \<subseteq> VV p****" using subgame_VV_subset G'_def by blast
          ultimately show False
            using G'.winning_path_supergame[of "p**"] \<open>\<omega>\<^bsub>G'\<^esub> = \<omega>\<close>
                  \<open>\<not>winning_path p** P\<close> ParityGame_axioms
            by blast
        qed
      qed
      moreover have "v \<in> V" using \<open>V\<^bsub>G'\<^esub> \<subseteq> V\<close> \<open>v \<in> V\<^bsub>G'\<^esub>\<close> by blast
      ultimately have "v \<in> W1" unfolding W1_def winning_region_def by blast
      thus False using \<open>v \<in> V\<^bsub>G'\<^esub>\<close> using U_def V'_def \<open>V\<^bsub>G'\<^esub> = V'\<close> \<open>v \<in> V\<^bsub>G'\<^esub>\<close> by blast
    qed
  } note recursion = this

  text \<open>
    We compose a winning strategy for player @{term p} on @{term "V - W1"} out of three pieces.
\<close>

  text \<open>
    First, if we happen to land in the attractor region of @{term K}, we follow the attractor
    strategy.  This is good because the priority of the nodes in @{term K} is good for
    player @{term p}, so he likes to go there.\<close>
  obtain \<sigma>1
    where \<sigma>1: "strategy p \<sigma>1"
              "strategy_attracts p \<sigma>1 (attractor p K) K"
    using attractor_has_strategy[of K p] K_def U_def by auto

  text \<open>Next, on @{term G'} we follow the winning strategy whose existence we proved earlier.\<close>
  have "G'.winning_region p = V\<^bsub>G'\<^esub>" using recursion unfolding G'.winning_region_def by blast
  then obtain \<sigma>2
    where \<sigma>2: "\<And>v. v \<in> V\<^bsub>G'\<^esub> \<Longrightarrow> G'.strategy p \<sigma>2"
              "\<And>v. v \<in> V\<^bsub>G'\<^esub> \<Longrightarrow> G'.winning_strategy p \<sigma>2 v"
    using G'.merge_winning_strategies by blast

  text \<open>
    As a last option we choose an arbitrary successor but avoid entering @{term W1}.
    In particular, this defines the strategy on the set @{term K}.\<close>
  define succ where "succ v = (SOME w. v\<rightarrow>w \<and> (v \<in> W1 \<or> w \<notin> W1))" for v

  text \<open>Compose the three pieces.\<close>
  define \<sigma> where "\<sigma> = override_on (override_on succ \<sigma>2 V') \<sigma>1 (attractor p K - K)"

  have "attractor p K \<inter> W1 = {}" proof (rule ccontr)
    assume "attractor p K \<inter> W1 \<noteq> {}"
    then obtain v where v: "v \<in> attractor p K" "v \<in> W1" by blast
    hence "v \<in> V" using W1_def winning_region_def by blast
    obtain P where "vmc2_path G P v p \<sigma>1 \<sigma>W1"
      using strategy_conforming_path_exists \<sigma>W1(1) \<sigma>1(1) \<open>v \<in> V\<close> by blast
    then interpret vmc2_path G P v p \<sigma>1 \<sigma>W1 .
    have "strategy_attracts_via p \<sigma>1 v (attractor p K) K" using v(1) \<sigma>1(2) strategy_attracts_def by blast
    hence "lset P \<inter> K \<noteq> {}" using strategy_attracts_viaE visits_via_visits by blast
    hence "\<not>lset P \<subseteq> W1" unfolding K_def U_def by blast
    thus False unfolding W1_def using comp.paths_stay_in_winning_region \<sigma>W1 v(2) by auto
  qed

  text \<open>On specific sets, @{term \<sigma>} behaves like one of the three pieces.\<close>
  have \<sigma>_\<sigma>1: "\<And>v. v \<in> attractor p K - K \<Longrightarrow> \<sigma> v = \<sigma>1 v" unfolding \<sigma>_def by simp
  have \<sigma>_\<sigma>2: "\<And>v. v \<in> V' \<Longrightarrow> \<sigma> v = \<sigma>2 v" unfolding \<sigma>_def V'_def by auto
  have \<sigma>_K: "\<And>v. v \<in> K \<union> W1 \<Longrightarrow> \<sigma> v = succ v" proof-
    fix v assume v: "v \<in> K \<union> W1"
    hence "v \<notin> V'" unfolding V'_def U_def using attractor_set_base by auto
    with v show "\<sigma> v = succ v" unfolding \<sigma>_def U_def using \<open>attractor p K \<inter> W1 = {}\<close>
      by (metis (mono_tags, lifting) Diff_iff IntI UnE override_on_def override_on_emptyset)
  qed

  text \<open>Show that @{term succ} succeeds in avoiding entering @{term W1}.\<close>
  { fix v assume v: "v \<in> VV p"
    hence "\<not>deadend v" using no_deadends by blast
    have "\<exists>w. v\<rightarrow>w \<and> (v \<in> W1 \<or> w \<notin> W1)" proof (cases)
      assume "v \<in> W1"
      thus ?thesis using no_deadends \<open>\<not>deadend v\<close> by blast
    next
      assume "v \<notin> W1"
      show ?thesis proof (rule ccontr)
        assume "\<not>(\<exists>w. v\<rightarrow>w \<and> (v \<in> W1 \<or> w \<notin> W1))"
        hence "\<And>w. v\<rightarrow>w \<Longrightarrow> winning_strategy p** \<sigma>W1 w" using \<sigma>W1(2) by blast
        hence "winning_strategy p** \<sigma>W1 v"
          using strategy_extends_backwards_VVpstar \<sigma>W1(1) \<open>v \<in> VV p\<close> by simp
        hence "v \<in> W1" unfolding W1_def winning_region_def using \<sigma>W1(1) \<open>\<not>deadend v\<close> by blast
        thus False using \<open>v \<notin> W1\<close> by blast
      qed
    qed
    hence "v\<rightarrow>succ v" "v \<in> W1 \<or> succ v \<notin> W1" unfolding succ_def
      using someI_ex[of "\<lambda>w. v\<rightarrow>w \<and> (v \<in> W1 \<or> w \<notin> W1)"] by blast+
  } note succ_works = this

  have "strategy p \<sigma>"
  proof
    fix v assume v: "v \<in> VV p" "\<not>deadend v"
    hence "v \<in> attractor p K - K \<Longrightarrow> v\<rightarrow>\<sigma> v" using \<sigma>_\<sigma>1 \<sigma>1(1) v unfolding strategy_def by auto
    moreover have "v \<in> V' \<Longrightarrow> v\<rightarrow>\<sigma> v" proof-
      assume "v \<in> V'"
      moreover have "v \<in> V\<^bsub>G'\<^esub>" using \<open>v \<in> V'\<close> \<open>V\<^bsub>G'\<^esub> = V'\<close> by blast
      moreover have "v \<in> G'.VV p" using \<open>G'.VV p = V' \<inter> VV p\<close> \<open>v \<in> V'\<close> \<open>v \<in> VV p\<close> by blast
      moreover have "\<not>Digraph.deadend G' v" using G'_no_deadends \<open>v \<in> V\<^bsub>G'\<^esub>\<close> by blast
      ultimately have "v \<rightarrow>\<^bsub>G'\<^esub> \<sigma>2 v" using \<sigma>2(1) G'.strategy_def[of p \<sigma>2] by blast
      with \<open>v \<in> V'\<close> show "v\<rightarrow>\<sigma> v" using \<open>E\<^bsub>G'\<^esub> \<subseteq> E\<close> \<sigma>_\<sigma>2 by (metis subsetCE)
    qed
    moreover have "v \<in> K \<union> W1 \<Longrightarrow> v\<rightarrow>\<sigma> v" using succ_works(1) v \<sigma>_K by auto
    moreover have "v \<in> V" using \<open>v \<in> VV p\<close> by blast
    ultimately show "v\<rightarrow>\<sigma> v" using V_decomp by blast
  qed

  have \<sigma>_attracts: "strategy_attracts p \<sigma> (attractor p K) K" proof-
    have "strategy_attracts p (override_on \<sigma> \<sigma>1 (attractor p K - K)) (attractor p K) K"
      using strategy_attracts_irrelevant_override \<sigma>1 \<open>strategy p \<sigma>\<close> by blast
    moreover have "\<sigma> = override_on \<sigma> \<sigma>1 (attractor p K - K)"
      by (rule ext) (simp add: override_on_def \<sigma>_\<sigma>1)
    ultimately show ?thesis by simp
  qed

  text \<open>Show that @{term \<sigma>} is a winning strategy on @{term "V - W1"}.\<close>
  have "\<forall>v \<in> V - W1. winning_strategy p \<sigma> v" proof (intro ballI winning_strategyI)
    fix v P assume P: "v \<in> V - W1" "vmc_path G P v p \<sigma>"
    interpret vmc_path G P v p \<sigma> using P(2) .

    have "lset P \<subseteq> V - W1"
    proof (induct rule: vmc_path_lset_induction_closed_subset)
      fix v assume "v \<in> V - W1" "\<not>deadend v" "v \<in> VV p"
      show "\<sigma> v \<in> V - W1 \<union> {}" proof (rule ccontr)
        assume "\<not>?thesis"
        hence "\<sigma> v \<in> W1"
          using \<open>strategy p \<sigma>\<close> \<open>\<not>deadend v\<close> \<open>v \<in> VV p\<close>
          unfolding strategy_def by blast
        hence "v \<notin> K" using succ_works(2)[OF \<open>v \<in> VV p\<close>] \<open>v \<in> V - W1\<close> \<sigma>_K by auto
        moreover have "v \<notin> attractor p K - K" proof
          assume "v \<in> attractor p K - K"
          hence "\<sigma> v \<in> attractor p K"
            using attracted_strategy_step \<open>strategy p \<sigma>\<close> \<sigma>_attracts \<open>\<not>deadend v\<close> \<open>v \<in> VV p\<close>
                  attractor_set_base
            by blast
          thus False using \<open>\<sigma> v \<in> W1\<close> \<open>attractor p K \<inter> W1 = {}\<close> by blast
        qed
        moreover have "v \<notin> V'" proof
          assume "v \<in> V'"
          have "\<sigma>2 v \<in> V\<^bsub>G'\<^esub>" proof (rule G'.valid_strategy_in_V[of p \<sigma>2 v])
            have "v \<in> V\<^bsub>G'\<^esub>" using \<open>V\<^bsub>G'\<^esub> = V'\<close> \<open>v \<in> V'\<close> by simp
            thus "\<not>G'.deadend v" using G'_no_deadends by blast
            show "G'.strategy p \<sigma>2" using \<sigma>2(1) \<open>v \<in> V\<^bsub>G'\<^esub>\<close> by blast
            show "v \<in> G'.VV p" using \<open>v \<in> VV p\<close> \<open>G'.VV p = V' \<inter> VV p\<close> \<open>v \<in> V'\<close> by simp
          qed
          hence "\<sigma> v \<in> V\<^bsub>G'\<^esub>" using \<open>v \<in> V'\<close> \<sigma>_\<sigma>2 by simp
          thus False using \<open>V\<^bsub>G'\<^esub> = V'\<close> \<open>\<sigma> v \<in> W1\<close> V'_def U_def by blast
        qed
        ultimately show False using \<open>v \<in> V - W1\<close> V_decomp by blast
      qed
    next
      fix v w assume "v \<in> V - W1" "\<not>deadend v" "v \<in> VV p**" "v\<rightarrow>w"
      show "w \<in> V - W1 \<union> {}"
      proof (rule ccontr)
        assume "\<not>?thesis"
        hence "w \<in> W1" using \<open>v\<rightarrow>w\<close> by blast
        let ?\<sigma> = "\<sigma>W1(v := w)"
        have "winning_strategy p** \<sigma>W1 w" using \<open>w \<in> W1\<close> \<sigma>W1(2) by blast
        moreover have "\<not>(\<exists>\<sigma>. strategy p** \<sigma> \<and> winning_strategy p** \<sigma> v)"
          using \<open>v \<in> V - W1\<close> unfolding W1_def winning_region_def by blast
        ultimately have "winning_strategy p** ?\<sigma> w"
          using winning_strategy_updates[of "p**" \<sigma>W1 w v w] \<sigma>W1(1) \<open>v\<rightarrow>w\<close>
          unfolding winning_region_def by blast
        moreover have "strategy p** ?\<sigma>" using \<open>v\<rightarrow>w\<close> \<sigma>W1(1) valid_strategy_updates by blast
        ultimately have "winning_strategy p** ?\<sigma> v"
          using strategy_extends_backwards_VVp[of v "p**" ?\<sigma> w]
                \<open>v \<in> VV p**\<close> \<open>v\<rightarrow>w\<close>
          by auto
        hence "v \<in> W1" unfolding W1_def winning_region_def
          using \<open>strategy p** ?\<sigma>\<close> \<open>v \<in> V - W1\<close> by blast
        thus False using \<open>v \<in> V - W1\<close> by blast
      qed
    qed (insert P(1), simp_all)
    text \<open>This concludes the proof of @{term "lset P \<subseteq> V - W1"}.\<close>
    hence "lset P \<subseteq> attractor p K \<union> V'" using V_decomp by blast

    have "\<not>lfinite P"
      using no_deadends lfinite_lset maximal_ends_on_deadend[of P] P_maximal P_not_null lset_P_V
      by blast

    text \<open>
      Every @{term \<sigma>}-conforming path starting in @{term "V - W1"} is winning.
      We distinguish two cases:
      \begin{enumerate}
        \item @{term P} eventually stays in @{term V'}.
          Then @{term P} is winning because @{term \<sigma>2} is winning.
        \item @{term P} visits @{term K} infinitely often.
          Then @{term P} is winning because of the priority of the nodes in @{term K}.
      \end{enumerate}
\<close>
    show "winning_path p P"
    proof (cases)
      assume "\<exists>n. lset (ldropn n P) \<subseteq> V'"
      text \<open>The first case: @{term P} eventually stays in @{term V'}.\<close>
      then obtain n where n: "lset (ldropn n P) \<subseteq> V'" by blast
      define P' where "P' = ldropn n P"
      hence "lset P' \<subseteq> V'" using n by blast
      interpret vmc_path': vmc_path G' P' "lhd P'" p \<sigma>2 proof
        show "\<not>lnull P'" unfolding P'_def
          using \<open>\<not>lfinite P\<close> lfinite_ldropn lnull_imp_lfinite by blast
        show "G'.valid_path P'" proof-
          have "valid_path P'" unfolding P'_def by simp
          thus ?thesis using subgame_valid_path \<open>lset P' \<subseteq> V'\<close> G'_def by blast
        qed
        show "G'.maximal_path P'" proof-
          have "maximal_path P'" unfolding P'_def by simp
          thus ?thesis using subgame_maximal_path \<open>lset P' \<subseteq> V'\<close> \<open>V' \<subseteq> V\<close> G'_def by blast
        qed
        show "G'.path_conforms_with_strategy p P' \<sigma>2" proof-
          have "path_conforms_with_strategy p P' \<sigma>" unfolding P'_def by simp
          hence "path_conforms_with_strategy p P' \<sigma>2"
            using path_conforms_with_strategy_irrelevant_updates \<open>lset P' \<subseteq> V'\<close> \<sigma>_\<sigma>2
            by blast
          thus ?thesis
            using subgame_path_conforms_with_strategy \<open>lset P' \<subseteq> V'\<close> \<open>V' \<subseteq> V\<close> G'_def
            by blast
        qed
      qed simp
      have "G'.winning_strategy p \<sigma>2 (lhd P')"
        using \<open>lset P' \<subseteq> V'\<close> vmc_path'.P_not_null \<sigma>2(2)[of "lhd P'"] \<open>V\<^bsub>G'\<^esub> = V'\<close> llist.set_sel(1)
        by blast
      hence "G'.winning_path p P'" using G'.winning_strategy_def vmc_path'.vmc_path_axioms by blast
      moreover have "G'.VV p** \<subseteq> VV p**" unfolding G'_def using subgame_VV by simp
      ultimately have "winning_path p P'"
        using G'.winning_path_supergame[of p P' G] \<open>\<omega>\<^bsub>G'\<^esub> = \<omega>\<close> ParityGame_axioms by blast
      thus ?thesis
        unfolding P'_def
        using infinite_small_llength[OF \<open>\<not>lfinite P\<close>]
              winning_path_drop_add[of P p n] P_valid
        by blast
    next
      assume asm: "\<not>(\<exists>n. lset (ldropn n P) \<subseteq> V')"
      text \<open>The second case: @{term P} visits @{term K} infinitely often.
        Then @{term min_prio} occurs infinitely often on @{term P}.\<close>
      have "min_prio \<in> path_inf_priorities P"
      unfolding path_inf_priorities_def proof (intro CollectI allI)
        fix n
        obtain k1 where k1: "ldropn n P $ k1 \<notin> V'" using asm by (metis lset_lnth subsetI)
        define k2 where "k2 = k1 + n"
        interpret vmc_path G "ldropn k2 P" "P $ k2" p \<sigma>
          using vmc_path_ldropn infinite_small_llength \<open>\<not>lfinite P\<close> by blast
        have "P $ k2 \<notin> V'" unfolding k2_def
          using k1 lnth_ldropn infinite_small_llength[OF \<open>\<not>lfinite P\<close>] by simp
        hence "P $ k2 \<in> attractor p K" using \<open>\<not>lfinite P\<close> \<open>lset P \<subseteq> V - W1\<close>
          by (metis DiffI U_def V'_def lset_nth_member_inf)
        then obtain k3 where k3: "ldropn k2 P $ k3 \<in> K"
          using \<sigma>_attracts strategy_attractsE unfolding G'.visits_via_def by blast
        define k4 where "k4 = k3 + k2"
        hence "P $ k4 \<in> K"
          using k3 lnth_ldropn infinite_small_llength[OF \<open>\<not>lfinite P\<close>] by simp
        moreover have "k4 \<ge> n" unfolding k4_def k2_def
          using le_add2 le_trans by blast
        moreover have "ldropn n P $ k4 - n = P $ (k4 - n) + n"
          using lnth_ldropn infinite_small_llength \<open>\<not>lfinite P\<close> by blast
        ultimately have "ldropn n P $ k4 - n \<in> K" by simp
        hence "lset (ldropn n P) \<inter> K \<noteq> {}"
          using \<open>\<not>lfinite P\<close> lfinite_ldropn in_lset_conv_lnth[of "ldropn n P $ k4 - n"]
          by blast
        thus "min_prio \<in> lset (ldropn n (lmap \<omega> P))" unfolding K_def by auto
      qed
      thus ?thesis unfolding winning_path_def
        using path_inf_priorities_at_least_min_prio[OF P_valid, folded min_prio_def]
              \<open>winning_priority p min_prio\<close> \<open>\<not>lfinite P\<close>
        by blast
    qed
  qed
  hence "\<forall>v \<in> V. \<exists>p \<sigma>. strategy p \<sigma> \<and> winning_strategy p \<sigma> v"
    unfolding W1_def winning_region_def using \<open>strategy p \<sigma>\<close> by blast
  hence "\<exists>p \<sigma>. strategy p \<sigma> \<and> winning_strategy p \<sigma> v" using \<open>v \<in> V\<close> by simp
  thus ?thesis unfolding winning_region_def using \<open>v \<in> V\<close> by blast
qed

subsection \<open>Positional Determinacy without Deadends\<close>

theorem positional_strategy_exists_without_deadends:
  assumes "v \<in> V" "\<And>v. v \<in> V \<Longrightarrow> \<not>deadend v"
  shows "\<exists>p. v \<in> winning_region p"
  using assms ParityGame_axioms
  by (induct "card (\<omega> ` V)" arbitrary: G v rule: nat_less_induct)
     (rule ParityGame.positional_strategy_induction_step, simp_all)

subsection \<open>Positional Determinacy with Deadends\<close>

text \<open>
  Prove a stronger version of the previous theorem: Allow deadends.
\<close>
theorem positional_strategy_exists:
  assumes "v0 \<in> V"
  shows "\<exists>p. v0 \<in> winning_region p"
proof-
  { fix p
    define A where "A = attractor p (deadends p**)"
    assume v0_in_attractor: "v0 \<in> attractor p (deadends p**)"
    then obtain \<sigma> where \<sigma>: "strategy p \<sigma>" "strategy_attracts p \<sigma> A (deadends p**)"
      using attractor_has_strategy[of "deadends p**" "p"] A_def deadends_in_V by blast

    have "A \<subseteq> V" using A_def using attractor_in_V deadends_in_V by blast
    hence "A - deadends p** \<subseteq> V" by auto

    have "winning_strategy p \<sigma> v0" proof (unfold winning_strategy_def, intro allI impI)
      fix P assume "vmc_path G P v0 p \<sigma>"
      then interpret vmc_path G P v0 p \<sigma> .
      show "winning_path p P"
        using visits_deadend[of "p**"] \<sigma>(2) strategy_attracts_lset v0_in_attractor
        unfolding A_def by simp
    qed
    hence "\<exists>p \<sigma>. strategy p \<sigma> \<and> winning_strategy p \<sigma> v0" using \<sigma> by blast
  } note lemma_path_to_deadend = this
  define A where "A p = attractor p (deadends p**)" for p
  text \<open>Remove the attractor sets of the sets of deadends.\<close>
  define V' where "V' = V - A Even - A Odd"
  hence "V' \<subseteq> V" by blast
  show ?thesis proof (cases)
    assume "v0 \<in> V'"
    define G' where "G' = subgame V'"
    interpret G': ParityGame G' unfolding G'_def using subgame_ParityGame .
    have "V\<^bsub>G'\<^esub> = V'" unfolding G'_def using \<open>V' \<subseteq> V\<close> by simp
    hence "v0 \<in> V\<^bsub>G'\<^esub>" using \<open>v0 \<in> V'\<close> by simp
    moreover have V'_no_deadends: "\<And>v. v \<in> V\<^bsub>G'\<^esub> \<Longrightarrow> \<not>G'.deadend v" proof-
      fix v assume "v \<in> V\<^bsub>G'\<^esub>"
      moreover have "V' = V - A Even - A Even**" using V'_def by simp
      ultimately show "\<not>G'.deadend v"
        using subgame_without_deadends \<open>v \<in> V\<^bsub>G'\<^esub>\<close> unfolding A_def G'_def by blast
    qed
    ultimately obtain p \<sigma> where \<sigma>: "G'.strategy p \<sigma>" "G'.winning_strategy p \<sigma> v0"
      using G'.positional_strategy_exists_without_deadends
      unfolding G'.winning_region_def
      by blast

    have V'_no_deadends': "\<And>v. v \<in> V' \<Longrightarrow> \<not>deadend v" proof-
      fix v assume "v \<in> V'"
      hence "\<not>G'.deadend v" using V'_no_deadends \<open>V' \<subseteq> V\<close> unfolding G'_def by auto
      thus "\<not>deadend v" unfolding G'_def using \<open>V' \<subseteq> V\<close> by auto
    qed

    obtain \<sigma>_attr
      where \<sigma>_attr: "strategy p \<sigma>_attr" "strategy_attracts p \<sigma>_attr (A p) (deadends p**)"
      using attractor_has_strategy[OF deadends_in_V] unfolding A_def by blast
    define \<sigma>' where "\<sigma>' = override_on \<sigma> \<sigma>_attr (A Even \<union> A Odd)"
    have \<sigma>'_is_\<sigma>_on_V': "\<And>v. v \<in> V' \<Longrightarrow> \<sigma>' v = \<sigma> v"
      unfolding V'_def \<sigma>'_def A_def by (cases p) simp_all

    have "strategy p \<sigma>'" proof-
      have "\<sigma>' = override_on \<sigma>_attr \<sigma> (UNIV - A Even - A Odd)"
        unfolding \<sigma>'_def override_on_def by (rule ext) simp
      moreover have "strategy p (override_on \<sigma>_attr \<sigma> V')"
        using valid_strategy_supergame \<sigma>_attr(1) \<sigma>(1) V'_no_deadends \<open>V\<^bsub>G'\<^esub> = V'\<close>
        unfolding G'_def by blast
      ultimately show ?thesis by (simp add: valid_strategy_only_in_V V'_def override_on_def)
    qed
    moreover have "winning_strategy p \<sigma>' v0" proof (rule winning_strategyI, rule ccontr)
      fix P assume "vmc_path G P v0 p \<sigma>'"
      then interpret vmc_path G P v0 p \<sigma>' .
      interpret vmc_path_no_deadend G P v0 p \<sigma>'
        using V'_no_deadends' \<open>v0 \<in> V'\<close> by unfold_locales
      assume contra: "\<not>winning_path p P"

      have "lset P \<subseteq> V'" proof (induct rule: vmc_path_lset_induction_closed_subset)
        fix v assume "v \<in> V'" "\<not>deadend v" "v \<in> VV p"
        hence "v \<in> G'.VV p" unfolding G'_def by (simp add: \<open>v \<in> V'\<close>)
        moreover have "\<not>G'.deadend v" using V'_no_deadends \<open>v \<in> V'\<close> \<open>V\<^bsub>G'\<^esub> = V'\<close> by blast
        moreover have "G'.strategy p \<sigma>'"
          using G'.valid_strategy_only_in_V \<sigma>'_def \<sigma>'_is_\<sigma>_on_V' \<sigma>(1) \<open>V\<^bsub>G'\<^esub> = V'\<close> by auto
        ultimately show "\<sigma>' v \<in> V' \<union> A p" using subgame_strategy_stays_in_subgame
          unfolding G'_def by blast
      next
        fix v w assume "v \<in> V'" "\<not>deadend v" "v \<in> VV p**" "v\<rightarrow>w"
        have "w \<notin> A p**" proof
          assume "w \<in> A p**"
          hence "v \<in> A p**" unfolding A_def
            using \<open>v \<in> VV p**\<close> \<open>v\<rightarrow>w\<close> attractor_set_VVp by blast
          thus False using \<open>v \<in> V'\<close> unfolding V'_def by (cases p) auto
        qed
        thus "w \<in> V' \<union> A p" unfolding V'_def using \<open>v\<rightarrow>w\<close> by (cases p) auto
      next
        show "lset P \<inter> A p = {}" proof (rule ccontr)
          assume "lset P \<inter> A p \<noteq> {}"
          have "strategy_attracts p (override_on \<sigma>' \<sigma>_attr (A p - deadends p**))
                                    (A p)
                                    (deadends p**)"
            using strategy_attracts_irrelevant_override[OF \<sigma>_attr(2) \<sigma>_attr(1) \<open>strategy p \<sigma>'\<close>]
            by blast
          moreover have "override_on \<sigma>' \<sigma>_attr (A p - deadends p**) = \<sigma>'"
            by (rule ext, unfold \<sigma>'_def, cases p) (simp_all add: override_on_def)
          ultimately have "strategy_attracts p \<sigma>' (A p) (deadends p**)" by simp
          hence "lset P \<inter> deadends p** \<noteq> {}"
            using \<open>lset P \<inter> A p \<noteq> {}\<close> attracted_path[OF deadends_in_V] by simp
          thus False using contra visits_deadend[of "p**"] by simp
        qed
      qed (insert \<open>v0 \<in> V'\<close>)

      then interpret vmc_path G' P v0 p \<sigma>'
        unfolding G'_def using subgame_path_vmc_path[OF \<open>V' \<subseteq> V\<close>] by blast
      have "G'.path_conforms_with_strategy p P \<sigma>" proof-
        have "\<And>v. v \<in> lset P \<Longrightarrow> \<sigma>' v = \<sigma> v"
          using \<sigma>'_is_\<sigma>_on_V' \<open>V\<^bsub>G'\<^esub> = V'\<close> lset_P_V by blast
        thus "G'.path_conforms_with_strategy p P \<sigma>"
          using P_conforms G'.path_conforms_with_strategy_irrelevant_updates by blast
      qed
      then interpret vmc_path G' P v0 p \<sigma> using conforms_to_another_strategy by blast
      have "G'.winning_path p P"
        using \<sigma>(2)[unfolded G'.winning_strategy_def] vmc_path_axioms by blast
      from \<open>\<not>winning_path p P\<close>
           G'.winning_path_supergame[OF this ParityGame_axioms, unfolded G'_def]
           subgame_VV_subset[of "p**" V']
           subgame_\<omega>[of V']
        show False by blast
    qed
    ultimately show ?thesis unfolding winning_region_def using \<open>v0 \<in> V\<close> by blast
  next
    assume "v0 \<notin> V'"
    then obtain p where "v0 \<in> attractor p (deadends p**)"
      unfolding V'_def A_def using \<open>v0 \<in> V\<close> by blast
    thus ?thesis unfolding winning_region_def
      using lemma_path_to_deadend \<open>v0 \<in> V\<close> by blast
  qed
qed

subsection \<open>The Main Theorem: Positional Determinacy\<close>
text \<open>\label{subsec:positional_determinacy}\<close>

text \<open>
  Prove the main theorem: The winning regions of player \Even and \Odd are a partition of the set
  of nodes @{term V}.
\<close>

theorem partition_into_winning_regions:
  shows "V = winning_region Even \<union> winning_region Odd"
    and "winning_region Even \<inter> winning_region Odd = {}"
proof
  show "V \<subseteq> winning_region Even \<union> winning_region Odd"
    by (rule subsetI) (metis (full_types) Un_iff other_other_player positional_strategy_exists)
next
  show "winning_region Even \<union> winning_region Odd \<subseteq> V"
    by (rule subsetI) (meson Un_iff subsetCE winning_region_in_V)
next
  show "winning_region Even \<inter> winning_region Odd = {}"
    using winning_strategy_only_for_one_player[of Even]
    unfolding winning_region_def by auto
qed

end \<comment> \<open>context ParityGame\<close>

end


(*  Title:      HOL/Algebra/Complete_Lattice.thy
    Author:     Clemens Ballarin, started 7 November 2003
    Copyright:  Clemens Ballarin

Most congruence rules by Stephan Hohe.
With additional contributions from Alasdair Armstrong and Simon Foster.
*)

theory Complete_Lattice
imports Lattice
begin

section \<open>Complete Lattices\<close>

locale weak_complete_lattice = weak_partial_order +
  assumes sup_exists:
    "[| A \<subseteq> carrier L |] ==> EX s. least L s (Upper L A)"
    and inf_exists:
    "[| A \<subseteq> carrier L |] ==> EX i. greatest L i (Lower L A)"

sublocale weak_complete_lattice \<subseteq> weak_lattice
proof
  fix x y
  assume a: "x \<in> carrier L" "y \<in> carrier L"
  thus "\<exists>s. is_lub L s {x, y}"
    by (rule_tac sup_exists[of "{x, y}"], auto)
  from a show "\<exists>s. is_glb L s {x, y}"
    by (rule_tac inf_exists[of "{x, y}"], auto)
qed

text \<open>Introduction rule: the usual definition of complete lattice\<close>

lemma (in weak_partial_order) weak_complete_latticeI:
  assumes sup_exists:
    "!!A. [| A \<subseteq> carrier L |] ==> EX s. least L s (Upper L A)"
    and inf_exists:
    "!!A. [| A \<subseteq> carrier L |] ==> EX i. greatest L i (Lower L A)"
  shows "weak_complete_lattice L"
  by standard (auto intro: sup_exists inf_exists)

lemma (in weak_complete_lattice) dual_weak_complete_lattice:
  "weak_complete_lattice (inv_gorder L)"
proof -
  interpret dual: weak_lattice "inv_gorder L"
    by (metis dual_weak_lattice)

  show ?thesis
    apply (unfold_locales)
    apply (simp_all add:inf_exists sup_exists)
  done
qed

lemma (in weak_complete_lattice) supI:
  "[| !!l. least L l (Upper L A) ==> P l; A \<subseteq> carrier L |]
  ==> P (\<Squnion>A)"
proof (unfold sup_def)
  assume L: "A \<subseteq> carrier L"
    and P: "!!l. least L l (Upper L A) ==> P l"
  with sup_exists obtain s where "least L s (Upper L A)" by blast
  with L show "P (SOME l. least L l (Upper L A))"
  by (fast intro: someI2 weak_least_unique P)
qed

lemma (in weak_complete_lattice) sup_closed [simp]:
  "A \<subseteq> carrier L ==> \<Squnion>A \<in> carrier L"
  by (rule supI) simp_all

lemma (in weak_complete_lattice) sup_cong:
  assumes "A \<subseteq> carrier L" "B \<subseteq> carrier L" "A {.=} B"
  shows "\<Squnion> A .= \<Squnion> B"
proof -
  have "\<And> x. is_lub L x A \<longleftrightarrow> is_lub L x B"
    by (rule least_Upper_cong_r, simp_all add: assms)
  moreover have "\<Squnion> B \<in> carrier L"
    by (simp add: assms(2))
  ultimately show ?thesis
    by (simp add: sup_def)
qed

sublocale weak_complete_lattice \<subseteq> weak_bounded_lattice
  apply (unfold_locales)
  apply (metis Upper_empty empty_subsetI sup_exists)
  apply (metis Lower_empty empty_subsetI inf_exists)
done

lemma (in weak_complete_lattice) infI:
  "[| !!i. greatest L i (Lower L A) ==> P i; A \<subseteq> carrier L |]
  ==> P (\<Sqinter>A)"
proof (unfold inf_def)
  assume L: "A \<subseteq> carrier L"
    and P: "!!l. greatest L l (Lower L A) ==> P l"
  with inf_exists obtain s where "greatest L s (Lower L A)" by blast
  with L show "P (SOME l. greatest L l (Lower L A))"
  by (fast intro: someI2 weak_greatest_unique P)
qed

lemma (in weak_complete_lattice) inf_closed [simp]:
  "A \<subseteq> carrier L ==> \<Sqinter>A \<in> carrier L"
  by (rule infI) simp_all

lemma (in weak_complete_lattice) inf_cong:
  assumes "A \<subseteq> carrier L" "B \<subseteq> carrier L" "A {.=} B"
  shows "\<Sqinter> A .= \<Sqinter> B"
proof -
  have "\<And> x. is_glb L x A \<longleftrightarrow> is_glb L x B"
    by (rule greatest_Lower_cong_r, simp_all add: assms)
  moreover have "\<Sqinter> B \<in> carrier L"
    by (simp add: assms(2))
  ultimately show ?thesis
    by (simp add: inf_def)
qed

theorem (in weak_partial_order) weak_complete_lattice_criterion1:
  assumes top_exists: "EX g. greatest L g (carrier L)"
    and inf_exists:
      "!!A. [| A \<subseteq> carrier L; A ~= {} |] ==> EX i. greatest L i (Lower L A)"
  shows "weak_complete_lattice L"
proof (rule weak_complete_latticeI)
  from top_exists obtain top where top: "greatest L top (carrier L)" ..
  fix A
  assume L: "A \<subseteq> carrier L"
  let ?B = "Upper L A"
  from L top have "top \<in> ?B" by (fast intro!: Upper_memI intro: greatest_le)
  then have B_non_empty: "?B ~= {}" by fast
  have B_L: "?B \<subseteq> carrier L" by simp
  from inf_exists [OF B_L B_non_empty]
  obtain b where b_inf_B: "greatest L b (Lower L ?B)" ..
  have "least L b (Upper L A)"
apply (rule least_UpperI)
   apply (rule greatest_le [where A = "Lower L ?B"])
    apply (rule b_inf_B)
   apply (rule Lower_memI)
    apply (erule Upper_memD [THEN conjunct1])
     apply assumption
    apply (rule L)
   apply (fast intro: L [THEN subsetD])
  apply (erule greatest_Lower_below [OF b_inf_B])
  apply simp
 apply (rule L)
apply (rule greatest_closed [OF b_inf_B])
done
  then show "EX s. least L s (Upper L A)" ..
next
  fix A
  assume L: "A \<subseteq> carrier L"
  show "EX i. greatest L i (Lower L A)"
  proof (cases "A = {}")
    case True then show ?thesis
      by (simp add: top_exists)
  next
    case False with L show ?thesis
      by (rule inf_exists)
  qed
qed

text \<open>Supremum\<close>

declare (in partial_order) weak_sup_of_singleton [simp del]

lemma (in partial_order) sup_of_singleton [simp]:
  "x \<in> carrier L ==> \<Squnion>{x} = x"
  using weak_sup_of_singleton unfolding eq_is_equal .

lemma (in upper_semilattice) join_assoc_lemma:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "x \<squnion> (y \<squnion> z) = \<Squnion>{x, y, z}"
  using weak_join_assoc_lemma L unfolding eq_is_equal .

lemma (in upper_semilattice) join_assoc:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
  using weak_join_assoc L unfolding eq_is_equal .

text \<open>Infimum\<close>

declare (in partial_order) weak_inf_of_singleton [simp del]

lemma (in partial_order) inf_of_singleton [simp]:
  "x \<in> carrier L ==> \<Sqinter>{x} = x"
  using weak_inf_of_singleton unfolding eq_is_equal .

text \<open>Condition on \<open>A\<close>: infimum exists.\<close>

lemma (in lower_semilattice) meet_assoc_lemma:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "x \<sqinter> (y \<sqinter> z) = \<Sqinter>{x, y, z}"
  using weak_meet_assoc_lemma L unfolding eq_is_equal .

lemma (in lower_semilattice) meet_assoc:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
  using weak_meet_assoc L unfolding eq_is_equal .

subsection \<open>Infimum Laws\<close>

context weak_complete_lattice
begin

lemma inf_glb:
  assumes "A \<subseteq> carrier L"
  shows "greatest L (\<Sqinter>A) (Lower L A)"
proof -
  obtain i where "greatest L i (Lower L A)"
    by (metis assms inf_exists)

  thus ?thesis
    apply (simp add: inf_def)
    apply (rule someI2[of _ "i"])
    apply (auto)
  done
qed

lemma inf_lower:
  assumes "A \<subseteq> carrier L" "x \<in> A"
  shows "\<Sqinter>A \<sqsubseteq> x"
  by (metis assms greatest_Lower_below inf_glb)

lemma inf_greatest:
  assumes "A \<subseteq> carrier L" "z \<in> carrier L"
          "(\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x)"
  shows "z \<sqsubseteq> \<Sqinter>A"
  by (metis Lower_memI assms greatest_le inf_glb)

lemma weak_inf_empty [simp]: "\<Sqinter>{} .= \<top>"
  by (metis Lower_empty empty_subsetI inf_glb top_greatest weak_greatest_unique)

lemma weak_inf_carrier [simp]: "\<Sqinter>carrier L .= \<bottom>"
  by (metis bottom_weak_eq inf_closed inf_lower subset_refl)

lemma weak_inf_insert [simp]:
  "\<lbrakk> a \<in> carrier L; A \<subseteq> carrier L \<rbrakk> \<Longrightarrow> \<Sqinter>insert a A .= a \<sqinter> \<Sqinter>A"
  apply (rule weak_le_antisym)
  apply (force intro: meet_le inf_greatest inf_lower inf_closed)
  apply (rule inf_greatest)
  apply (force)
  apply (force intro: inf_closed)
  apply (auto)
  apply (metis inf_closed meet_left)
  apply (force intro: le_trans inf_closed meet_right meet_left inf_lower)
done

subsection \<open>Supremum Laws\<close>

lemma sup_lub:
  assumes "A \<subseteq> carrier L"
  shows "least L (\<Squnion>A) (Upper L A)"
    by (metis Upper_is_closed assms least_closed least_cong supI sup_closed sup_exists weak_least_unique)

lemma sup_upper:
  assumes "A \<subseteq> carrier L" "x \<in> A"
  shows "x \<sqsubseteq> \<Squnion>A"
  by (metis assms least_Upper_above supI)

lemma sup_least:
  assumes "A \<subseteq> carrier L" "z \<in> carrier L"
          "(\<And>x. x \<in> A \<Longrightarrow> x \<sqsubseteq> z)"
  shows "\<Squnion>A \<sqsubseteq> z"
  by (metis Upper_memI assms least_le sup_lub)

lemma weak_sup_empty [simp]: "\<Squnion>{} .= \<bottom>"
  by (metis Upper_empty bottom_least empty_subsetI sup_lub weak_least_unique)

lemma weak_sup_carrier [simp]: "\<Squnion>carrier L .= \<top>"
  by (metis Lower_closed Lower_empty sup_closed sup_upper top_closed top_higher weak_le_antisym)

lemma weak_sup_insert [simp]:
  "\<lbrakk> a \<in> carrier L; A \<subseteq> carrier L \<rbrakk> \<Longrightarrow> \<Squnion>insert a A .= a \<squnion> \<Squnion>A"
  apply (rule weak_le_antisym)
  apply (rule sup_least)
  apply (auto)
  apply (metis join_left sup_closed)
  apply (rule le_trans) defer
  apply (rule join_right)
  apply (auto)
  apply (rule join_le)
  apply (auto intro: sup_upper sup_least sup_closed)
done

end

subsection \<open>Fixed points of a lattice\<close>

definition "fps L f = {x \<in> carrier L. f x .=\<^bsub>L\<^esub> x}"

abbreviation "fpl L f \<equiv> L\<lparr>carrier := fps L f\<rparr>"

lemma (in weak_partial_order)
  use_fps: "x \<in> fps L f \<Longrightarrow> f x .= x"
  by (simp add: fps_def)

lemma fps_carrier [simp]:
  "fps L f \<subseteq> carrier L"
  by (auto simp add: fps_def)

lemma (in weak_complete_lattice) fps_sup_image:
  assumes "f \<in> carrier L \<rightarrow> carrier L" "A \<subseteq> fps L f"
  shows "\<Squnion> (f ` A) .= \<Squnion> A"
proof -
  from assms(2) have AL: "A \<subseteq> carrier L"
    by (auto simp add: fps_def)

  show ?thesis
  proof (rule sup_cong, simp_all add: AL)
    from assms(1) AL show "f ` A \<subseteq> carrier L"
      by (auto)
    from assms(2) show "f ` A {.=} A"
      apply (auto simp add: fps_def)
      apply (rule set_eqI2)
      apply blast
      apply (rename_tac b)
      apply (rule_tac x="f b" in bexI)
      apply (metis (mono_tags, lifting) Ball_Collect assms(1) Pi_iff local.sym)
      apply (auto)
    done
  qed
qed

lemma (in weak_complete_lattice) fps_idem:
  "\<lbrakk> f \<in> carrier L \<rightarrow> carrier L; Idem f \<rbrakk> \<Longrightarrow> fps L f {.=} f ` carrier L"
  apply (rule set_eqI2)
  apply (auto simp add: idempotent_def fps_def)
  apply (metis Pi_iff local.sym)
  apply force
done

context weak_complete_lattice
begin

lemma weak_sup_pre_fixed_point:
  assumes "f \<in> carrier L \<rightarrow> carrier L" "isotone L L f" "A \<subseteq> fps L f"
  shows "(\<Squnion>\<^bsub>L\<^esub> A) \<sqsubseteq>\<^bsub>L\<^esub> f (\<Squnion>\<^bsub>L\<^esub> A)"
proof (rule sup_least)
  from assms(3) show AL: "A \<subseteq> carrier L"
    by (auto simp add: fps_def)
  thus fA: "f (\<Squnion>A) \<in> carrier L"
    by (simp add: assms funcset_carrier[of f L L])
  fix x
  assume xA: "x \<in> A"
  hence "x \<in> fps L f"
    using assms subsetCE by blast
  hence "f x .=\<^bsub>L\<^esub> x"
    by (auto simp add: fps_def)
  moreover have "f x \<sqsubseteq>\<^bsub>L\<^esub> f (\<Squnion>\<^bsub>L\<^esub>A)"
    by (meson AL assms(2) subsetCE sup_closed sup_upper use_iso1 xA)
  ultimately show "x \<sqsubseteq>\<^bsub>L\<^esub> f (\<Squnion>\<^bsub>L\<^esub>A)"
    by (meson AL fA assms(1) funcset_carrier le_cong local.refl subsetCE xA)
qed

lemma weak_sup_post_fixed_point:
  assumes "f \<in> carrier L \<rightarrow> carrier L" "isotone L L f" "A \<subseteq> fps L f"
  shows "f (\<Sqinter>\<^bsub>L\<^esub> A) \<sqsubseteq>\<^bsub>L\<^esub> (\<Sqinter>\<^bsub>L\<^esub> A)"
proof (rule inf_greatest)
  from assms(3) show AL: "A \<subseteq> carrier L"
    by (auto simp add: fps_def)
  thus fA: "f (\<Sqinter>A) \<in> carrier L"
    by (simp add: assms funcset_carrier[of f L L])
  fix x
  assume xA: "x \<in> A"
  hence "x \<in> fps L f"
    using assms subsetCE by blast
  hence "f x .=\<^bsub>L\<^esub> x"
    by (auto simp add: fps_def)
  moreover have "f (\<Sqinter>\<^bsub>L\<^esub>A) \<sqsubseteq>\<^bsub>L\<^esub> f x"
    by (meson AL assms(2) inf_closed inf_lower subsetCE use_iso1 xA)
  ultimately show "f (\<Sqinter>\<^bsub>L\<^esub>A) \<sqsubseteq>\<^bsub>L\<^esub> x"
    by (meson AL assms(1) fA funcset_carrier le_cong_r subsetCE xA)
qed

subsubsection \<open>Least fixed points\<close>

lemma LFP_closed [intro, simp]:
  "\<mu> f \<in> carrier L"
  by (metis (lifting) LFP_def inf_closed mem_Collect_eq subsetI)

lemma LFP_lowerbound:
  assumes "x \<in> carrier L" "f x \<sqsubseteq> x"
  shows "\<mu> f \<sqsubseteq> x"
  by (auto intro:inf_lower assms simp add:LFP_def)

lemma LFP_greatest:
  assumes "x \<in> carrier L"
          "(\<And>u. \<lbrakk> u \<in> carrier L; f u \<sqsubseteq> u \<rbrakk> \<Longrightarrow> x \<sqsubseteq> u)"
  shows "x \<sqsubseteq> \<mu> f"
  by (auto simp add:LFP_def intro:inf_greatest assms)

lemma LFP_lemma2:
  assumes "Mono f" "f \<in> carrier L \<rightarrow> carrier L"
  shows "f (\<mu> f) \<sqsubseteq> \<mu> f"
  using assms
  apply (auto simp add:Pi_def)
  apply (rule LFP_greatest)
  apply (metis LFP_closed)
  apply (metis LFP_closed LFP_lowerbound le_trans use_iso1)
done

lemma LFP_lemma3:
  assumes "Mono f" "f \<in> carrier L \<rightarrow> carrier L"
  shows "\<mu> f \<sqsubseteq> f (\<mu> f)"
  using assms
  apply (auto simp add:Pi_def)
  apply (metis LFP_closed LFP_lemma2 LFP_lowerbound assms(2) use_iso2)
done

lemma LFP_weak_unfold:
  "\<lbrakk> Mono f; f \<in> carrier L \<rightarrow> carrier L \<rbrakk> \<Longrightarrow> \<mu> f .= f (\<mu> f)"
  by (auto intro: LFP_lemma2 LFP_lemma3 funcset_mem)

lemma LFP_fixed_point [intro]:
  assumes "Mono f" "f \<in> carrier L \<rightarrow> carrier L"
  shows "\<mu> f \<in> fps L f"
proof -
  have "f (\<mu> f) \<in> carrier L"
    using assms(2) by blast
  with assms show ?thesis
    by (simp add: LFP_weak_unfold fps_def local.sym)
qed

lemma LFP_least_fixed_point:
  assumes "Mono f" "f \<in> carrier L \<rightarrow> carrier L" "x \<in> fps L f"
  shows "\<mu> f \<sqsubseteq> x"
  using assms by (force intro: LFP_lowerbound simp add: fps_def)

lemma LFP_idem:
  assumes "f \<in> carrier L \<rightarrow> carrier L" "Mono f" "Idem f"
  shows "\<mu> f .= (f \<bottom>)"
proof (rule weak_le_antisym)
  from assms(1) show fb: "f \<bottom> \<in> carrier L"
    by (rule funcset_mem, simp)
  from assms show mf: "\<mu> f \<in> carrier L"
    by blast
  show "\<mu> f \<sqsubseteq> f \<bottom>"
  proof -
    have "f (f \<bottom>) .= f \<bottom>"
      by (auto simp add: fps_def fb assms(3) idempotent)
    moreover have "f (f \<bottom>) \<in> carrier L"
      by (rule funcset_mem[of f "carrier L"], simp_all add: assms fb)
    ultimately show ?thesis
      by (auto intro: LFP_lowerbound simp add: fb)
  qed
  show "f \<bottom> \<sqsubseteq> \<mu> f"
  proof -
    have "f \<bottom> \<sqsubseteq> f (\<mu> f)"
      by (auto intro: use_iso1[of _ f] simp add: assms)
    moreover have "... .= \<mu> f"
      using assms(1) assms(2) fps_def by force
    moreover from assms(1) have "f (\<mu> f) \<in> carrier L"
      by (auto)
    ultimately show ?thesis
      using fb by blast
  qed
qed

subsubsection \<open>Greatest fixed points\<close>

lemma GFP_closed [intro, simp]:
  "\<nu> f \<in> carrier L"
  by (auto intro:sup_closed simp add:GFP_def)

lemma GFP_upperbound:
  assumes "x \<in> carrier L" "x \<sqsubseteq> f x"
  shows "x \<sqsubseteq> \<nu> f"
  by (auto intro:sup_upper assms simp add:GFP_def)

lemma GFP_least:
  assumes "x \<in> carrier L"
          "(\<And>u. \<lbrakk> u \<in> carrier L; u \<sqsubseteq> f u \<rbrakk> \<Longrightarrow> u \<sqsubseteq> x)"
  shows "\<nu> f \<sqsubseteq> x"
  by (auto simp add:GFP_def intro:sup_least assms)

lemma GFP_lemma2:
  assumes "Mono f" "f \<in> carrier L \<rightarrow> carrier L"
  shows "\<nu> f \<sqsubseteq> f (\<nu> f)"
  using assms
  apply (auto simp add:Pi_def)
  apply (rule GFP_least)
  apply (metis GFP_closed)
  apply (metis GFP_closed GFP_upperbound le_trans use_iso2)
done

lemma GFP_lemma3:
  assumes "Mono f" "f \<in> carrier L \<rightarrow> carrier L"
  shows "f (\<nu> f) \<sqsubseteq> \<nu> f"
  by (metis GFP_closed GFP_lemma2 GFP_upperbound assms funcset_mem use_iso2)

lemma GFP_weak_unfold:
  "\<lbrakk> Mono f; f \<in> carrier L \<rightarrow> carrier L \<rbrakk> \<Longrightarrow> \<nu> f .= f (\<nu> f)"
  by (auto intro: GFP_lemma2 GFP_lemma3 funcset_mem)

lemma (in weak_complete_lattice) GFP_fixed_point [intro]:
  assumes "Mono f" "f \<in> carrier L \<rightarrow> carrier L"
  shows "\<nu> f \<in> fps L f"
  using assms
proof -
  have "f (\<nu> f) \<in> carrier L"
    using assms(2) by blast
  with assms show ?thesis
    by (simp add: GFP_weak_unfold fps_def local.sym)
qed

lemma GFP_greatest_fixed_point:
  assumes "Mono f" "f \<in> carrier L \<rightarrow> carrier L" "x \<in> fps L f"
  shows "x \<sqsubseteq> \<nu> f"
  using assms
  by (rule_tac GFP_upperbound, auto simp add: fps_def, meson PiE local.sym weak_refl)

lemma GFP_idem:
  assumes "f \<in> carrier L \<rightarrow> carrier L" "Mono f" "Idem f"
  shows "\<nu> f .= (f \<top>)"
proof (rule weak_le_antisym)
  from assms(1) show fb: "f \<top> \<in> carrier L"
    by (rule funcset_mem, simp)
  from assms show mf: "\<nu> f \<in> carrier L"
    by blast
  show "f \<top> \<sqsubseteq> \<nu> f"
  proof -
    have "f (f \<top>) .= f \<top>"
      by (auto simp add: fps_def fb assms(3) idempotent)
    moreover have "f (f \<top>) \<in> carrier L"
      by (rule funcset_mem[of f "carrier L"], simp_all add: assms fb)
    ultimately show ?thesis
      by (rule_tac GFP_upperbound, simp_all add: fb local.sym)
  qed
  show "\<nu> f \<sqsubseteq> f \<top>"
  proof -
    have "\<nu> f \<sqsubseteq> f (\<nu> f)"
      by (simp add: GFP_lemma2 assms(1) assms(2))
    moreover have "... \<sqsubseteq> f \<top>"
      by (auto intro: use_iso1[of _ f] simp add: assms)
    moreover from assms(1) have "f (\<nu> f) \<in> carrier L"
      by (auto)
    ultimately show ?thesis
      using fb local.le_trans by blast
  qed
qed

end

subsection \<open>Complete lattices where @{text eq} is the Equality\<close>

locale complete_lattice = partial_order +
  assumes sup_exists:
    "[| A \<subseteq> carrier L |] ==> EX s. least L s (Upper L A)"
    and inf_exists:
    "[| A \<subseteq> carrier L |] ==> EX i. greatest L i (Lower L A)"

sublocale complete_lattice \<subseteq> lattice
proof
  fix x y
  assume a: "x \<in> carrier L" "y \<in> carrier L"
  thus "\<exists>s. is_lub L s {x, y}"
    by (rule_tac sup_exists[of "{x, y}"], auto)
  from a show "\<exists>s. is_glb L s {x, y}"
    by (rule_tac inf_exists[of "{x, y}"], auto)
qed

sublocale complete_lattice \<subseteq> weak?: weak_complete_lattice
  by standard (auto intro: sup_exists inf_exists)

lemma complete_lattice_lattice [simp]:
  assumes "complete_lattice X"
  shows "lattice X"
proof -
  interpret c: complete_lattice X
    by (simp add: assms)
  show ?thesis
    by (unfold_locales)
qed

text \<open>Introduction rule: the usual definition of complete lattice\<close>

lemma (in partial_order) complete_latticeI:
  assumes sup_exists:
    "!!A. [| A \<subseteq> carrier L |] ==> EX s. least L s (Upper L A)"
    and inf_exists:
    "!!A. [| A \<subseteq> carrier L |] ==> EX i. greatest L i (Lower L A)"
  shows "complete_lattice L"
  by standard (auto intro: sup_exists inf_exists)

theorem (in partial_order) complete_lattice_criterion1:
  assumes top_exists: "EX g. greatest L g (carrier L)"
    and inf_exists:
      "!!A. [| A \<subseteq> carrier L; A ~= {} |] ==> EX i. greatest L i (Lower L A)"
  shows "complete_lattice L"
proof (rule complete_latticeI)
  from top_exists obtain top where top: "greatest L top (carrier L)" ..
  fix A
  assume L: "A \<subseteq> carrier L"
  let ?B = "Upper L A"
  from L top have "top \<in> ?B" by (fast intro!: Upper_memI intro: greatest_le)
  then have B_non_empty: "?B ~= {}" by fast
  have B_L: "?B \<subseteq> carrier L" by simp
  from inf_exists [OF B_L B_non_empty]
  obtain b where b_inf_B: "greatest L b (Lower L ?B)" ..
  have "least L b (Upper L A)"
apply (rule least_UpperI)
   apply (rule greatest_le [where A = "Lower L ?B"])
    apply (rule b_inf_B)
   apply (rule Lower_memI)
    apply (erule Upper_memD [THEN conjunct1])
     apply assumption
    apply (rule L)
   apply (fast intro: L [THEN subsetD])
  apply (erule greatest_Lower_below [OF b_inf_B])
  apply simp
 apply (rule L)
apply (rule greatest_closed [OF b_inf_B])
done
  then show "EX s. least L s (Upper L A)" ..
next
  fix A
  assume L: "A \<subseteq> carrier L"
  show "EX i. greatest L i (Lower L A)"
  proof (cases "A = {}")
    case True then show ?thesis
      by (simp add: top_exists)
  next
    case False with L show ?thesis
      by (rule inf_exists)
  qed
qed

(* TODO: prove dual version *)

subsection \<open>Fixed points\<close>

context complete_lattice
begin

lemma LFP_unfold:
  "\<lbrakk> Mono f; f \<in> carrier L \<rightarrow> carrier L \<rbrakk> \<Longrightarrow> \<mu> f = f (\<mu> f)"
  using eq_is_equal weak.LFP_weak_unfold by auto

lemma LFP_const:
  "t \<in> carrier L \<Longrightarrow> \<mu> (\<lambda> x. t) = t"
  by (simp add: local.le_antisym weak.LFP_greatest weak.LFP_lowerbound)

lemma LFP_id:
  "\<mu> id = \<bottom>"
  by (simp add: local.le_antisym weak.LFP_lowerbound)

lemma GFP_unfold:
  "\<lbrakk> Mono f; f \<in> carrier L \<rightarrow> carrier L \<rbrakk> \<Longrightarrow> \<nu> f = f (\<nu> f)"
  using eq_is_equal weak.GFP_weak_unfold by auto

lemma GFP_const:
  "t \<in> carrier L \<Longrightarrow> \<nu> (\<lambda> x. t) = t"
  by (simp add: local.le_antisym weak.GFP_least weak.GFP_upperbound)

lemma GFP_id:
  "\<nu> id = \<top>"
  using weak.GFP_upperbound by auto

end

subsection \<open>Interval complete lattices\<close>

context weak_complete_lattice
begin

  lemma at_least_at_most_Sup:
    "\<lbrakk> a \<in> carrier L; b \<in> carrier L; a \<sqsubseteq> b \<rbrakk> \<Longrightarrow> \<Squnion> \<lbrace>a..b\<rbrace> .= b"
    apply (rule weak_le_antisym)
    apply (rule sup_least)
    apply (auto simp add: at_least_at_most_closed)
    apply (rule sup_upper)
    apply (auto simp add: at_least_at_most_closed)
  done

  lemma at_least_at_most_Inf:
    "\<lbrakk> a \<in> carrier L; b \<in> carrier L; a \<sqsubseteq> b \<rbrakk> \<Longrightarrow> \<Sqinter> \<lbrace>a..b\<rbrace> .= a"
    apply (rule weak_le_antisym)
    apply (rule inf_lower)
    apply (auto simp add: at_least_at_most_closed)
    apply (rule inf_greatest)
    apply (auto simp add: at_least_at_most_closed)
  done

end

lemma weak_complete_lattice_interval:
  assumes "weak_complete_lattice L" "a \<in> carrier L" "b \<in> carrier L" "a \<sqsubseteq>\<^bsub>L\<^esub> b"
  shows "weak_complete_lattice (L \<lparr> carrier := \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub> \<rparr>)"
proof -
  interpret L: weak_complete_lattice L
    by (simp add: assms)
  interpret weak_partial_order "L \<lparr> carrier := \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub> \<rparr>"
  proof -
    have "\<lbrace>a..b\<rbrace>\<^bsub>L\<^esub> \<subseteq> carrier L"
      by (auto, simp add: at_least_at_most_def)
    thus "weak_partial_order (L\<lparr>carrier := \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub>\<rparr>)"
      by (simp add: L.weak_partial_order_axioms weak_partial_order_subset)
  qed

  show ?thesis
  proof
    fix A
    assume a: "A \<subseteq> carrier (L\<lparr>carrier := \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub>\<rparr>)"
    show "\<exists>s. is_lub (L\<lparr>carrier := \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub>\<rparr>) s A"
    proof (cases "A = {}")
      case True
      thus ?thesis
        by (rule_tac x="a" in exI, auto simp add: least_def assms)
    next
      case False
      show ?thesis
      proof (rule_tac x="\<Squnion>\<^bsub>L\<^esub> A" in exI, rule least_UpperI, simp_all)
        show b:"\<And> x. x \<in> A \<Longrightarrow> x \<sqsubseteq>\<^bsub>L\<^esub> \<Squnion>\<^bsub>L\<^esub>A"
          using a by (auto intro: L.sup_upper, meson L.at_least_at_most_closed L.sup_upper subset_trans)
        show "\<And>y. y \<in> Upper (L\<lparr>carrier := \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub>\<rparr>) A \<Longrightarrow> \<Squnion>\<^bsub>L\<^esub>A \<sqsubseteq>\<^bsub>L\<^esub> y"
          using a L.at_least_at_most_closed by (rule_tac L.sup_least, auto intro: funcset_mem simp add: Upper_def)
        from a show "A \<subseteq> \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub>"
          by (auto)
        from a show "\<Squnion>\<^bsub>L\<^esub>A \<in> \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub>"
          apply (rule_tac L.at_least_at_most_member)
          apply (auto)
          apply (meson L.at_least_at_most_closed L.sup_closed subset_trans)
          apply (meson False L.at_least_at_most_closed L.at_least_at_most_lower L.le_trans L.sup_closed b all_not_in_conv assms(2) contra_subsetD subset_trans)
          apply (rule L.sup_least)
          apply (auto simp add: assms)
          using L.at_least_at_most_closed apply blast
        done
      qed
    qed
    show "\<exists>s. is_glb (L\<lparr>carrier := \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub>\<rparr>) s A"
    proof (cases "A = {}")
      case True
      thus ?thesis
        by (rule_tac x="b" in exI, auto simp add: greatest_def assms)
    next
      case False
      show ?thesis
      proof (rule_tac x="\<Sqinter>\<^bsub>L\<^esub> A" in exI, rule greatest_LowerI, simp_all)
        show b:"\<And>x. x \<in> A \<Longrightarrow> \<Sqinter>\<^bsub>L\<^esub>A \<sqsubseteq>\<^bsub>L\<^esub> x"
          using a L.at_least_at_most_closed by (force intro!: L.inf_lower)
        show "\<And>y. y \<in> Lower (L\<lparr>carrier := \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub>\<rparr>) A \<Longrightarrow> y \<sqsubseteq>\<^bsub>L\<^esub> \<Sqinter>\<^bsub>L\<^esub>A"
           using a L.at_least_at_most_closed by (rule_tac L.inf_greatest, auto intro: funcset_carrier' simp add: Lower_def)
        from a show "A \<subseteq> \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub>"
          by (auto)
        from a show "\<Sqinter>\<^bsub>L\<^esub>A \<in> \<lbrace>a..b\<rbrace>\<^bsub>L\<^esub>"
          apply (rule_tac L.at_least_at_most_member)
          apply (auto)
          apply (meson L.at_least_at_most_closed L.inf_closed subset_trans)
          apply (meson L.at_least_at_most_closed L.at_least_at_most_lower L.inf_greatest assms(2) set_rev_mp subset_trans)
          apply (meson False L.at_least_at_most_closed L.at_least_at_most_upper L.inf_closed L.le_trans b all_not_in_conv assms(3) contra_subsetD subset_trans)
        done
      qed
    qed
  qed
qed

subsection \<open>Knaster-Tarski theorem and variants\<close>

text \<open>The set of fixed points of a complete lattice is itself a complete lattice\<close>

theorem Knaster_Tarski:
  assumes "weak_complete_lattice L" "f \<in> carrier L \<rightarrow> carrier L" "isotone L L f"
  shows "weak_complete_lattice (fpl L f)" (is "weak_complete_lattice ?L'")
proof -
  interpret L: weak_complete_lattice L
    by (simp add: assms)
  interpret weak_partial_order ?L'
  proof -
    have "{x \<in> carrier L. f x .=\<^bsub>L\<^esub> x} \<subseteq> carrier L"
      by (auto)
    thus "weak_partial_order ?L'"
      by (simp add: L.weak_partial_order_axioms weak_partial_order_subset)
  qed
  show ?thesis
  proof (unfold_locales, simp_all)
    fix A
    assume A: "A \<subseteq> fps L f"
    show "\<exists>s. is_lub (fpl L f) s A"
    proof
      from A have AL: "A \<subseteq> carrier L"
        by (meson fps_carrier subset_eq)

      let ?w = "\<Squnion>\<^bsub>L\<^esub> A"
      have w: "f (\<Squnion>\<^bsub>L\<^esub>A) \<in> carrier L"
        by (rule funcset_mem[of f "carrier L"], simp_all add: AL assms(2))

      have pf_w: "(\<Squnion>\<^bsub>L\<^esub> A) \<sqsubseteq>\<^bsub>L\<^esub> f (\<Squnion>\<^bsub>L\<^esub> A)"
        by (simp add: A L.weak_sup_pre_fixed_point assms(2) assms(3))

      have f_top_chain: "f ` \<lbrace>?w..\<top>\<^bsub>L\<^esub>\<rbrace>\<^bsub>L\<^esub> \<subseteq> \<lbrace>?w..\<top>\<^bsub>L\<^esub>\<rbrace>\<^bsub>L\<^esub>"
      proof (auto simp add: at_least_at_most_def)
        fix x
        assume b: "x \<in> carrier L" "\<Squnion>\<^bsub>L\<^esub>A \<sqsubseteq>\<^bsub>L\<^esub> x"
        from b show fx: "f x \<in> carrier L"
          using assms(2) by blast
        show "\<Squnion>\<^bsub>L\<^esub>A \<sqsubseteq>\<^bsub>L\<^esub> f x"
        proof -
          have "?w \<sqsubseteq>\<^bsub>L\<^esub> f ?w"
          proof (rule_tac L.sup_least, simp_all add: AL w)
            fix y
            assume c: "y \<in> A"
            hence y: "y \<in> fps L f"
              using A subsetCE by blast
            with assms have "y .=\<^bsub>L\<^esub> f y"
            proof -
              from y have "y \<in> carrier L"
                by (simp add: fps_def)
              moreover hence "f y \<in> carrier L"
                by (rule_tac funcset_mem[of f "carrier L"], simp_all add: assms)
              ultimately show ?thesis using y
                by (rule_tac L.sym, simp_all add: L.use_fps)
            qed
            moreover have "y \<sqsubseteq>\<^bsub>L\<^esub> \<Squnion>\<^bsub>L\<^esub>A"
              by (simp add: AL L.sup_upper c(1))
            ultimately show "y \<sqsubseteq>\<^bsub>L\<^esub> f (\<Squnion>\<^bsub>L\<^esub>A)"
              by (meson fps_def AL funcset_mem L.refl L.weak_complete_lattice_axioms assms(2) assms(3) c(1) isotone_def rev_subsetD weak_complete_lattice.sup_closed weak_partial_order.le_cong)
          qed
          thus ?thesis
            by (meson AL funcset_mem L.le_trans L.sup_closed assms(2) assms(3) b(1) b(2) use_iso2)
        qed

        show "f x \<sqsubseteq>\<^bsub>L\<^esub> \<top>\<^bsub>L\<^esub>"
          by (simp add: fx)
      qed

      let ?L' = "L\<lparr> carrier := \<lbrace>?w..\<top>\<^bsub>L\<^esub>\<rbrace>\<^bsub>L\<^esub> \<rparr>"

      interpret L': weak_complete_lattice ?L'
        by (auto intro: weak_complete_lattice_interval simp add: L.weak_complete_lattice_axioms AL)

      let ?L'' = "L\<lparr> carrier := fps L f \<rparr>"

      show "is_lub ?L'' (\<mu>\<^bsub>?L'\<^esub> f) A"
      proof (rule least_UpperI, simp_all)
        fix x
        assume "x \<in> Upper ?L'' A"
        hence "\<mu>\<^bsub>?L'\<^esub> f \<sqsubseteq>\<^bsub>?L'\<^esub> x"
          apply (rule_tac L'.LFP_lowerbound)
          apply (auto simp add: Upper_def)
          apply (simp add: A AL L.at_least_at_most_member L.sup_least set_rev_mp)
          apply (simp add: Pi_iff assms(2) fps_def, rule_tac L.weak_refl)
          apply (auto)
          apply (rule funcset_mem[of f "carrier L"], simp_all add: assms(2))
        done
        thus " \<mu>\<^bsub>?L'\<^esub> f \<sqsubseteq>\<^bsub>L\<^esub> x"
          by (simp)
      next
        fix x
        assume xA: "x \<in> A"
        show "x \<sqsubseteq>\<^bsub>L\<^esub> \<mu>\<^bsub>?L'\<^esub> f"
        proof -
          have "\<mu>\<^bsub>?L'\<^esub> f \<in> carrier ?L'"
            by blast
          thus ?thesis
            by (simp, meson AL L.at_least_at_most_closed L.at_least_at_most_lower L.le_trans L.sup_closed L.sup_upper xA subsetCE)
        qed
      next
        show "A \<subseteq> fps L f"
          by (simp add: A)
      next
        show "\<mu>\<^bsub>?L'\<^esub> f \<in> fps L f"
        proof (auto simp add: fps_def)
          have "\<mu>\<^bsub>?L'\<^esub> f \<in> carrier ?L'"
            by (rule L'.LFP_closed)
          thus c:"\<mu>\<^bsub>?L'\<^esub> f \<in> carrier L"
             by (auto simp add: at_least_at_most_def)
          have "\<mu>\<^bsub>?L'\<^esub> f .=\<^bsub>?L'\<^esub> f (\<mu>\<^bsub>?L'\<^esub> f)"
          proof (rule "L'.LFP_weak_unfold", simp_all)
            show "f \<in> \<lbrace>\<Squnion>\<^bsub>L\<^esub>A..\<top>\<^bsub>L\<^esub>\<rbrace>\<^bsub>L\<^esub> \<rightarrow> \<lbrace>\<Squnion>\<^bsub>L\<^esub>A..\<top>\<^bsub>L\<^esub>\<rbrace>\<^bsub>L\<^esub>"
              apply (auto simp add: Pi_def at_least_at_most_def)
              using assms(2) apply blast
              apply (meson AL funcset_mem L.le_trans L.sup_closed assms(2) assms(3) pf_w use_iso2)
              using assms(2) apply blast
            done
            from assms(3) show "Mono\<^bsub>L\<lparr>carrier := \<lbrace>\<Squnion>\<^bsub>L\<^esub>A..\<top>\<^bsub>L\<^esub>\<rbrace>\<^bsub>L\<^esub>\<rparr>\<^esub> f"
              apply (auto simp add: isotone_def)
              using L'.weak_partial_order_axioms apply blast
              apply (meson L.at_least_at_most_closed subsetCE)
            done
          qed
          thus "f (\<mu>\<^bsub>?L'\<^esub> f) .=\<^bsub>L\<^esub> \<mu>\<^bsub>?L'\<^esub> f"
            by (simp add: L.equivalence_axioms funcset_carrier' c assms(2) equivalence.sym)
        qed
      qed
    qed
    show "\<exists>i. is_glb (L\<lparr>carrier := fps L f\<rparr>) i A"
    proof
      from A have AL: "A \<subseteq> carrier L"
        by (meson fps_carrier subset_eq)

      let ?w = "\<Sqinter>\<^bsub>L\<^esub> A"
      have w: "f (\<Sqinter>\<^bsub>L\<^esub>A) \<in> carrier L"
        by (simp add: AL funcset_carrier' assms(2))

      have pf_w: "f (\<Sqinter>\<^bsub>L\<^esub> A) \<sqsubseteq>\<^bsub>L\<^esub> (\<Sqinter>\<^bsub>L\<^esub> A)"
        by (simp add: A L.weak_sup_post_fixed_point assms(2) assms(3))

      have f_bot_chain: "f ` \<lbrace>\<bottom>\<^bsub>L\<^esub>..?w\<rbrace>\<^bsub>L\<^esub> \<subseteq> \<lbrace>\<bottom>\<^bsub>L\<^esub>..?w\<rbrace>\<^bsub>L\<^esub>"
      proof (auto simp add: at_least_at_most_def)
        fix x
        assume b: "x \<in> carrier L" "x \<sqsubseteq>\<^bsub>L\<^esub> \<Sqinter>\<^bsub>L\<^esub>A"
        from b show fx: "f x \<in> carrier L"
          using assms(2) by blast
        show "f x \<sqsubseteq>\<^bsub>L\<^esub> \<Sqinter>\<^bsub>L\<^esub>A"
        proof -
          have "f ?w \<sqsubseteq>\<^bsub>L\<^esub> ?w"
          proof (rule_tac L.inf_greatest, simp_all add: AL w)
            fix y
            assume c: "y \<in> A"
            with assms have "y .=\<^bsub>L\<^esub> f y"
              by (metis (no_types, lifting) A funcset_carrier'[OF assms(2)] L.sym fps_def mem_Collect_eq subset_eq)
            moreover have "\<Sqinter>\<^bsub>L\<^esub>A \<sqsubseteq>\<^bsub>L\<^esub> y"
              by (simp add: AL L.inf_lower c)
            ultimately show "f (\<Sqinter>\<^bsub>L\<^esub>A) \<sqsubseteq>\<^bsub>L\<^esub> y"
              by (meson AL L.inf_closed L.le_trans c pf_w set_rev_mp w)
          qed
          thus ?thesis
            by (meson AL L.inf_closed L.le_trans assms(3) b(1) b(2) fx use_iso2 w)
        qed

        show "\<bottom>\<^bsub>L\<^esub> \<sqsubseteq>\<^bsub>L\<^esub> f x"
          by (simp add: fx)
      qed

      let ?L' = "L\<lparr> carrier := \<lbrace>\<bottom>\<^bsub>L\<^esub>..?w\<rbrace>\<^bsub>L\<^esub> \<rparr>"

      interpret L': weak_complete_lattice ?L'
        by (auto intro!: weak_complete_lattice_interval simp add: L.weak_complete_lattice_axioms AL)

      let ?L'' = "L\<lparr> carrier := fps L f \<rparr>"

      show "is_glb ?L'' (\<nu>\<^bsub>?L'\<^esub> f) A"
      proof (rule greatest_LowerI, simp_all)
        fix x
        assume "x \<in> Lower ?L'' A"
        hence "x \<sqsubseteq>\<^bsub>?L'\<^esub> \<nu>\<^bsub>?L'\<^esub> f"
          apply (rule_tac L'.GFP_upperbound)
          apply (auto simp add: Lower_def)
          apply (meson A AL L.at_least_at_most_member L.bottom_lower L.weak_complete_lattice_axioms fps_carrier subsetCE weak_complete_lattice.inf_greatest)
          apply (simp add: funcset_carrier' L.sym assms(2) fps_def)
        done
        thus "x \<sqsubseteq>\<^bsub>L\<^esub> \<nu>\<^bsub>?L'\<^esub> f"
          by (simp)
      next
        fix x
        assume xA: "x \<in> A"
        show "\<nu>\<^bsub>?L'\<^esub> f \<sqsubseteq>\<^bsub>L\<^esub> x"
        proof -
          have "\<nu>\<^bsub>?L'\<^esub> f \<in> carrier ?L'"
            by blast
          thus ?thesis
            by (simp, meson AL L.at_least_at_most_closed L.at_least_at_most_upper L.inf_closed L.inf_lower L.le_trans subsetCE xA)
        qed
      next
        show "A \<subseteq> fps L f"
          by (simp add: A)
      next
        show "\<nu>\<^bsub>?L'\<^esub> f \<in> fps L f"
        proof (auto simp add: fps_def)
          have "\<nu>\<^bsub>?L'\<^esub> f \<in> carrier ?L'"
            by (rule L'.GFP_closed)
          thus c:"\<nu>\<^bsub>?L'\<^esub> f \<in> carrier L"
             by (auto simp add: at_least_at_most_def)
          have "\<nu>\<^bsub>?L'\<^esub> f .=\<^bsub>?L'\<^esub> f (\<nu>\<^bsub>?L'\<^esub> f)"
          proof (rule "L'.GFP_weak_unfold", simp_all)
            show "f \<in> \<lbrace>\<bottom>\<^bsub>L\<^esub>..?w\<rbrace>\<^bsub>L\<^esub> \<rightarrow> \<lbrace>\<bottom>\<^bsub>L\<^esub>..?w\<rbrace>\<^bsub>L\<^esub>"
              apply (auto simp add: Pi_def at_least_at_most_def)
              using assms(2) apply blast
              apply (simp add: funcset_carrier' assms(2))
              apply (meson AL funcset_carrier L.inf_closed L.le_trans assms(2) assms(3) pf_w use_iso2)
            done
            from assms(3) show "Mono\<^bsub>L\<lparr>carrier := \<lbrace>\<bottom>\<^bsub>L\<^esub>..?w\<rbrace>\<^bsub>L\<^esub>\<rparr>\<^esub> f"
              apply (auto simp add: isotone_def)
              using L'.weak_partial_order_axioms apply blast
              using L.at_least_at_most_closed apply (blast intro: funcset_carrier')
            done
          qed
          thus "f (\<nu>\<^bsub>?L'\<^esub> f) .=\<^bsub>L\<^esub> \<nu>\<^bsub>?L'\<^esub> f"
            by (simp add: L.equivalence_axioms funcset_carrier' c assms(2) equivalence.sym)
        qed
      qed
    qed
  qed
qed

theorem Knaster_Tarski_top:
  assumes "weak_complete_lattice L" "isotone L L f" "f \<in> carrier L \<rightarrow> carrier L"
  shows "\<top>\<^bsub>fpl L f\<^esub> .=\<^bsub>L\<^esub> \<nu>\<^bsub>L\<^esub> f"
proof -
  interpret L: weak_complete_lattice L
    by (simp add: assms)
  interpret L': weak_complete_lattice "fpl L f"
    by (rule Knaster_Tarski, simp_all add: assms)
  show ?thesis
  proof (rule L.weak_le_antisym, simp_all)
    show "\<top>\<^bsub>fpl L f\<^esub> \<sqsubseteq>\<^bsub>L\<^esub> \<nu>\<^bsub>L\<^esub> f"
      by (rule L.GFP_greatest_fixed_point, simp_all add: assms L'.top_closed[simplified])
    show "\<nu>\<^bsub>L\<^esub> f \<sqsubseteq>\<^bsub>L\<^esub> \<top>\<^bsub>fpl L f\<^esub>"
    proof -
      have "\<nu>\<^bsub>L\<^esub> f \<in> fps L f"
        by (rule L.GFP_fixed_point, simp_all add: assms)
      hence "\<nu>\<^bsub>L\<^esub> f \<in> carrier (fpl L f)"
        by simp
      hence "\<nu>\<^bsub>L\<^esub> f \<sqsubseteq>\<^bsub>fpl L f\<^esub> \<top>\<^bsub>fpl L f\<^esub>"
        by (rule L'.top_higher)
      thus ?thesis
        by simp
    qed
    show "\<top>\<^bsub>fpl L f\<^esub> \<in> carrier L"
    proof -
      have "carrier (fpl L f) \<subseteq> carrier L"
        by (auto simp add: fps_def)
      with L'.top_closed show ?thesis
        by blast
    qed
  qed
qed

theorem Knaster_Tarski_bottom:
  assumes "weak_complete_lattice L" "isotone L L f" "f \<in> carrier L \<rightarrow> carrier L"
  shows "\<bottom>\<^bsub>fpl L f\<^esub> .=\<^bsub>L\<^esub> \<mu>\<^bsub>L\<^esub> f"
proof -
  interpret L: weak_complete_lattice L
    by (simp add: assms)
  interpret L': weak_complete_lattice "fpl L f"
    by (rule Knaster_Tarski, simp_all add: assms)
  show ?thesis
  proof (rule L.weak_le_antisym, simp_all)
    show "\<mu>\<^bsub>L\<^esub> f \<sqsubseteq>\<^bsub>L\<^esub> \<bottom>\<^bsub>fpl L f\<^esub>"
      by (rule L.LFP_least_fixed_point, simp_all add: assms L'.bottom_closed[simplified])
    show "\<bottom>\<^bsub>fpl L f\<^esub> \<sqsubseteq>\<^bsub>L\<^esub> \<mu>\<^bsub>L\<^esub> f"
    proof -
      have "\<mu>\<^bsub>L\<^esub> f \<in> fps L f"
        by (rule L.LFP_fixed_point, simp_all add: assms)
      hence "\<mu>\<^bsub>L\<^esub> f \<in> carrier (fpl L f)"
        by simp
      hence "\<bottom>\<^bsub>fpl L f\<^esub> \<sqsubseteq>\<^bsub>fpl L f\<^esub> \<mu>\<^bsub>L\<^esub> f"
        by (rule L'.bottom_lower)
      thus ?thesis
        by simp
    qed
    show "\<bottom>\<^bsub>fpl L f\<^esub> \<in> carrier L"
    proof -
      have "carrier (fpl L f) \<subseteq> carrier L"
        by (auto simp add: fps_def)
      with L'.bottom_closed show ?thesis
        by blast
    qed
  qed
qed

text \<open>If a function is both idempotent and isotone then the image of the function forms a complete lattice\<close>

theorem Knaster_Tarski_idem:
  assumes "complete_lattice L" "f \<in> carrier L \<rightarrow> carrier L" "isotone L L f" "idempotent L f"
  shows "complete_lattice (L\<lparr>carrier := f ` carrier L\<rparr>)"
proof -
  interpret L: complete_lattice L
    by (simp add: assms)
  have "fps L f = f ` carrier L"
    using L.weak.fps_idem[OF assms(2) assms(4)]
    by (simp add: L.set_eq_is_eq)
  then interpret L': weak_complete_lattice "(L\<lparr>carrier := f ` carrier L\<rparr>)"
    by (metis Knaster_Tarski L.weak.weak_complete_lattice_axioms assms(2) assms(3))
  show ?thesis
    using L'.sup_exists L'.inf_exists
    by (unfold_locales, auto simp add: L.eq_is_equal)
qed

theorem Knaster_Tarski_idem_extremes:
  assumes "weak_complete_lattice L" "isotone L L f" "idempotent L f" "f \<in> carrier L \<rightarrow> carrier L"
  shows "\<top>\<^bsub>fpl L f\<^esub> .=\<^bsub>L\<^esub> f (\<top>\<^bsub>L\<^esub>)" "\<bottom>\<^bsub>fpl L f\<^esub> .=\<^bsub>L\<^esub> f (\<bottom>\<^bsub>L\<^esub>)"
proof -
  interpret L: weak_complete_lattice "L"
    by (simp_all add: assms)
  interpret L': weak_complete_lattice "fpl L f"
    by (rule Knaster_Tarski, simp_all add: assms)
  have FA: "fps L f \<subseteq> carrier L"
    by (auto simp add: fps_def)
  show "\<top>\<^bsub>fpl L f\<^esub> .=\<^bsub>L\<^esub> f (\<top>\<^bsub>L\<^esub>)"
  proof -
    from FA have "\<top>\<^bsub>fpl L f\<^esub> \<in> carrier L"
    proof -
      have "\<top>\<^bsub>fpl L f\<^esub> \<in> fps L f"
        using L'.top_closed by auto
      thus ?thesis
        using FA by blast
    qed
    moreover with assms have "f \<top>\<^bsub>L\<^esub> \<in> carrier L"
      by (auto)

    ultimately show ?thesis
      using L.trans[OF Knaster_Tarski_top[of L f] L.GFP_idem[of f]]
      by (simp_all add: assms)
  qed
  show "\<bottom>\<^bsub>fpl L f\<^esub> .=\<^bsub>L\<^esub> f (\<bottom>\<^bsub>L\<^esub>)"
  proof -
    from FA have "\<bottom>\<^bsub>fpl L f\<^esub> \<in> carrier L"
    proof -
      have "\<bottom>\<^bsub>fpl L f\<^esub> \<in> fps L f"
        using L'.bottom_closed by auto
      thus ?thesis
        using FA by blast
    qed
    moreover with assms have "f \<bottom>\<^bsub>L\<^esub> \<in> carrier L"
      by (auto)

    ultimately show ?thesis
      using L.trans[OF Knaster_Tarski_bottom[of L f] L.LFP_idem[of f]]
      by (simp_all add: assms)
  qed
qed

theorem Knaster_Tarski_idem_inf_eq:
  assumes "weak_complete_lattice L" "isotone L L f" "idempotent L f" "f \<in> carrier L \<rightarrow> carrier L"
          "A \<subseteq> fps L f"
  shows "\<Sqinter>\<^bsub>fpl L f\<^esub> A .=\<^bsub>L\<^esub> f (\<Sqinter>\<^bsub>L\<^esub> A)"
proof -
  interpret L: weak_complete_lattice "L"
    by (simp_all add: assms)
  interpret L': weak_complete_lattice "fpl L f"
    by (rule Knaster_Tarski, simp_all add: assms)
  have FA: "fps L f \<subseteq> carrier L"
    by (auto simp add: fps_def)
  have A: "A \<subseteq> carrier L"
    using FA assms(5) by blast
  have fA: "f (\<Sqinter>\<^bsub>L\<^esub>A) \<in> fps L f"
    by (metis (no_types, lifting) A L.idempotent L.inf_closed PiE assms(3) assms(4) fps_def mem_Collect_eq)
  have infA: "\<Sqinter>\<^bsub>fpl L f\<^esub>A \<in> fps L f"
    by (rule L'.inf_closed[simplified], simp add: assms)
  show ?thesis
  proof (rule L.weak_le_antisym)
    show ic: "\<Sqinter>\<^bsub>fpl L f\<^esub>A \<in> carrier L"
      using FA infA by blast
    show fc: "f (\<Sqinter>\<^bsub>L\<^esub>A) \<in> carrier L"
      using FA fA by blast
    show "f (\<Sqinter>\<^bsub>L\<^esub>A) \<sqsubseteq>\<^bsub>L\<^esub> \<Sqinter>\<^bsub>fpl L f\<^esub>A"
    proof -
      have "\<And>x. x \<in> A \<Longrightarrow> f (\<Sqinter>\<^bsub>L\<^esub>A) \<sqsubseteq>\<^bsub>L\<^esub> x"
        by (meson A FA L.inf_closed L.inf_lower L.le_trans L.weak_sup_post_fixed_point assms(2) assms(4) assms(5) fA subsetCE)
      hence "f (\<Sqinter>\<^bsub>L\<^esub>A) \<sqsubseteq>\<^bsub>fpl L f\<^esub> \<Sqinter>\<^bsub>fpl L f\<^esub>A"
        by (rule_tac L'.inf_greatest, simp_all add: fA assms(3,5))
      thus ?thesis
        by (simp)
    qed
    show "\<Sqinter>\<^bsub>fpl L f\<^esub>A \<sqsubseteq>\<^bsub>L\<^esub> f (\<Sqinter>\<^bsub>L\<^esub>A)"
    proof -
      have "\<And>x. x \<in> A \<Longrightarrow> \<Sqinter>\<^bsub>fpl L f\<^esub>A \<sqsubseteq>\<^bsub>fpl L f\<^esub> x"
        by (rule L'.inf_lower, simp_all add: assms)
      hence "\<Sqinter>\<^bsub>fpl L f\<^esub>A \<sqsubseteq>\<^bsub>L\<^esub> (\<Sqinter>\<^bsub>L\<^esub>A)"
        apply (rule_tac L.inf_greatest, simp_all add: A)
        using FA infA apply blast
        done
      hence 1:"f(\<Sqinter>\<^bsub>fpl L f\<^esub>A) \<sqsubseteq>\<^bsub>L\<^esub> f(\<Sqinter>\<^bsub>L\<^esub>A)"
        by (metis (no_types, lifting) A FA L.inf_closed assms(2) infA subsetCE use_iso1)
      have 2:"\<Sqinter>\<^bsub>fpl L f\<^esub>A \<sqsubseteq>\<^bsub>L\<^esub> f (\<Sqinter>\<^bsub>fpl L f\<^esub>A)"
        by (metis (no_types, lifting) FA L.sym L.use_fps L.weak_complete_lattice_axioms PiE assms(4) infA subsetCE weak_complete_lattice_def weak_partial_order.weak_refl)

      show ?thesis
        using FA fA infA by (auto intro!: L.le_trans[OF 2 1] ic fc, metis FA PiE assms(4) subsetCE)
    qed
  qed
qed

subsection \<open>Examples\<close>

subsubsection \<open>The Powerset of a Set is a Complete Lattice\<close>

theorem powerset_is_complete_lattice:
  "complete_lattice \<lparr>carrier = Pow A, eq = op =, le = op \<subseteq>\<rparr>"
  (is "complete_lattice ?L")
proof (rule partial_order.complete_latticeI)
  show "partial_order ?L"
    by standard auto
next
  fix B
  assume "B \<subseteq> carrier ?L"
  then have "least ?L (\<Union> B) (Upper ?L B)"
    by (fastforce intro!: least_UpperI simp: Upper_def)
  then show "EX s. least ?L s (Upper ?L B)" ..
next
  fix B
  assume "B \<subseteq> carrier ?L"
  then have "greatest ?L (\<Inter> B \<inter> A) (Lower ?L B)"
    txt \<open>@{term "\<Inter> B"} is not the infimum of @{term B}:
      @{term "\<Inter> {} = UNIV"} which is in general bigger than @{term "A"}! \<close>
    by (fastforce intro!: greatest_LowerI simp: Lower_def)
  then show "EX i. greatest ?L i (Lower ?L B)" ..
qed

text \<open>Another example, that of the lattice of subgroups of a group,
  can be found in Group theory (Section~\ref{sec:subgroup-lattice}).\<close>

subsection \<open>Limit preserving functions\<close>

definition weak_sup_pres :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
"weak_sup_pres X Y f \<equiv> complete_lattice X \<and> complete_lattice Y \<and> (\<forall> A \<subseteq> carrier X. A \<noteq> {} \<longrightarrow> f (\<Squnion>\<^bsub>X\<^esub> A) = (\<Squnion>\<^bsub>Y\<^esub> (f ` A)))"

definition sup_pres :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
"sup_pres X Y f \<equiv> complete_lattice X \<and> complete_lattice Y \<and> (\<forall> A \<subseteq> carrier X. f (\<Squnion>\<^bsub>X\<^esub> A) = (\<Squnion>\<^bsub>Y\<^esub> (f ` A)))"

definition weak_inf_pres :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
"weak_inf_pres X Y f \<equiv> complete_lattice X \<and> complete_lattice Y \<and> (\<forall> A \<subseteq> carrier X. A \<noteq> {} \<longrightarrow> f (\<Sqinter>\<^bsub>X\<^esub> A) = (\<Sqinter>\<^bsub>Y\<^esub> (f ` A)))"

definition inf_pres :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
"inf_pres X Y f \<equiv> complete_lattice X \<and> complete_lattice Y \<and> (\<forall> A \<subseteq> carrier X. f (\<Sqinter>\<^bsub>X\<^esub> A) = (\<Sqinter>\<^bsub>Y\<^esub> (f ` A)))"

lemma weak_sup_pres:
  "sup_pres X Y f \<Longrightarrow> weak_sup_pres X Y f"
  by (simp add: sup_pres_def weak_sup_pres_def)

lemma weak_inf_pres:
  "inf_pres X Y f \<Longrightarrow> weak_inf_pres X Y f"
  by (simp add: inf_pres_def weak_inf_pres_def)

lemma sup_pres_is_join_pres:
  assumes "weak_sup_pres X Y f"
  shows "join_pres X Y f"
  using assms
  apply (simp add: join_pres_def weak_sup_pres_def, safe)
  apply (rename_tac x y)
  apply (drule_tac x="{x, y}" in spec)
  apply (auto simp add: join_def)
done

lemma inf_pres_is_meet_pres:
  assumes "weak_inf_pres X Y f"
  shows "meet_pres X Y f"
  using assms
  apply (simp add: meet_pres_def weak_inf_pres_def, safe)
  apply (rename_tac x y)
  apply (drule_tac x="{x, y}" in spec)
  apply (auto simp add: meet_def)
done

end


(*  Title:      HOL/ex/Intuitionistic.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge

Taken from FOL/ex/int.ML
*)

section \<open>Higher-Order Logic: Intuitionistic predicate calculus problems\<close>

theory Intuitionistic imports MainRLT begin

(*Metatheorem (for PROPOSITIONAL formulae...):
  P is classically provable iff ~~P is intuitionistically provable.
  Therefore ~P is classically provable iff it is intuitionistically provable.

Proof: Let Q be the conjuction of the propositions A|~A, one for each atom A
in P.  Now ~~Q is intuitionistically provable because ~~(A|~A) is and because
~~ distributes over &.  If P is provable classically, then clearly Q-->P is
provable intuitionistically, so ~~(Q-->P) is also provable intuitionistically.
The latter is intuitionistically equivalent to ~~Q-->~~P, hence to ~~P, since
~~Q is intuitionistically provable.  Finally, if P is a negation then ~~P is
intuitionstically equivalent to P.  [Andy Pitts] *)

lemma "(~~(P&Q)) = ((~~P) & (~~Q))"
  by iprover

lemma "~~ ((~P --> Q) --> (~P --> ~Q) --> P)"
  by iprover

(* ~~ does NOT distribute over | *)

lemma "(~~(P-->Q))  = (~~P --> ~~Q)"
  by iprover

lemma "(~~~P) = (~P)"
  by iprover

lemma "~~((P --> Q | R)  -->  (P-->Q) | (P-->R))"
  by iprover

lemma "(P=Q) = (Q=P)"
  by iprover

lemma "((P --> (Q | (Q-->R))) --> R) --> R"
  by iprover

lemma "(((G-->A) --> J) --> D --> E) --> (((H-->B)-->I)-->C-->J)
      --> (A-->H) --> F --> G --> (((C-->B)-->I)-->D)-->(A-->C)
      --> (((F-->A)-->B) --> I) --> E"
  by iprover

(* Lemmas for the propositional double-negation translation *)

lemma "P --> ~~P"
  by iprover

lemma "~~(~~P --> P)"
  by iprover

lemma "~~P & ~~(P --> Q) --> ~~Q"
  by iprover

(* de Bruijn formulae *)

(*de Bruijn formula with three predicates*)
lemma "((P=Q) --> P&Q&R) &
       ((Q=R) --> P&Q&R) &
       ((R=P) --> P&Q&R) --> P&Q&R"
  by iprover

(*de Bruijn formula with five predicates*)
lemma "((P=Q) --> P&Q&R&S&T) &
       ((Q=R) --> P&Q&R&S&T) &
       ((R=S) --> P&Q&R&S&T) &
       ((S=T) --> P&Q&R&S&T) &
       ((T=P) --> P&Q&R&S&T) --> P&Q&R&S&T"
  by iprover

(*** Problems from Sahlin, Franzen and Haridi,
     An Intuitionistic Predicate Logic Theorem Prover.
     J. Logic and Comp. 2 (5), October 1992, 619-656.
***)

(*Problem 1.1*)
lemma "(\<forall>x. \<exists>y. \<forall>z. p(x) \<and> q(y) \<and> r(z)) =
       (\<forall>z. \<exists>y. \<forall>x. p(x) \<and> q(y) \<and> r(z))"
  by (iprover del: allE elim 2: allE')

(*Problem 3.1*)
lemma "\<not> (\<exists>x. \<forall>y. p y x = (\<not> p x x))"
  by iprover

(* Intuitionistic FOL: propositional problems based on Pelletier. *)

(* Problem ~~1 *)
lemma "~~((P-->Q)  =  (~Q --> ~P))"
  by iprover

(* Problem ~~2 *)
lemma "~~(~~P  =  P)"
  by iprover

(* Problem 3 *)
lemma "~(P-->Q) --> (Q-->P)"
  by iprover

(* Problem ~~4 *)
lemma "~~((~P-->Q)  =  (~Q --> P))"
  by iprover

(* Problem ~~5 *)
lemma "~~((P|Q-->P|R) --> P|(Q-->R))"
  by iprover

(* Problem ~~6 *)
lemma "~~(P | ~P)"
  by iprover

(* Problem ~~7 *)
lemma "~~(P | ~~~P)"
  by iprover

(* Problem ~~8.  Peirce's law *)
lemma "~~(((P-->Q) --> P)  -->  P)"
  by iprover

(* Problem 9 *)
lemma "((P|Q) & (~P|Q) & (P| ~Q)) --> ~ (~P | ~Q)"
  by iprover

(* Problem 10 *)
lemma "(Q-->R) --> (R-->P&Q) --> (P-->(Q|R)) --> (P=Q)"
  by iprover

(* 11.  Proved in each direction (incorrectly, says Pelletier!!) *)
lemma "P=P"
  by iprover

(* Problem ~~12.  Dijkstra's law *)
lemma "~~(((P = Q) = R)  =  (P = (Q = R)))"
  by iprover

lemma "((P = Q) = R)  -->  ~~(P = (Q = R))"
  by iprover

(* Problem 13.  Distributive law *)
lemma "(P | (Q & R))  = ((P | Q) & (P | R))"
  by iprover

(* Problem ~~14 *)
lemma "~~((P = Q) = ((Q | ~P) & (~Q|P)))"
  by iprover

(* Problem ~~15 *)
lemma "~~((P --> Q) = (~P | Q))"
  by iprover

(* Problem ~~16 *)
lemma "~~((P-->Q) | (Q-->P))"
by iprover

(* Problem ~~17 *)
lemma "~~(((P & (Q-->R))-->S) = ((~P | Q | S) & (~P | ~R | S)))"
  oops

(*Dijkstra's "Golden Rule"*)
lemma "(P&Q) = (P = (Q = (P|Q)))"
  by iprover

(****Examples with quantifiers****)

(* The converse is classical in the following implications... *)

lemma "(\<exists>x. P(x)\<longrightarrow>Q)  \<longrightarrow>  (\<forall>x. P(x)) \<longrightarrow> Q"
  by iprover

lemma "((\<forall>x. P(x))\<longrightarrow>Q) \<longrightarrow> \<not> (\<forall>x. P(x) \<and> \<not>Q)"
  by iprover

lemma "((\<forall>x. \<not>P(x))\<longrightarrow>Q)  \<longrightarrow>  \<not> (\<forall>x. \<not> (P(x)\<or>Q))"
  by iprover

lemma "(\<forall>x. P(x)) \<or> Q  \<longrightarrow>  (\<forall>x. P(x) \<or> Q)"
  by iprover

lemma "(\<exists>x. P \<longrightarrow> Q(x)) \<longrightarrow> (P \<longrightarrow> (\<exists>x. Q(x)))"
  by iprover

(* Hard examples with quantifiers *)

(*The ones that have not been proved are not known to be valid!
  Some will require quantifier duplication -- not currently available*)

(* Problem ~~19 *)
lemma "\<not>\<not>(\<exists>x. \<forall>y z. (P(y)\<longrightarrow>Q(z)) \<longrightarrow> (P(x)\<longrightarrow>Q(x)))"
  by iprover

(* Problem 20 *)
lemma "(\<forall>x y. \<exists>z. \<forall>w. (P(x)\<and>Q(y)\<longrightarrow>R(z)\<and>S(w)))
    \<longrightarrow> (\<exists>x y. P(x) \<and> Q(y)) \<longrightarrow> (\<exists>z. R(z))"
  by iprover

(* Problem 21 *)
lemma "(\<exists>x. P\<longrightarrow>Q(x)) \<and> (\<exists>x. Q(x)\<longrightarrow>P) \<longrightarrow> \<not>\<not>(\<exists>x. P=Q(x))"
  by iprover

(* Problem 22 *)
lemma "(\<forall>x. P = Q(x))  \<longrightarrow>  (P = (\<forall>x. Q(x)))"
  by iprover

(* Problem ~~23 *)
lemma "\<not>\<not> ((\<forall>x. P \<or> Q(x))  =  (P \<or> (\<forall>x. Q(x))))"
  by iprover

(* Problem 25 *)
lemma "(\<exists>x. P(x)) \<and>
       (\<forall>x. L(x) \<longrightarrow> \<not> (M(x) \<and> R(x))) \<and>
       (\<forall>x. P(x) \<longrightarrow> (M(x) \<and> L(x))) \<and>
       ((\<forall>x. P(x)\<longrightarrow>Q(x)) \<or> (\<exists>x. P(x)\<and>R(x)))
   \<longrightarrow> (\<exists>x. Q(x)\<and>P(x))"
  by iprover

(* Problem 27 *)
lemma "(\<exists>x. P(x) \<and> \<not>Q(x)) \<and>
             (\<forall>x. P(x) \<longrightarrow> R(x)) \<and>
             (\<forall>x. M(x) \<and> L(x) \<longrightarrow> P(x)) \<and>
             ((\<exists>x. R(x) \<and> \<not> Q(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> \<not> R(x)))
         \<longrightarrow> (\<forall>x. M(x) \<longrightarrow> \<not>L(x))"
  by iprover

(* Problem ~~28.  AMENDED *)
lemma "(\<forall>x. P(x) \<longrightarrow> (\<forall>x. Q(x))) \<and>
       (\<not>\<not>(\<forall>x. Q(x)\<or>R(x)) \<longrightarrow> (\<exists>x. Q(x)&S(x))) \<and>
       (\<not>\<not>(\<exists>x. S(x)) \<longrightarrow> (\<forall>x. L(x) \<longrightarrow> M(x)))
   \<longrightarrow> (\<forall>x. P(x) \<and> L(x) \<longrightarrow> M(x))"
  by iprover

(* Problem 29.  Essentially the same as Principia Mathematica *11.71 *)
lemma "(((\<exists>x. P(x)) \<and> (\<exists>y. Q(y))) \<longrightarrow>
   (((\<forall>x. (P(x) \<longrightarrow> R(x))) \<and> (\<forall>y. (Q(y) \<longrightarrow> S(y)))) =
    (\<forall>x y. ((P(x) \<and> Q(y)) \<longrightarrow> (R(x) \<and> S(y))))))"
  by iprover

(* Problem ~~30 *)
lemma "(\<forall>x. (P(x) \<or> Q(x)) \<longrightarrow> \<not> R(x)) \<and>
       (\<forall>x. (Q(x) \<longrightarrow> \<not> S(x)) \<longrightarrow> P(x) \<and> R(x))
   \<longrightarrow> (\<forall>x. \<not>\<not>S(x))"
  by iprover

(* Problem 31 *)
lemma "\<not>(\<exists>x. P(x) \<and> (Q(x) \<or> R(x))) \<and>
        (\<exists>x. L(x) \<and> P(x)) \<and>
        (\<forall>x. \<not> R(x) \<longrightarrow> M(x))
    \<longrightarrow> (\<exists>x. L(x) \<and> M(x))"
  by iprover

(* Problem 32 *)
lemma "(\<forall>x. P(x) \<and> (Q(x)|R(x))\<longrightarrow>S(x)) \<and>
       (\<forall>x. S(x) \<and> R(x) \<longrightarrow> L(x)) \<and>
       (\<forall>x. M(x) \<longrightarrow> R(x))
   \<longrightarrow> (\<forall>x. P(x) \<and> M(x) \<longrightarrow> L(x))"
  by iprover

(* Problem ~~33 *)
lemma "(\<forall>x. \<not>\<not>(P(a) \<and> (P(x)\<longrightarrow>P(b))\<longrightarrow>P(c)))  =
       (\<forall>x. \<not>\<not>((\<not>P(a) \<or> P(x) \<or> P(c)) \<and> (\<not>P(a) \<or> \<not>P(b) \<or> P(c))))"
  oops

(* Problem 36 *)
lemma
     "(\<forall>x. \<exists>y. J x y) \<and>
      (\<forall>x. \<exists>y. G x y) \<and>
      (\<forall>x y. J x y \<or> G x y \<longrightarrow> (\<forall>z. J y z \<or> G y z \<longrightarrow> H x z))
  \<longrightarrow> (\<forall>x. \<exists>y. H x y)"
  by iprover

(* Problem 39 *)
lemma "\<not> (\<exists>x. \<forall>y. F y x = (\<not>F y y))"
  by iprover

(* Problem 40.  AMENDED *)
lemma "(\<exists>y. \<forall>x. F x y = F x x) \<longrightarrow>
             \<not>(\<forall>x. \<exists>y. \<forall>z. F z y = (\<not> F z x))"
  by iprover

(* Problem 44 *)
lemma "(\<forall>x. f(x) \<longrightarrow>
             (\<exists>y. g(y) \<and> h x y \<and> (\<exists>y. g(y) \<and> ~ h x y)))  \<and>
             (\<exists>x. j(x) \<and> (\<forall>y. g(y) \<longrightarrow> h x y))
             \<longrightarrow> (\<exists>x. j(x) \<and> \<not>f(x))"
  by iprover

(* Problem 48 *)
lemma "(a=b \<or> c=d) \<and> (a=c \<or> b=d) \<longrightarrow> a=d \<or> b=c"
  by iprover

(* Problem 51 *)
lemma "((\<exists>z w. (\<forall>x y. (P x y = ((x = z) \<and> (y = w))))) \<longrightarrow>
  (\<exists>z. (\<forall>x. (\<exists>w. ((\<forall>y. (P x y = (y = w))) = (x = z))))))"
  by iprover

(* Problem 52 *)
(*Almost the same as 51. *)
lemma "((\<exists>z w. (\<forall>x y. (P x y = ((x = z) \<and> (y = w))))) \<longrightarrow>
   (\<exists>w. (\<forall>y. (\<exists>z. ((\<forall>x. (P x y = (x = z))) = (y = w))))))"
  by iprover

(* Problem 56 *)
lemma "(\<forall>x. (\<exists>y. P(y) \<and> x=f(y)) \<longrightarrow> P(x)) = (\<forall>x. P(x) \<longrightarrow> P(f(x)))"
  by iprover

(* Problem 57 *)
lemma "P (f a b) (f b c) & P (f b c) (f a c) \<and>
     (\<forall>x y z. P x y \<and> P y z \<longrightarrow> P x z) \<longrightarrow> P (f a b) (f a c)"
  by iprover

(* Problem 60 *)
lemma "\<forall>x. P x (f x) = (\<exists>y. (\<forall>z. P z y \<longrightarrow> P z (f x)) \<and> P x y)"
  by iprover

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Lattice\<close>
theory Binary_Relations_Lattice
  imports
    Binary_Relations_Order_Base
    HOL.Boolean_Algebras
begin

paragraph \<open>Summary\<close>
text \<open>Basic results about the lattice structure on binary relations.\<close>

lemma rel_infI [intro]:
  assumes "R x y"
  and "S x y"
  shows "(R \<sqinter> S) x y"
  using assms by (rule inf2I)

lemma rel_infE [elim]:
  assumes "(R \<sqinter> S) x y"
  obtains "R x y" "S x y"
  using assms by (rule inf2E)

lemma rel_infD:
  assumes "(R \<sqinter> S) x y"
  shows "R x y" and "S x y"
  using assms by auto

lemma in_dom_rel_infI [intro]:
  assumes "R x y"
  and "S x y"
  shows "in_dom (R \<sqinter> S) x"
  using assms by blast

lemma in_dom_rel_infE [elim]:
  assumes "in_dom (R \<sqinter> S) x"
  obtains y where "R x y" "S x y"
  using assms by blast

lemma in_codom_rel_infI [intro]:
  assumes "R x y"
  and "S x y"
  shows "in_codom (R \<sqinter> S) y"
  using assms by blast

lemma in_codom_rel_infE [elim]:
  assumes "in_codom (R \<sqinter> S) y"
  obtains x where "R x y" "S x y"
  using assms by blast

lemma in_field_eq_in_dom_sup_in_codom: "in_field L = (in_dom L \<squnion> in_codom L)"
  by (intro ext) (simp add: in_field_iff_in_dom_or_in_codom)

lemma in_dom_restrict_left_eq [simp]: "in_dom R\<restriction>\<^bsub>P\<^esub> = (in_dom R \<sqinter> P)"
  by (intro ext) auto

lemma in_codom_restrict_left_eq [simp]: "in_codom R\<upharpoonleft>\<^bsub>P\<^esub> = (in_codom R \<sqinter> P)"
  by (intro ext) auto

lemma restrict_left_restrict_left_eq [simp]:
  fixes R :: "'a \<Rightarrow> _" and P Q :: "'a \<Rightarrow> bool"
  shows "R\<restriction>\<^bsub>P\<^esub>\<restriction>\<^bsub>Q\<^esub> = R\<restriction>\<^bsub>P\<^esub> \<sqinter> R\<restriction>\<^bsub>Q\<^esub>"
  by (intro ext iffI restrict_leftI) auto

lemma restrict_left_restrict_right_eq [simp]:
  fixes R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and P :: "'a \<Rightarrow> bool" and Q :: "'b \<Rightarrow> bool"
  shows "R\<restriction>\<^bsub>P\<^esub>\<upharpoonleft>\<^bsub>Q\<^esub> = R\<restriction>\<^bsub>P\<^esub> \<sqinter> R\<upharpoonleft>\<^bsub>Q\<^esub>"
  by (intro ext iffI restrict_leftI restrict_rightI) auto

lemma restrict_right_restrict_left_eq [simp]:
  fixes R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and P :: "'b \<Rightarrow> bool" and Q :: "'a \<Rightarrow> bool"
  shows "R\<upharpoonleft>\<^bsub>P\<^esub>\<restriction>\<^bsub>Q\<^esub> = R\<upharpoonleft>\<^bsub>P\<^esub> \<sqinter> R\<restriction>\<^bsub>Q\<^esub>"
  by (intro ext iffI restrict_leftI restrict_rightI) auto

lemma restrict_right_restrict_right_eq [simp]:
  fixes R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and P Q :: "'b \<Rightarrow> bool"
  shows "R\<upharpoonleft>\<^bsub>P\<^esub>\<upharpoonleft>\<^bsub>Q\<^esub> = R\<upharpoonleft>\<^bsub>P\<^esub> \<sqinter> R\<upharpoonleft>\<^bsub>Q\<^esub>"
  by (intro ext iffI) auto

lemma restrict_left_sup_eq [simp]: "(R :: 'a \<Rightarrow> _)\<restriction>\<^bsub>((P :: 'a \<Rightarrow> bool) \<squnion> Q)\<^esub> = R\<restriction>\<^bsub>P\<^esub> \<squnion> R\<restriction>\<^bsub>Q\<^esub> "
  by (intro antisym le_relI) (auto elim!: restrict_leftE)

lemma restrict_left_inf_eq [simp]: "(R :: 'a \<Rightarrow> _)\<restriction>\<^bsub>((P :: 'a \<Rightarrow> bool) \<sqinter> Q)\<^esub> = R\<restriction>\<^bsub>P\<^esub> \<sqinter> R\<restriction>\<^bsub>Q\<^esub> "
  by (intro antisym le_relI) (auto elim!: restrict_leftE)

lemma inf_rel_bimap_and_eq_restrict_left_restrict_right:
  "R \<sqinter> (rel_bimap P Q (\<and>)) = R\<restriction>\<^bsub>P\<^esub>\<upharpoonleft>\<^bsub>Q\<^esub>"
  by (intro ext) auto

end