(* Authors: Dongchen Jiang and Tobias Nipkow *)

theory Marriage
imports Main
begin

theorem marriage_necessary:
  fixes A :: "'a \<Rightarrow> 'b set" and I :: "'a set"
  assumes "finite I" and "\<forall> i\<in>I. finite (A i)"
  and "\<exists>R. (\<forall>i\<in>I. R i \<in> A i) \<and> inj_on R I" (is "\<exists>R. ?R R A & ?inj R A")
  shows "\<forall>J\<subseteq>I. card J \<le> card (UNION J A)"
proof clarify
  fix J
  assume "J \<subseteq> I"
  show "card J \<le> card (UNION J A)"
  proof-
    from assms(3) obtain R where "?R R A" and "?inj R A" by auto
    have "inj_on R J" by(rule subset_inj_on[OF `?inj R A` `J\<subseteq>I`])
    moreover have "(R ` J) \<subseteq> (UNION J A)" using `J\<subseteq>I` `?R R A` by auto
    moreover have "finite (UNION J A)" using `J\<subseteq>I` assms
      by (metis finite_UN_I finite_subset set_mp)
    ultimately show ?thesis by (rule card_inj_on_le)
  qed
qed

text{* The proof by Halmos and Vaughan: *}
theorem marriage_HV:
  fixes A :: "'a \<Rightarrow> 'b set" and I :: "'a set"
  assumes "finite I" and "\<forall> i\<in>I. finite (A i)"
  and "\<forall>J\<subseteq>I. card J \<le> card (UNION J A)" (is "?M A I")
  shows "\<exists>R. (\<forall>i\<in>I. R i \<in> A i) \<and> inj_on R I"
       (is "?SDR A I" is "\<exists>R. ?R R A I & ?inj R A I")
proof-
  { fix I
    have "finite I \<Longrightarrow> \<forall>i\<in>I. finite (A i) \<Longrightarrow> ?M A I \<Longrightarrow> ?SDR A I"
    proof(induct arbitrary: A rule: finite_psubset_induct)
      case (psubset I)
      show ?case
      proof (cases)
        assume "I={}" then show ?thesis by simp
      next
        assume "I \<noteq> {}"
        have "\<forall>i\<in>I. A i \<noteq> {}"
        proof (rule ccontr)
          assume  "\<not> (\<forall>i\<in>I. A i\<noteq>{})"
          then obtain i where "i\<in>I" "A i = {}" by blast
          hence "{i}\<subseteq> I" by auto
          from mp[OF spec[OF psubset.prems(2)] this] `A i={}`
          show False by simp
        qed
        show ?thesis
        proof cases
          assume case1: "\<forall>K\<subset>I. K\<noteq>{} \<longrightarrow> card (UNION K A) \<ge> card K + 1"
          show ?thesis
          proof-
            from `I\<noteq>{}` obtain n where "n\<in>I" by auto
            with `\<forall>i\<in>I. A i \<noteq> {}` have "A n \<noteq> {}" by auto
            then obtain x where "x \<in> A n" by auto
            let ?A' = "\<lambda>i. A i - {x}" let ?I' = "I - {n}"
            from `n\<in>I` have "?I' \<subset> I"
              by (metis DiffD2 Diff_subset insertI1 psubset_eq)
            have fin': "\<forall>i\<in>?I'. finite (?A' i)" using psubset.prems(1) by auto
            have "?M ?A' ?I'"
            proof clarify
              fix J
              assume "J \<subseteq> ?I'"
              hence "J \<subset> I" by (metis `I - {n} \<subset> I` subset_psubset_trans)
              show "card J \<le> card (UNION J ?A')"
              proof cases
                assume "J = {}" thus ?thesis by auto
              next
                assume "J \<noteq> {}"
                hence "card J + 1 \<le> card(UNION J A)" using case1 `J\<subset>I` by blast
                moreover
                have "card(UNION J A) - 1 \<le> card(UNION J ?A')" (is "?l \<le> ?r")
                proof-
                  have "finite J" using `J \<subset> I` psubset(1)
                    by (metis psubset_imp_subset finite_subset)
                  hence 1: "finite(UNION J A)"
                    using `\<forall>i\<in>I. finite(A i)` `J\<subset>I` by force
                  have "?l = card(UNION J A) - card{x}" by simp
                  also have "\<dots> \<le> card(UNION J A - {x})" using 1
                    by (metis diff_card_le_card_Diff finite.intros)
                  also have "UNION J A - {x} = UNION J ?A'" by blast
                  finally show ?thesis .
                qed
                ultimately show ?thesis by arith
              qed
            qed
            from psubset(2)[OF `?I'\<subset>I` fin' `?M ?A' ?I'`]
            obtain R' where "?R R' ?A' ?I'" "?inj R' ?A' ?I'" by auto
            let ?Rx = "R'(n := x)"
            have "?R ?Rx A I" using `x\<in>A n` `?R R' ?A' ?I'` by force
            have "\<forall>i\<in>?I'. ?Rx i \<noteq> x" using `?R R' ?A' ?I'` by auto
            hence "?inj ?Rx A I" using `?inj R' ?A' ?I'`
              by(auto simp: inj_on_def)
            with `?R ?Rx A I` show ?thesis by auto
          qed
        next
          assume "\<not> (\<forall>K\<subset>I. K\<noteq>{} \<longrightarrow> card (UNION K A) \<ge> card K + 1)"
          then obtain K where
            "K\<subset>I" "K\<noteq>{}" and c1: "\<not>(card (UNION K A) \<ge> card K + 1)" by auto
          with psubset.prems(2) have "card (UNION K A) \<ge> card K" by auto
          with c1 have case2: "card (UNION K A)= card K" by auto
          from `K\<subset>I` `finite I` have "finite K" by (auto intro:finite_subset)
          from psubset.prems `K\<subset>I`
          have "\<forall>i\<in>K. finite (A i)" "\<forall>J\<subseteq>K. card J \<le> card(UNION J A)" by auto
          from psubset(2)[OF `K\<subset>I` this]
          obtain R1 where "?R R1 A K" "?inj R1 A K" by auto
          let ?AK = "\<lambda>i. A i - UNION K A" let ?IK = "I - K"
          from `K\<noteq>{}` `K\<subset>I` have "?IK\<subset>I" by auto
          have "\<forall>i\<in>?IK. finite (?AK i)" using psubset.prems(1) by auto
          have "?M ?AK ?IK"
          proof clarify
            fix J assume "J \<subseteq> ?IK"
            with `finite I` have "finite J" by(auto intro: finite_subset)
            show "card J \<le> card (UNION J ?AK)"
            proof-
              from `J\<subseteq>?IK` have "J \<inter> K = {}" by auto
              have "card J = card(J\<union>K) - card K"
                using `finite J` `finite K` `J\<inter>K={}`
                by (auto simp: card_Un_disjoint)
              also have "card(J\<union>K) \<le> card(UNION (J\<union>K) A)"
              proof -
                from `J\<subseteq>?IK` `K\<subset>I` have "J \<union> K \<subseteq> I" by auto
                with psubset.prems(2) show ?thesis by blast
              qed
              also have "\<dots> - card K = card(UNION J ?AK \<union> UNION K A) - card K"
              proof-
                have "UNION (J\<union>K) A = UNION J ?AK \<union> UNION K A"
                  using `J\<subseteq>?IK` by auto
                thus ?thesis by simp
              qed
              also have "\<dots> = card(UNION J ?AK) + card(UNION K A) - card K"
              proof-
                have "finite (UNION J ?AK)" using `finite J` `J\<subseteq>?IK` psubset(3)
                  by(blast intro: finite_UN_I finite_Diff)
                moreover have "finite (UNION K A)"
                  using `finite K` `\<forall>i\<in>K. finite (A i)` by auto
                moreover have "UNION J ?AK \<inter> UNION K A = {}" by auto
                ultimately show ?thesis
                  by (simp add: card_Un_disjoint del:Un_Diff_cancel2)
              qed
              also have "\<dots> = card(UNION J ?AK)" using case2 by simp
              finally show ?thesis by simp
            qed
          qed
          from psubset(2)[OF `?IK\<subset>I` `\<forall>i\<in>?IK. finite (?AK i)` `\<forall>J\<subseteq>?IK. card J\<le>card(UNION J ?AK)`]
          obtain R2 where "?R R2 ?AK ?IK" "?inj R2 ?AK ?IK" by auto
          let ?R12 = "\<lambda>i. if i\<in>K then R1 i else R2 i"
          have "\<forall>i\<in>I. ?R12 i \<in> A i" using `?R R1 A K``?R R2 ?AK ?IK` by auto
          moreover have "\<forall>i\<in>I. \<forall>j\<in>I. i\<noteq>j\<longrightarrow>?R12 i \<noteq> ?R12 j"
          proof clarify
            fix i j assume "i\<in>I" "j\<in>I" "i\<noteq>j" "?R12 i = ?R12 j"
            show False
            proof-
              { assume "i\<in>K \<and> j\<in>K \<or> i\<notin>K\<and>j\<notin>K"
                with `?inj R1 A K` `?inj R2 ?AK ?IK` `?R12 i=?R12 j` `i\<noteq>j` `i\<in>I` `j\<in>I`
                have ?thesis by (fastforce simp: inj_on_def)
              } moreover
              { assume "i\<in>K \<and> j\<notin>K \<or> i\<notin>K \<and> j\<in>K"
                with `?R R1 A K` `?R R2 ?AK ?IK` `?R12 i=?R12 j` `j\<in>I` `i\<in>I`
                have ?thesis by auto (metis Diff_iff)
              } ultimately show ?thesis by blast
            qed
          qed
          ultimately show ?thesis unfolding inj_on_def by fast
        qed
      qed
    qed
  }
  with assms `?M A I` show ?thesis by auto
qed

text{* The proof by Rado: *}
theorem marriage_Rado:
  fixes A :: "'a \<Rightarrow> 'b set" and I :: "'a set"
  assumes "finite I" and "\<forall> i\<in>I. finite (A i)"
  and "\<forall>J\<subseteq>I. card J \<le> card (UNION J A)" (is "?M A")
  shows "\<exists>R. (\<forall>i\<in>I. R i \<in> A i) \<and> inj_on R I"
       (is "?SDR A" is "\<exists>R. ?R R A & ?inj R A")
proof-
  { have "\<forall>i\<in>I. finite (A i) \<Longrightarrow> ?M A \<Longrightarrow> ?SDR A"
    proof(induct n == "\<Sum>i\<in>I. card(A i) - 1" arbitrary: A)
      case 0
      have "\<forall>i\<in>I.\<exists>a. A(i) = {a}"
      proof (rule ccontr)
        assume  "\<not> (\<forall>i\<in>I.\<exists>a. A i = {a})"
        then obtain i where i: "i:I" "\<forall>a. A i \<noteq> {a}" by blast
        hence "{i}\<subseteq> I" by auto
        from "0"(1-2) mp[OF spec[OF "0.prems"(2)] `{i}\<subseteq>I`] `finite I` i
        show False by (auto simp: card_le_Suc_iff)
      qed
      then obtain R where R: "\<forall>i\<in>I. A i = {R i}" by metis
      then have "\<forall>i\<in>I. R i \<in> A i" by blast
      moreover have "inj_on R I"
      proof (auto simp: inj_on_def)
        fix x y assume "x \<in> I" "y \<in> I" "R x = R y"
        with R spec[OF "0.prems"(2), of "{x,y}"] show "x=y"
          by (simp add:le_Suc_eq card_insert_if split: if_splits)
      qed
      ultimately show ?case by blast
    next
      case (Suc n)
      from Suc.hyps(2)[symmetric, THEN setsum_SucD]
      obtain i where i: "i:I" "2 \<le> card(A i)" by auto
      then obtain x1 x2 where "x1 : A i" "x2 : A i" "x1 \<noteq> x2"
        using Suc(3) by (fastforce simp: card_le_Suc_iff eval_nat_numeral)
      let "?Ai x" = "A i - {x}" let "?A x" = "A(i:=?Ai x)"
      let "?U J" = "UNION J A" let "?Ui J x" = "?U J \<union> ?Ai x"
      have n1: "n = (\<Sum>j\<in>I. card (?A x1 j) - 1)"
        using Suc.hyps(2) Suc.prems(1) i `finite I` `x1:A i`
        by (auto simp: setsum.remove card_Diff_singleton)
      have n2: "n = (\<Sum>j\<in>I. card (?A x2 j) - 1)"
        using Suc.hyps(2) Suc.prems(1) i `finite I` `x2:A i`
        by (auto simp: setsum.remove card_Diff_singleton)
      have finx1: "\<forall>j\<in>I. finite (?A x1 j)" by (simp add: Suc(3))
      have finx2: "\<forall>j\<in>I. finite (?A x2 j)" by (simp add: Suc(3))
      { fix x assume "\<not> ?M (A(i:= ?Ai x))"
        with Suc.prems(2) obtain J
          where J: "J \<subseteq> I" "card J > card(UNION J (A(i:= ?Ai x)))"
          by (auto simp add:not_less_eq_eq Suc_le_eq)
        note fJi = finite_Diff[OF finite_subset[OF `J\<subseteq>I` `finite I`], of "{i}"]
        have fU: "finite(?U (J-{i}))" using `J\<subseteq>I`
          by (metis Diff_iff Suc(3) finite_UN[OF fJi] subsetD)
        have "i \<in> J" using J Suc.prems(2)
          by (simp_all add: UNION_fun_upd not_le[symmetric] del: fun_upd_apply split: if_splits)
        hence "card(J-{i}) \<ge> card(?Ui (J-{i}) x)"
          using fJi J by(simp add: UNION_fun_upd del: fun_upd_apply)
        hence "\<exists>J\<subseteq>I. i \<notin> J \<and> card(J) \<ge> card(?Ui J x) \<and> finite(?U J)"
          by (metis DiffD2 J(1) fU `i \<in> J` insertI1 subset_insertI2 subset_insert_iff)
      } note lem = this
      have "?M (?A x1) \<or> ?M (?A x2)" -- "Rado's Lemma"
      proof(rule ccontr)
        assume "\<not> (?M (?A x1) \<or> ?M (?A x2))"
        with lem obtain J1 J2 where
          J1: "J1\<subseteq>I" "i\<notin>J1" "card J1 \<ge> card(?Ui J1 x1)" "finite(?U J1)" and
          J2: "J2\<subseteq>I" "i\<notin>J2" "card J2 \<ge> card(?Ui J2 x2)" "finite(?U J2)"
          by metis
        note fin1 = finite_subset[OF `J1\<subseteq>I` assms(1)]
        note fin2 = finite_subset[OF `J2\<subseteq>I` assms(1)]
        have finUi1: "finite(?Ui J1 x1)" using Suc(3) by(blast intro: J1(4) i(1))
        have finUi2: "finite(?Ui J2 x2)" using Suc(3) by(blast intro: J2(4) i(1))
        have "card J1 + card J2 + 1 = card(J1 \<union> J2) + 1 + card(J1 \<inter> J2)"
          by simp (metis card_Un_Int fin1 fin2)
        also have "card(J1 \<union> J2) + 1 = card(insert i (J1 \<union> J2))"
          using `i\<notin>J1` `i\<notin>J2` fin1 fin2 by simp
        also have "\<dots> \<le> card(UNION (insert i (J1 \<union> J2)) A)" (is "_ \<le> card ?M")
          by (metis J1(1) J2(1) Suc(4) Un_least i(1) insert_subset)
        also have "?M = ?Ui J1 x1 \<union> ?Ui J2 x2" using `x1\<noteq>x2` by auto
        also have "card(J1 \<inter> J2) \<le> card(UNION (J1 \<inter> J2) A)"
          by (metis J2(1) Suc(4) le_infI2)
        also have "\<dots> \<le> card(?U J1 \<inter> ?U J2)" by(blast intro: card_mono J1(4))
        also have "\<dots> \<le> card(?Ui J1 x1 \<inter> ?Ui J2 x2)"
          using Suc(3) `i\<in>I` by(blast intro: card_mono J1(4))
        finally show False using J1(3) J2(3)
          by(auto simp add: card_Un_Int[symmetric, OF finUi1 finUi2])
      qed
      thus ?case using Suc.hyps(1)[OF n1 finx1] Suc.hyps(1)[OF n2 finx2]
        by (metis DiffD1 fun_upd_def)
    qed
  } with assms `?M A` show ?thesis by auto
qed

end


section \<open> UTP Theories \<close>

theory utp_theory
imports utp_rel_laws
begin

text \<open> Here, we mechanise a representation of UTP theories using locales~\cite{Ballarin06}. We also
  link them to the HOL-Algebra library~\cite{Ballarin17}, which allows us to import properties from
  complete lattices and Galois connections. \<close>

subsection \<open> Complete lattice of predicates \<close>

definition upred_lattice :: "('\<alpha> upred) gorder" ("\<P>") where
"upred_lattice = \<lparr> carrier = UNIV, eq = (=), le = (\<sqsubseteq>) \<rparr>"

text \<open> @{term "\<P>"} is the complete lattice of alphabetised predicates. All other theories will
  be defined relative to it. \<close>

interpretation upred_lattice: complete_lattice \<P>
proof (unfold_locales, simp_all add: upred_lattice_def)
  fix A :: "'\<alpha> upred set"
  show "\<exists>s. is_lub \<lparr>carrier = UNIV, eq = (=), le = (\<sqsubseteq>)\<rparr> s A"
    apply (rule_tac x="\<Squnion> A" in exI)
    apply (rule least_UpperI)
       apply (auto intro: Inf_greatest simp add: Inf_lower Upper_def)
    done
  show "\<exists>i. is_glb \<lparr>carrier = UNIV, eq = (=), le = (\<sqsubseteq>)\<rparr> i A"
    apply (rule_tac x="\<Sqinter> A" in exI)
    apply (rule greatest_LowerI)
       apply (auto intro: Sup_least simp add: Sup_upper Lower_def)
    done
qed

lemma upred_weak_complete_lattice [simp]: "weak_complete_lattice \<P>"
  by (simp add: upred_lattice.weak.weak_complete_lattice_axioms)

lemma upred_lattice_eq [simp]:
  "(.=\<^bsub>\<P>\<^esub>) = (=)"
  by (simp add: upred_lattice_def)

lemma upred_lattice_le [simp]:
  "le \<P> P Q = (P \<sqsubseteq> Q)"
  by (simp add: upred_lattice_def)

lemma upred_lattice_carrier [simp]:
  "carrier \<P> = UNIV"
  by (simp add: upred_lattice_def)

lemma upred_lattice_Monotonic [simp]: "Mono\<^bsub>\<P>\<^esub> H = Monotonic H"
  using upred_lattice.weak_partial_order_axioms by (auto simp add: isotone_def mono_def)

subsection \<open> UTP theories hierarchy \<close>

definition utp_order :: "('\<alpha> \<times> '\<alpha>) health \<Rightarrow> '\<alpha> hrel gorder" where
"utp_order H = \<lparr> carrier = {P. P is H}, eq = (=), le = (\<sqsubseteq>) \<rparr>"

text \<open> Constant @{term utp_order} obtains the order structure associated with a UTP theory.
  Its carrier is the set of healthy predicates, equality is HOL equality, and the order is
  refinement. \<close>

lemma utp_order_carrier [simp]:
  "carrier (utp_order H) = \<lbrakk>H\<rbrakk>\<^sub>H"
  by (simp add: utp_order_def)

lemma utp_order_eq [simp]:
  "eq (utp_order T) = (=)"
  by (simp add: utp_order_def)

lemma utp_order_le [simp]:
  "le (utp_order T) = (\<sqsubseteq>)"
  by (simp add: utp_order_def)

lemma utp_partial_order: "partial_order (utp_order T)"
  by (unfold_locales, simp_all add: utp_order_def)

lemma utp_weak_partial_order: "weak_partial_order (utp_order T)"
  by (unfold_locales, simp_all add: utp_order_def)

lemma mono_Monotone_utp_order:
  "mono f \<Longrightarrow> Monotone (utp_order T) f"
  apply (auto simp add: isotone_def)
   apply (metis partial_order_def utp_partial_order)
  apply (metis monoD)
  done

lemma isotone_utp_orderI: "Monotonic H \<Longrightarrow> isotone (utp_order X) (utp_order Y) H"
  by (auto simp add: mono_def isotone_def utp_weak_partial_order)

lemma Mono_utp_orderI:
  "\<lbrakk> \<And> P Q. \<lbrakk> P \<sqsubseteq> Q; P is H; Q is H \<rbrakk> \<Longrightarrow> F(P) \<sqsubseteq> F(Q) \<rbrakk> \<Longrightarrow> Mono\<^bsub>utp_order H\<^esub> F"
  by (auto simp add: isotone_def utp_weak_partial_order)

text \<open> The UTP order can equivalently be characterised as the fixed point lattice, @{const fpl}. \<close>

lemma utp_order_fpl: "utp_order H = fpl \<P> H"
  by (auto simp add: utp_order_def upred_lattice_def fps_def Healthy_def)

subsection \<open> UTP theory hierarchy \<close>

text \<open> We next define a hierarchy of locales that characterise different classes of UTP theory.
  Minimally we require that a UTP theory's healthiness condition is idempotent. \<close>

locale utp_theory =
  fixes hcond :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("\<H>")
  assumes HCond_Idem: "\<H>(\<H>(P)) = \<H>(P)"
begin

  abbreviation thy_order :: "'\<alpha> hrel gorder" where
  "thy_order \<equiv> utp_order \<H>"

  lemma HCond_Idempotent [closure,intro]: "Idempotent \<H>"
    by (simp add: Idempotent_def HCond_Idem)

  sublocale utp_po: partial_order "utp_order \<H>"
    by (unfold_locales, simp_all add: utp_order_def)

  text \<open> We need to remove some transitivity rules to stop them being applied in calculations \<close>

  declare utp_po.trans [trans del]

end

locale utp_theory_lattice = utp_theory +
  assumes uthy_lattice: "complete_lattice (utp_order \<H>)"
begin

sublocale complete_lattice "utp_order \<H>"
  by (simp add: uthy_lattice)

declare top_closed [simp del]
declare bottom_closed [simp del]

text \<open> The healthiness conditions of a UTP theory lattice form a complete lattice, and allows us to make
  use of complete lattice results from HOL-Algebra~\cite{Ballarin17}, such as the Knaster-Tarski theorem. We can also
  retrieve lattice operators as below. \<close>

abbreviation utp_top ("\<^bold>\<top>")
where "utp_top \<equiv> top (utp_order \<H>)"

abbreviation utp_bottom ("\<^bold>\<bottom>")
where "utp_bottom \<equiv> bottom (utp_order \<H>)"

abbreviation utp_join (infixl "\<^bold>\<squnion>" 65) where
"utp_join \<equiv> join (utp_order \<H>)"

abbreviation utp_meet (infixl "\<^bold>\<sqinter>" 70) where
"utp_meet \<equiv> meet (utp_order \<H>)"

abbreviation utp_sup ("\<^bold>\<Squnion>_" [90] 90) where
"utp_sup \<equiv> Lattice.sup (utp_order \<H>)"

abbreviation utp_inf ("\<^bold>\<Sqinter>_" [90] 90) where
"utp_inf \<equiv> Lattice.inf (utp_order \<H>)"

abbreviation utp_gfp ("\<^bold>\<nu>") where
"utp_gfp \<equiv> GREATEST_FP (utp_order \<H>)"

abbreviation utp_lfp ("\<^bold>\<mu>") where
"utp_lfp \<equiv> LEAST_FP (utp_order \<H>)"

end

syntax
  "_tmu" :: "logic \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<mu>\<index> _ \<bullet> _" [0, 10] 10)
  "_tnu" :: "logic \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<nu>\<index> _ \<bullet> _" [0, 10] 10)

notation gfp ("\<mu>")
notation lfp ("\<nu>")

translations
  "\<^bold>\<mu>\<^bsub>H\<^esub> X \<bullet> P" == "CONST LEAST_FP (CONST utp_order H) (\<lambda> X. P)"
  "\<^bold>\<nu>\<^bsub>H\<^esub> X \<bullet> P" == "CONST GREATEST_FP (CONST utp_order H) (\<lambda> X. P)"

lemma upred_lattice_inf:
  "Lattice.inf \<P> A = \<Sqinter> A"
  by (metis Sup_least Sup_upper UNIV_I antisym_conv subsetI upred_lattice.weak.inf_greatest upred_lattice.weak.inf_lower upred_lattice_carrier upred_lattice_le)

text \<open> We can then derive a number of properties about these operators, as below. \<close>

context utp_theory_lattice
begin

  lemma LFP_healthy_comp: "\<^bold>\<mu> F = \<^bold>\<mu> (F \<circ> \<H>)"
  proof -
    have "{P. (P is \<H>) \<and> F P \<sqsubseteq> P} = {P. (P is \<H>) \<and> F (\<H> P) \<sqsubseteq> P}"
      by (auto simp add: Healthy_def)
    thus ?thesis
      by (simp add: LEAST_FP_def)
  qed

  lemma GFP_healthy_comp: "\<^bold>\<nu> F = \<^bold>\<nu> (F \<circ> \<H>)"
  proof -
    have "{P. (P is \<H>) \<and> P \<sqsubseteq> F P} = {P. (P is \<H>) \<and> P \<sqsubseteq> F (\<H> P)}"
      by (auto simp add: Healthy_def)
    thus ?thesis
      by (simp add: GREATEST_FP_def)
  qed

  lemma top_healthy [closure]: "\<^bold>\<top> is \<H>"
    using weak.top_closed by auto

  lemma bottom_healthy [closure]: "\<^bold>\<bottom> is \<H>"
    using weak.bottom_closed by auto

  lemma utp_top: "P is \<H> \<Longrightarrow> P \<sqsubseteq> \<^bold>\<top>"
    using weak.top_higher by auto

  lemma utp_bottom: "P is \<H> \<Longrightarrow> \<^bold>\<bottom> \<sqsubseteq> P"
    using weak.bottom_lower by auto

end

lemma upred_top: "\<top>\<^bsub>\<P>\<^esub> = false"
  using ball_UNIV greatest_def by fastforce

lemma upred_bottom: "\<bottom>\<^bsub>\<P>\<^esub> = true"
  by fastforce

text \<open> One way of obtaining a complete lattice is showing that the healthiness conditions
  are monotone, which the below locale characterises. \<close>

locale utp_theory_mono = utp_theory +
  assumes HCond_Mono [closure,intro]: "Monotonic \<H>"

sublocale utp_theory_mono \<subseteq> utp_theory_lattice
proof -
  interpret weak_complete_lattice "fpl \<P> \<H>"
    by (rule Knaster_Tarski, auto)

  have "complete_lattice (fpl \<P> \<H>)"
    by (unfold_locales, simp add: fps_def sup_exists, (blast intro: sup_exists inf_exists)+)

  hence "complete_lattice (utp_order \<H>)"
    by (simp add: utp_order_def, simp add: upred_lattice_def)

  thus "utp_theory_lattice \<H>"
    by (simp add: utp_theory_axioms utp_theory_lattice.intro utp_theory_lattice_axioms.intro)
qed

text \<open> In a monotone theory, the top and bottom can always be obtained by applying the healthiness
  condition to the predicate top and bottom, respectively. \<close>

context utp_theory_mono
begin

lemma healthy_top: "\<^bold>\<top> = \<H>(false)"
proof -
  have "\<^bold>\<top> = \<top>\<^bsub>fpl \<P> \<H>\<^esub>"
    by (simp add: utp_order_fpl)
  also have "... = \<H> \<top>\<^bsub>\<P>\<^esub>"
    using Knaster_Tarski_idem_extremes(1)[of \<P> \<H>]
    by (simp add: HCond_Idempotent HCond_Mono)
  also have "... = \<H> false"
    by (simp add: upred_top)
  finally show ?thesis .
qed

lemma healthy_bottom: "\<^bold>\<bottom> = \<H>(true)"
proof -
  have "\<^bold>\<bottom> = \<bottom>\<^bsub>fpl \<P> \<H>\<^esub>"
    by (simp add: utp_order_fpl)
  also have "... = \<H> \<bottom>\<^bsub>\<P>\<^esub>"
    using Knaster_Tarski_idem_extremes(2)[of \<P> \<H>]
    by (simp add: HCond_Idempotent HCond_Mono)
  also have "... = \<H> true"
    by (simp add: upred_bottom)
   finally show ?thesis .
qed

lemma healthy_inf:
  assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
  shows "\<^bold>\<Sqinter> A = \<H> (\<Sqinter> A)"
  using Knaster_Tarski_idem_inf_eq[OF upred_weak_complete_lattice, of "\<H>"]
  by (simp, metis HCond_Idempotent HCond_Mono assms partial_object.simps(3) upred_lattice_def upred_lattice_inf utp_order_def)

end

locale utp_theory_continuous = utp_theory +
  assumes HCond_Cont [closure,intro]: "Continuous \<H>"

sublocale utp_theory_continuous \<subseteq> utp_theory_mono
proof
  show "Monotonic \<H>"
    by (simp add: Continuous_Monotonic HCond_Cont)
qed

context utp_theory_continuous
begin

  lemma healthy_inf_cont:
    assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "\<^bold>\<Sqinter> A = \<Sqinter> A"
  proof -
    have "\<^bold>\<Sqinter> A = \<Sqinter> (\<H>`A)"
      using Continuous_def HCond_Cont assms(1) assms(2) healthy_inf by auto
    also have "... = \<Sqinter> A"
      by (unfold Healthy_carrier_image[OF assms(1)], simp)
    finally show ?thesis .
  qed

  lemma healthy_inf_def:
    assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
    shows "\<^bold>\<Sqinter> A = (if (A = {}) then \<^bold>\<top> else (\<Sqinter> A))"
    using assms healthy_inf_cont weak.weak_inf_empty by auto

  lemma healthy_meet_cont:
    assumes "P is \<H>" "Q is \<H>"
    shows "P \<^bold>\<sqinter> Q = P \<sqinter> Q"
    using healthy_inf_cont[of "{P, Q}"] assms
    by (simp add: Healthy_if meet_def)

  lemma meet_is_healthy [closure]:
    assumes "P is \<H>" "Q is \<H>"
    shows "P \<sqinter> Q is \<H>"
    by (metis Continuous_Disjunctous Disjunctuous_def HCond_Cont Healthy_def' assms(1) assms(2))

  lemma meet_bottom [simp]:
    assumes "P is \<H>"
    shows "P \<sqinter> \<^bold>\<bottom> = \<^bold>\<bottom>"
      by (simp add: assms semilattice_sup_class.sup_absorb2 utp_bottom)

  lemma meet_top [simp]:
    assumes "P is \<H>"
    shows "P \<sqinter> \<^bold>\<top> = P"
      by (simp add: assms semilattice_sup_class.sup_absorb1 utp_top)

  text \<open> The UTP theory lfp operator can be rewritten to the alphabetised predicate lfp when
    in a continuous context. \<close>

  theorem utp_lfp_def:
    assumes "Monotonic F" "F \<in> \<lbrakk>\<H>\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
    shows "\<^bold>\<mu> F = (\<mu> X \<bullet> F(\<H>(X)))"
  proof (rule antisym)
    have ne: "{P. (P is \<H>) \<and> F P \<sqsubseteq> P} \<noteq> {}"
    proof -
      have "F \<^bold>\<top> \<sqsubseteq> \<^bold>\<top>"
        using assms(2) utp_top weak.top_closed by force
      thus ?thesis
        by (auto, rule_tac x="\<^bold>\<top>" in exI, auto simp add: top_healthy)
    qed
    show "\<^bold>\<mu> F \<sqsubseteq> (\<mu> X \<bullet> F (\<H> X))"
    proof -
      have "\<Sqinter>{P. (P is \<H>) \<and> F(P) \<sqsubseteq> P} \<sqsubseteq> \<Sqinter>{P. F(\<H>(P)) \<sqsubseteq> P}"
      proof -
        have 1: "\<And> P. F(\<H>(P)) = \<H>(F(\<H>(P)))"
          by (metis HCond_Idem Healthy_def assms(2) funcset_mem mem_Collect_eq)
        show ?thesis
        proof (rule Sup_least, auto)
          fix P
          assume a: "F (\<H> P) \<sqsubseteq> P"
          hence F: "(F (\<H> P)) \<sqsubseteq> (\<H> P)"
            by (metis 1 HCond_Mono mono_def)
          show "\<Sqinter>{P. (P is \<H>) \<and> F P \<sqsubseteq> P} \<sqsubseteq> P"
          proof (rule Sup_upper2[of "F (\<H> P)"])
            show "F (\<H> P) \<in> {P. (P is \<H>) \<and> F P \<sqsubseteq> P}"
            proof (auto)
              show "F (\<H> P) is \<H>"
                by (metis 1 Healthy_def)
              show "F (F (\<H> P)) \<sqsubseteq> F (\<H> P)"
                using F mono_def assms(1) by blast
            qed
            show "F (\<H> P) \<sqsubseteq> P"
              by (simp add: a)
          qed
        qed
      qed

      with ne show ?thesis
        by (simp add: LEAST_FP_def gfp_def, subst healthy_inf_cont, auto simp add: lfp_def)
    qed
    from ne show "(\<mu> X \<bullet> F (\<H> X)) \<sqsubseteq> \<^bold>\<mu> F"
      apply (simp add: LEAST_FP_def gfp_def, subst healthy_inf_cont, auto simp add: lfp_def)
      apply (rule Sup_least)
      apply (auto simp add: Healthy_def Sup_upper)
      done
  qed

  lemma UINF_ind_Healthy [closure]:
    assumes "\<And> i. P(i) is \<H>"
    shows "(\<Sqinter> i \<bullet> P(i)) is \<H>"
    by (simp add: closure assms)

end

text \<open> In another direction, we can also characterise UTP theories that are relational. Minimally
  this requires that the healthiness condition is closed under sequential composition. \<close>

locale utp_theory_rel =
  utp_theory +
  assumes Healthy_Sequence [closure]: "\<lbrakk> P is \<H>; Q is \<H> \<rbrakk> \<Longrightarrow> (P ;; Q) is \<H>"
begin

lemma upower_Suc_Healthy [closure]:
  assumes "P is \<H>"
  shows "P \<^bold>^ Suc n is \<H>"
  by (induct n, simp_all add: closure assms upred_semiring.power_Suc)

end

locale utp_theory_cont_rel = utp_theory_rel + utp_theory_continuous
begin

  lemma seq_cont_Sup_distl:
    assumes "P is \<H>" "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "P ;; (\<^bold>\<Sqinter> A) = \<^bold>\<Sqinter> {P ;; Q | Q. Q \<in> A }"
  proof -
    have "{P ;; Q | Q. Q \<in> A } \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
      using Healthy_Sequence assms(1) assms(2) by (auto)
    thus ?thesis
      by (simp add: healthy_inf_cont seq_Sup_distl setcompr_eq_image assms)
  qed

  lemma seq_cont_Sup_distr:
    assumes "Q is \<H>" "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "(\<^bold>\<Sqinter> A) ;; Q = \<^bold>\<Sqinter> {P ;; Q | P. P \<in> A }"
  proof -
    have "{P ;; Q | P. P \<in> A } \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
      using Healthy_Sequence assms(1) assms(2) by (auto)
    thus ?thesis
      by (simp add: healthy_inf_cont seq_Sup_distr setcompr_eq_image assms)
  qed

  lemma uplus_healthy [closure]:
    assumes "P is \<H>"
    shows "P\<^sup>+ is \<H>"
    by (simp add: uplus_power_def closure assms)

end

text \<open> There also exist UTP theories with units. Not all theories have both a left and a right unit
  (e.g. H1-H2 designs) and so we split up the locale into two cases. \<close>

locale utp_theory_units =
  utp_theory_rel +
  fixes utp_unit ("\<I>\<I>")
  assumes Healthy_Unit [closure]: "\<I>\<I> is \<H>"
begin

text \<open> We can characterise the theory Kleene star by lifting the relational one. \<close>

definition utp_star ("_\<^bold>\<star>" [999] 999) where
[upred_defs]: "utp_star P = (P\<^sup>\<star> ;; \<I>\<I>)"

text \<open> We can then characterise tests as refinements of units. \<close>

definition utp_test :: "'a hrel \<Rightarrow> bool" where
[upred_defs]: "utp_test b = (\<I>\<I> \<sqsubseteq> b)"

end

locale utp_theory_left_unital =
  utp_theory_units +
  assumes Unit_Left: "P is \<H> \<Longrightarrow> (\<I>\<I> ;; P) = P"

locale utp_theory_right_unital =
  utp_theory_units +
  assumes Unit_Right: "P is \<H> \<Longrightarrow> (P ;; \<I>\<I>) = P"

locale utp_theory_unital =
  utp_theory_left_unital + utp_theory_right_unital
begin

lemma Unit_self [simp]:
  "\<I>\<I> ;; \<I>\<I> = \<I>\<I>"
  by (simp add: Healthy_Unit Unit_Right)

lemma utest_intro:
  "\<I>\<I> \<sqsubseteq> P \<Longrightarrow> utp_test P"
  by (simp add: utp_test_def)

lemma utest_Unit [closure]:
  "utp_test \<I>\<I>"
  by (simp add: utp_test_def)

end

locale utp_theory_mono_unital = utp_theory_unital + utp_theory_mono
begin

lemma utest_Top [closure]: "utp_test \<^bold>\<top>"
  by (simp add: Healthy_Unit utp_test_def utp_top)

end

locale utp_theory_cont_unital = utp_theory_cont_rel + utp_theory_unital

sublocale utp_theory_cont_unital \<subseteq> utp_theory_mono_unital
  by (simp add: utp_theory_mono_axioms utp_theory_mono_unital_def utp_theory_unital_axioms)

locale utp_theory_unital_zerol =
  utp_theory_unital +
  utp_theory_lattice +
  assumes Top_Left_Zero: "P is \<H> \<Longrightarrow> \<^bold>\<top> ;; P = \<^bold>\<top>"

locale utp_theory_cont_unital_zerol =
  utp_theory_cont_unital + utp_theory_unital_zerol
begin

lemma Top_test_Right_Zero:
  assumes "b is \<H>" "utp_test b"
  shows "b ;; \<^bold>\<top> = \<^bold>\<top>"
proof -
  have "b \<sqinter> \<I>\<I> = \<I>\<I>"
    by (meson assms(2) semilattice_sup_class.le_iff_sup utp_test_def)
  then show ?thesis
    by (metis (no_types) Top_Left_Zero Unit_Left assms(1) meet_top top_healthy upred_semiring.distrib_right)
qed

end

subsection \<open> Theory of relations \<close>

interpretation rel_theory: utp_theory_mono_unital id skip_r
  rewrites "rel_theory.utp_top = false"
  and "rel_theory.utp_bottom = true"
  and "carrier (utp_order id) = UNIV"
  and "(P is id) = True"
proof -
  show "utp_theory_mono_unital id II"
    by (unfold_locales, simp_all add: Healthy_def)
  then interpret utp_theory_mono_unital id skip_r
    by simp
  show "utp_top = false" "utp_bottom = true"
    by (simp_all add: healthy_top healthy_bottom)
  show "carrier (utp_order id) = UNIV" "(P is id) = True"
    by (auto simp add: utp_order_def Healthy_def)
qed

thm rel_theory.GFP_unfold

subsection \<open> Theory links \<close>

text \<open> We can also describe links between theories, such a Galois connections and retractions,
  using the following notation. \<close>

definition mk_conn ("_ \<Leftarrow>\<langle>_,_\<rangle>\<Rightarrow> _" [90,0,0,91] 91) where
"H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2 \<equiv> \<lparr> orderA = utp_order H1, orderB = utp_order H2, lower = \<H>\<^sub>2, upper = \<H>\<^sub>1 \<rparr>"

lemma mk_conn_orderA [simp]: "\<X>\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = utp_order H1"
  by (simp add:mk_conn_def)

lemma mk_conn_orderB [simp]: "\<Y>\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = utp_order H2"
  by (simp add:mk_conn_def)

lemma mk_conn_lower [simp]:  "\<pi>\<^sub>*\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = \<H>\<^sub>1"
  by (simp add: mk_conn_def)

lemma mk_conn_upper [simp]:  "\<pi>\<^sup>*\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = \<H>\<^sub>2"
  by (simp add: mk_conn_def)

lemma galois_comp: "(H\<^sub>2 \<Leftarrow>\<langle>\<H>\<^sub>3,\<H>\<^sub>4\<rangle>\<Rightarrow> H\<^sub>3) \<circ>\<^sub>g (H\<^sub>1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H\<^sub>2) = H\<^sub>1 \<Leftarrow>\<langle>\<H>\<^sub>1\<circ>\<H>\<^sub>3,\<H>\<^sub>4\<circ>\<H>\<^sub>2\<rangle>\<Rightarrow> H\<^sub>3"
  by (simp add: comp_galcon_def mk_conn_def)

text \<open> Example Galois connection / retract: Existential quantification \<close>

lemma Idempotent_ex: "mwb_lens x \<Longrightarrow> Idempotent (ex x)"
  by (simp add: Idempotent_def exists_twice)

lemma Monotonic_ex: "mwb_lens x \<Longrightarrow> Monotonic (ex x)"
  by (simp add: mono_def ex_mono)

lemma ex_closed_unrest:
  "vwb_lens x \<Longrightarrow> \<lbrakk>ex x\<rbrakk>\<^sub>H = {P. x \<sharp> P}"
  by (simp add: Healthy_def unrest_as_exists)

text \<open> Any theory can be composed with an existential quantification to produce a Galois connection \<close>

theorem ex_retract:
  assumes "vwb_lens x" "Idempotent H" "ex x \<circ> H = H \<circ> ex x"
  shows "retract ((ex x \<circ> H) \<Leftarrow>\<langle>ex x, H\<rangle>\<Rightarrow> H)"
proof (unfold_locales, simp_all)
  show "H \<in> \<lbrakk>ex x \<circ> H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
    using Healthy_Idempotent assms by blast
  from assms(1) assms(3)[THEN sym] show "ex x \<in> \<lbrakk>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>ex x \<circ> H\<rbrakk>\<^sub>H"
    by (simp add: Pi_iff Healthy_def fun_eq_iff exists_twice)
  fix P Q
  assume "P is (ex x \<circ> H)" "Q is H"
  thus "(H P \<sqsubseteq> Q) = (P \<sqsubseteq> (\<exists> x \<bullet> Q))"
    by (metis (no_types, lifting) Healthy_Idempotent Healthy_if assms comp_apply dual_order.trans ex_weakens utp_pred_laws.ex_mono vwb_lens_wb)
next
  fix P
  assume "P is (ex x \<circ> H)"
  thus "(\<exists> x \<bullet> H P) \<sqsubseteq> P"
    by (simp add: Healthy_def)
qed

corollary ex_retract_id:
  assumes "vwb_lens x"
  shows "retract (ex x \<Leftarrow>\<langle>ex x, id\<rangle>\<Rightarrow> id)"
  using assms ex_retract[where H="id"] by (auto)
end


(*<*)
theory Propositional_Logic
imports Abstract_Completeness
begin
(*>*)

section \<open>Toy instantiation: Propositional Logic\<close>

datatype fmla = Atom nat | Neg fmla | Conj fmla fmla

primrec max_depth where
  "max_depth (Atom _) = 0"
| "max_depth (Neg \<phi>) = Suc (max_depth \<phi>)"
| "max_depth (Conj \<phi> \<psi>) = Suc (max (max_depth \<phi>) (max_depth \<psi>))"

lemma max_depth_0: "max_depth \<phi> = 0 = (\<exists>n. \<phi> = Atom n)"
  by (cases \<phi>) auto

lemma max_depth_Suc: "max_depth \<phi> = Suc n = ((\<exists>\<psi>. \<phi> = Neg \<psi> \<and> max_depth \<psi> = n) \<or>
  (\<exists>\<psi>1 \<psi>2. \<phi> = Conj \<psi>1 \<psi>2 \<and> max (max_depth \<psi>1) (max_depth \<psi>2) = n))"
  by (cases \<phi>) auto

abbreviation "atoms \<equiv> smap Atom nats"
abbreviation "depth1 \<equiv>
  sinterleave (smap Neg atoms) (smap (case_prod Conj) (sproduct atoms atoms))"

abbreviation "sinterleaves \<equiv> fold sinterleave"

fun extendLevel where "extendLevel (belowN, N) =
  (let Next = sinterleaves
    (map (smap (case_prod Conj)) [sproduct belowN N, sproduct N belowN, sproduct N N])
    (smap Neg N)
  in (sinterleave belowN N, Next))"

lemma extendLevel_step:
  "\<lbrakk>sset belowN = {\<phi>. max_depth \<phi> < n};
    sset N = {\<phi>. max_depth \<phi> = n}; st = (belowN, N)\<rbrakk> \<Longrightarrow>
  \<exists>belowNext Next. extendLevel st = (belowNext, Next) \<and>
     sset belowNext = {\<phi>. max_depth \<phi> < Suc n} \<and> sset Next = {\<phi>. max_depth \<phi> = Suc n}"
  by (auto simp: sset_sinterleave sset_sproduct stream.set_map
    image_iff max_depth_Suc)

lemma sset_atoms: "sset atoms = {\<phi>. max_depth \<phi> < 1}"
  by (auto simp: stream.set_map max_depth_0)

lemma sset_depth1: "sset depth1 = {\<phi>. max_depth \<phi> = 1}"
  by (auto simp: sset_sinterleave sset_sproduct stream.set_map
    max_depth_Suc max_depth_0 max_def image_iff)

lemma extendLevel_Nsteps:
  "\<lbrakk>sset belowN = {\<phi>. max_depth \<phi> < n}; sset N = {\<phi>. max_depth \<phi> = n}\<rbrakk> \<Longrightarrow>
  \<exists>belowNext Next. (extendLevel ^^ m) (belowN, N) = (belowNext, Next) \<and>
     sset belowNext = {\<phi>. max_depth \<phi> < n + m} \<and> sset Next = {\<phi>. max_depth \<phi> = n + m}"
proof (induction m arbitrary: belowN N n)
  case (Suc m)
  then obtain belowNext Next where "(extendLevel ^^ m) (belowN, N) = (belowNext, Next)"
    "sset belowNext = {\<phi>. max_depth \<phi> < n + m}" "sset Next = {\<phi>. max_depth \<phi> = n + m}"
    by blast
  thus ?case unfolding funpow.simps o_apply add_Suc_right
    by (intro extendLevel_step[of belowNext _ Next])
qed simp

corollary extendLevel:
  "\<exists>belowNext Next. (extendLevel ^^ m) (atoms, depth1) = (belowNext, Next) \<and>
     sset belowNext = {\<phi>. max_depth \<phi> < 1 + m} \<and> sset Next = {\<phi>. max_depth \<phi> = 1 + m}"
  by (rule extendLevel_Nsteps) (auto simp: sset_atoms sset_depth1)

definition "fmlas = sinterleave atoms (smerge (smap snd (siterate extendLevel (atoms, depth1))))"

lemma fmlas_UNIV: "sset fmlas = (UNIV :: fmla set)"
proof (intro equalityI subsetI UNIV_I)
  fix \<phi>
  show "\<phi> \<in> sset fmlas"
  proof (cases "max_depth \<phi>")
    case 0 thus ?thesis unfolding fmlas_def sset_sinterleave stream.set_map
      by (intro UnI1) (auto simp: max_depth_0)
  next
    case (Suc m) thus ?thesis using extendLevel[of m]
    unfolding fmlas_def sset_smerge sset_siterate sset_sinterleave stream.set_map
      by (intro UnI2) (auto, metis (mono_tags) mem_Collect_eq)
  qed
qed

datatype rule = Idle | Ax nat | NegL fmla | NegR fmla | ConjL fmla fmla | ConjR fmla fmla

abbreviation "mkRules f \<equiv> smap f fmlas"
abbreviation "mkRulePairs f \<equiv> smap (case_prod f) (sproduct fmlas fmlas)"

definition rules where
  "rules = Idle ##
     sinterleaves [mkRules NegL, mkRules NegR, mkRulePairs ConjL, mkRulePairs ConjR]
     (smap Ax nats)"

lemma rules_UNIV: "sset rules = (UNIV :: rule set)"
  unfolding rules_def by (auto simp: sset_sinterleave sset_sproduct stream.set_map
    fmlas_UNIV image_iff) (metis rule.exhaust)

type_synonym state = "fmla fset * fmla fset"

fun eff' :: "rule \<Rightarrow> state \<Rightarrow> state fset option" where
  "eff' Idle (\<Gamma>, \<Delta>) = Some {|(\<Gamma>, \<Delta>)|}"
| "eff' (Ax n) (\<Gamma>, \<Delta>) =
    (if Atom n |\<in>| \<Gamma> \<and> Atom n |\<in>| \<Delta> then Some {||} else None)"
| "eff' (NegL \<phi>) (\<Gamma>, \<Delta>) =
    (if Neg \<phi> |\<in>| \<Gamma> then Some {|(\<Gamma> |-| {| Neg \<phi> |}, finsert \<phi> \<Delta>)|} else None)"
| "eff' (NegR \<phi>) (\<Gamma>, \<Delta>) =
    (if Neg \<phi> |\<in>| \<Delta> then Some {|(finsert \<phi> \<Gamma>, \<Delta> |-| {| Neg \<phi> |})|} else None)"
| "eff' (ConjL \<phi> \<psi>) (\<Gamma>, \<Delta>) =
    (if Conj \<phi> \<psi> |\<in>| \<Gamma>
    then Some {|(finsert \<phi> (finsert \<psi> (\<Gamma> |-| {| Conj \<phi> \<psi> |})), \<Delta>)|}
    else None)"
| "eff' (ConjR \<phi> \<psi>) (\<Gamma>, \<Delta>) =
    (if Conj \<phi> \<psi> |\<in>| \<Delta>
    then Some {|(\<Gamma>, finsert \<phi> (\<Delta> |-| {| Conj \<phi> \<psi> |})), (\<Gamma>, finsert \<psi> (\<Delta> |-| {| Conj \<phi> \<psi> |}))|}
    else None)"

abbreviation "Disj \<phi> \<psi> \<equiv> Neg (Conj (Neg \<phi>) (Neg \<psi>))"
abbreviation "Imp \<phi> \<psi> \<equiv> Disj (Neg \<phi>) \<psi>"
abbreviation "Iff \<phi> \<psi> \<equiv> Conj (Imp \<phi> \<psi>) (Imp \<psi> \<phi>)"

definition "thm1 \<equiv> ({|Conj (Atom 0) (Neg (Atom 0))|}, {||})"

declare Stream.smember_code [code del]

interpretation RuleSystem "\<lambda>r s ss. eff' r s = Some ss" rules UNIV
  by unfold_locales (auto simp: rules_UNIV intro: exI[of _ Idle])

interpretation PersistentRuleSystem "\<lambda>r s ss. eff' r s = Some ss" rules UNIV
proof (unfold_locales, unfold enabled_def per_def rules_UNIV, clarsimp)
  fix r \<Gamma> \<Delta> ss r' \<Gamma>' \<Delta>' ss'
  assume "r' \<noteq> r" "eff' r (\<Gamma>, \<Delta>) = Some ss" "eff' r' (\<Gamma>, \<Delta>) = Some ss'" "(\<Gamma>', \<Delta>') |\<in>| ss'"
  then show "\<exists>sl. eff' r (\<Gamma>', \<Delta>') = Some sl"
    by (cases r r' rule: rule.exhaust[case_product rule.exhaust]) (auto split: if_splits)
qed

definition "rho \<equiv> i.fenum rules"
definition "propTree \<equiv> i.mkTree eff' rho"

export_code propTree thm1 in Haskell module_name PropInstance (* file "." *)

(*<*)
end
(*>*)


(*  Title:      Depth-First Search
    Author:     Toshiaki Nishihara and Yasuhiko Minamide
    Maintainer: Yasuhiko Minamide <minamide at cs.tsukuba.ac.jp>
*)

section "Depth-First Search"

theory DFS
  imports Main "Eval_Base.Eval_Base"
begin

subsection "Definition of Graphs"

typedecl node
type_synonym graph = "(node * node) list"

primrec nexts :: "[graph, node] \<Rightarrow> node list"
where
  "nexts [] n = []"
| "nexts (e#es) n = (if fst e = n then snd e # nexts es n else nexts es n)"

definition nextss :: "[graph, node list] \<Rightarrow> node set"
  where "nextss g xs = set g `` set xs"

lemma nextss_Cons: "nextss g (x#xs) = set (nexts g x) \<union> nextss g xs"
  unfolding nextss_def by (auto simp add:Image_def nexts_set)

definition reachable :: "[graph, node list] \<Rightarrow> node set"
  where "reachable g xs = (set g)\<^sup>* `` set xs"

subsection "Depth-First Search with Stack"

definition nodes_of :: "graph \<Rightarrow> node set"
  where "nodes_of g = set (map fst g @ map snd g)"

lemma [simp]: "finite (nodes_of g - set ys)"
proof(rule finite_subset)
  show "finite (nodes_of g)"
    by (auto simp add: nodes_of_def)
qed (auto)

function
  dfs :: "graph \<Rightarrow> node list \<Rightarrow> node list \<Rightarrow> node list"
where
  dfs_base: "dfs g [] ys = ys"
| dfs_inductive: "dfs g (x#xs) ys = (if List.member ys x then dfs g xs ys
                        else dfs g (nexts g x@xs) (x#ys))"
by pat_completeness auto

termination
apply (relation "inv_image (finite_psubset <*lex*> less_than)
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))")
apply auto[1]
apply (simp_all add: finite_psubset_def)
by (case_tac  "x \<in> nodes_of g") (auto simp add: List.member_def)

text \<open>
  \begin{itemize}
  \item The second argument of \isatext{\isastyle{dfs}} is a stack of nodes that will be
  visited.
  \item The third argument of \isatext{\isastyle{dfs}} is a list of nodes that have
  been visited already.
  \end{itemize}
\<close>

subsection "Depth-First Search with Nested-Recursion"

function
  dfs2 :: "graph \<Rightarrow> node list \<Rightarrow> node list \<Rightarrow> node list"
where
  "dfs2 g [] ys = ys"
|  dfs2_inductive:
          "dfs2 g (x#xs) ys = (if List.member ys x then dfs2 g xs ys
                               else dfs2 g xs (dfs2 g (nexts g x) (x#ys)))"
by pat_completeness auto

lemma dfs2_invariant: "dfs2_dom (g, xs, ys) \<Longrightarrow> set ys \<subseteq> set (dfs2 g xs ys)"
apply2 (induct g xs ys rule: dfs2.pinduct) by(force simp add: dfs2.psimps)+

termination dfs2
apply (relation "inv_image (finite_psubset <*lex*> less_than)
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))")
apply auto[1]
apply (simp_all add: finite_psubset_def)
apply (case_tac  "x \<in> nodes_of g")
apply (auto simp add: List.member_def)[2]
by (insert dfs2_invariant) force

(*lemma dfs2_induct[induct type]:
  assumes B: "\<And>g ys. P g [] ys" and
  H: "\<And>g x xs ys.
        \<lbrakk>\<not> x mem ys \<longrightarrow> P g xs (dfs2 (g, nexts g x, x # ys));
         \<not> x mem ys \<longrightarrow> P g (nexts g x) (x # ys); x mem ys \<longrightarrow> P g xs ys\<rbrakk>
         \<Longrightarrow> P g (x # xs) ys"
  shows "P u v w"

proof (induct u v w rule: dfs2.induct)
  case 1 show ?case by (rule B)
next
  case (2 g x xs ys)
  show ?case
  proof (rule H)
    show "\<not> x mem ys \<longrightarrow> P g xs (dfs2 (g, nexts g x, x # ys))"
    proof
      assume *: "\<not> x mem ys"
      have "set (x#ys) \<subseteq> set (dfs2 (g, nexts g x, x # ys))"
        by (rule dfs2_inv)
      with 2 * show "P g xs (dfs2 (g, nexts g x, x # ys))"
        by auto
    qed
  qed (rule 2)+
qed
*)

lemma dfs_app: "dfs g (xs@ys) zs = dfs g ys (dfs g xs zs)"
  apply2 (induct g xs zs rule: dfs.induct) by auto

lemma "dfs2 g xs ys = dfs g xs ys"
  apply2 (induct g xs ys rule: dfs2.induct) by(auto simp add: dfs_app)

subsection "Basic Properties"

lemma visit_subset_dfs: "set ys \<subseteq> set (dfs g xs ys)"
  apply2 (induct g xs ys rule: dfs.induct) by auto

lemma next_subset_dfs: "set xs \<subseteq> set (dfs g xs ys)"
proof2(induct g xs ys rule:dfs.induct)
  case(2 g x xs ys)
  show ?case
  proof(cases "x \<in> set ys")
    case True
    have "set ys \<subseteq> set (dfs g xs ys)"
      by (rule visit_subset_dfs)
    with 2 and True show ?thesis
      by (auto simp add: List.member_def)
  next
    case False
    have "set (x#ys) \<subseteq> set (dfs g (nexts g x @ xs) (x#ys))"
      by(rule visit_subset_dfs)
    with 2 and False show ?thesis
      by (auto simp add: List.member_def)
  qed
qed(simp)

lemma nextss_closed_dfs'[rule_format]:
 "nextss g ys \<subseteq> set xs \<union> set ys \<longrightarrow> nextss g (dfs g xs ys) \<subseteq> set (dfs g xs ys)"
  apply2 (induct g xs ys rule:dfs.induct) by(auto simp add:nextss_Cons List.member_def)

lemma nextss_closed_dfs: "nextss g (dfs g xs []) \<subseteq> set (dfs g xs [])"
  by (rule nextss_closed_dfs', simp add: nextss_def)

lemma Image_closed_trancl: assumes "r `` X \<subseteq> X" shows "r\<^sup>* `` X = X"
proof
  show "r\<^sup>* `` X \<subseteq> X"
  proof -
    {
      fix x y
      assume y: "y \<in> X"
      assume "(y,x) \<in> r\<^sup>*"
      then have "x \<in> X"
        apply2 (induct) by(insert assms y, auto simp add: Image_def)
    }
    then show ?thesis unfolding Image_def by auto
  qed
qed auto

lemma reachable_closed_dfs: "reachable g xs \<subseteq> set(dfs g xs [])"
proof -
  have "reachable g xs \<subseteq> reachable g (dfs g xs [])"
    unfolding reachable_def by (rule Image_mono) (auto simp add: next_subset_dfs)
  also have "\<dots> = set(dfs g xs [])"
    unfolding reachable_def
  proof (rule Image_closed_trancl)
    from nextss_closed_dfs
    show "set g `` set (dfs g xs []) \<subseteq> set (dfs g xs [])"
      by (simp add: nextss_def)
  qed
  finally show ?thesis .
qed

lemma reachable_nexts: "reachable g (nexts g x) \<subseteq> reachable g [x]"
  unfolding reachable_def
  by (auto intro: converse_rtrancl_into_rtrancl simp: nexts_set)

lemma reachable_append: "reachable g (xs @ ys) = reachable g xs \<union> reachable g ys"
  unfolding reachable_def by auto

lemma dfs_subset_reachable_visit_nodes: "set (dfs g xs ys) \<subseteq> reachable g xs \<union> set ys"
proof2(induct g xs ys rule: dfs.induct)
  case 1
  then show ?case by simp
next
  case (2 g x xs ys)
  show ?case
  proof (cases "x \<in> set ys")
    case True
    with 2 show "set (dfs g (x#xs) ys) \<subseteq> reachable g (x#xs) \<union> set ys"
      by (auto simp add: reachable_def List.member_def)
  next
    case False
    have "reachable g (nexts g x) \<subseteq> reachable g [x]"
      by (rule reachable_nexts)
    hence a: "reachable g (nexts g x @ xs) \<subseteq> reachable g (x#xs)"
      by(simp add: reachable_append, auto simp add: reachable_def)
    with False 2
    show "set (dfs g (x#xs) ys) \<subseteq> reachable g (x#xs) \<union> set ys"
      by (auto simp add: reachable_def List.member_def)
  qed
qed

subsection "Correctness"

theorem dfs_eq_reachable: "set (dfs g xs []) = reachable g xs"
proof
  have "set (dfs g xs []) \<subseteq> reachable g xs \<union> set []"
    by (rule dfs_subset_reachable_visit_nodes[of g xs "[]"])
 thus "set (dfs g xs []) \<subseteq> reachable g xs"
   by simp
qed(rule reachable_closed_dfs)

theorem "y \<in> set (dfs g [x] []) = ((x,y) \<in> (set g)\<^sup>*)"
  by(simp only:dfs_eq_reachable reachable_def, auto)

subsection "Executable Code"

consts Node :: "int \<Rightarrow> node"

code_datatype Node

instantiation node :: equal
begin

definition equal_node :: "node \<Rightarrow> node \<Rightarrow> bool"
where
  [code del]: "equal_node = HOL.eq"

instance proof
qed (simp add: equal_node_def)

end

declare [[code abort: "HOL.equal :: node \<Rightarrow> node \<Rightarrow> bool"]]

export_code dfs dfs2 in SML file \<open>dfs.ML\<close>

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_59
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun last :: "Nat list => Nat" where
  "last (nil2) = Z"
| "last (cons2 z (nil2)) = z"
| "last (cons2 z (cons2 x2 x3)) = last (cons2 x2 x3)"

theorem property0 :
  "((ys = (nil2)) ==> ((last (x xs ys)) = (last xs)))"
  find_proof DInd
  apply (induct rule: TIP_prop_59.last.induct)
    apply auto
  done

theorem property0' :(*sub-optimal proof*)
  "((ys = (nil2)) ==> ((last (x xs ys)) = (last xs)))"
  apply (induct xs)
   apply auto[1]
  apply clarsimp
    (*Why "case_tac xs"?
    Because we want to simplify "last (cons2 x1 (x xs nil2))" using last.simps(3).
    and we need to pattern-match on "xs" to use x.simps(2).
   *)
  apply(case_tac xs)
   apply fastforce+
  done

end


(*  Title:      HOL/Cardinals/Wellorder_Embedding.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Well-order embeddings.
*)

section \<open>Well-Order Embeddings\<close>

theory Wellorder_Embedding
imports Fun_More Wellorder_Relation
begin

subsection \<open>Auxiliaries\<close>

lemma UNION_bij_betw_ofilter:
assumes WELL: "Well_order r" and
        OF: "\<And> i. i \<in> I \<Longrightarrow> ofilter r (A i)" and
       BIJ: "\<And> i. i \<in> I \<Longrightarrow> bij_betw f (A i) (A' i)"
shows "bij_betw f (\<Union>i \<in> I. A i) (\<Union>i \<in> I. A' i)"
proof-
  have "wo_rel r" using WELL by (simp add: wo_rel_def)
  hence "\<And> i j. \<lbrakk>i \<in> I; j \<in> I\<rbrakk> \<Longrightarrow> A i \<le> A j \<or> A j \<le> A i"
  using wo_rel.ofilter_linord[of r] OF by blast
  with WELL BIJ show ?thesis
  by (auto simp add: bij_betw_UNION_chain)
qed

subsection \<open>(Well-order) embeddings, strict embeddings, isomorphisms and order-compatible
functions\<close>

lemma embed_halfcong:
assumes EQ: "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a" and
        EMB: "embed r r' f"
shows "embed r r' g"
proof(unfold embed_def, auto)
  fix a assume *: "a \<in> Field r"
  hence "bij_betw f (under r a) (under r' (f a))"
  using EMB unfolding embed_def by simp
  moreover
  {have "under r a \<le> Field r"
   by (auto simp add: under_Field)
   hence "\<And> b. b \<in> under r a \<Longrightarrow> f b = g b"
   using EQ by blast
  }
  moreover have "f a = g a" using * EQ by auto
  ultimately show "bij_betw g (under r a) (under r' (g a))"
  using bij_betw_cong[of "under r a" f g "under r' (f a)"] by auto
qed

lemma embed_cong[fundef_cong]:
assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
shows "embed r r' f = embed r r' g"
using assms embed_halfcong[of r f g r']
            embed_halfcong[of r g f r'] by auto

lemma embedS_cong[fundef_cong]:
assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
shows "embedS r r' f = embedS r r' g"
unfolding embedS_def using assms
embed_cong[of r f g r'] bij_betw_cong[of "Field r" f g "Field r'"] by blast

lemma iso_cong[fundef_cong]:
assumes "\<And> a. a \<in> Field r \<Longrightarrow> f a = g a"
shows "iso r r' f = iso r r' g"
unfolding iso_def using assms
embed_cong[of r f g r'] bij_betw_cong[of "Field r" f g "Field r'"] by blast

lemma id_compat: "compat r r id"
by(auto simp add: id_def compat_def)

lemma comp_compat:
"\<lbrakk>compat r r' f; compat r' r'' f'\<rbrakk> \<Longrightarrow> compat r r'' (f' o f)"
by(auto simp add: comp_def compat_def)

corollary one_set_greater:
"(\<exists>f::'a \<Rightarrow> 'a'. f ` A \<le> A' \<and> inj_on f A) \<or> (\<exists>g::'a' \<Rightarrow> 'a. g ` A' \<le> A \<and> inj_on g A')"
proof-
  obtain r where "well_order_on A r" by (fastforce simp add: well_order_on)
  hence 1: "A = Field r \<and> Well_order r"
  using well_order_on_Well_order by auto
  obtain r' where 2: "well_order_on A' r'" by (fastforce simp add: well_order_on)
  hence 2: "A' = Field r' \<and> Well_order r'"
  using well_order_on_Well_order by auto
  hence "(\<exists>f. embed r r' f) \<or> (\<exists>g. embed r' r g)"
  using 1 2 by (auto simp add: wellorders_totally_ordered)
  moreover
  {fix f assume "embed r r' f"
   hence "f`A \<le> A' \<and> inj_on f A"
   using 1 2 by (auto simp add: embed_Field embed_inj_on)
  }
  moreover
  {fix g assume "embed r' r g"
   hence "g`A' \<le> A \<and> inj_on g A'"
   using 1 2 by (auto simp add: embed_Field embed_inj_on)
  }
  ultimately show ?thesis by blast
qed

corollary one_type_greater:
"(\<exists>f::'a \<Rightarrow> 'a'. inj f) \<or> (\<exists>g::'a' \<Rightarrow> 'a. inj g)"
using one_set_greater[of UNIV UNIV] by auto

subsection \<open>Uniqueness of embeddings\<close>

lemma comp_embedS:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
        and  EMB: "embedS r r' f" and EMB': "embedS r' r'' f'"
shows "embedS r r'' (f' o f)"
proof-
  have "embed r' r'' f'" using EMB' unfolding embedS_def by simp
  thus ?thesis using assms by (auto simp add: embedS_comp_embed)
qed

lemma iso_iff4:
assumes WELL: "Well_order r"  and WELL': "Well_order r'"
shows "iso r r' f = (embed r r' f \<and> embed r' r (inv_into (Field r) f))"
using assms embed_bothWays_iso
by(unfold iso_def, auto simp add: inv_into_Field_embed_bij_betw)

lemma embed_embedS_iso:
"embed r r' f = (embedS r r' f \<or> iso r r' f)"
unfolding embedS_def iso_def by blast

lemma not_embedS_iso:
"\<not> (embedS r r' f \<and> iso r r' f)"
unfolding embedS_def iso_def by blast

lemma embed_embedS_iff_not_iso:
assumes "embed r r' f"
shows "embedS r r' f = (\<not> iso r r' f)"
using assms unfolding embedS_def iso_def by blast

lemma iso_inv_into:
assumes WELL: "Well_order r" and ISO: "iso r r' f"
shows "iso r' r (inv_into (Field r) f)"
using assms unfolding iso_def
using bij_betw_inv_into inv_into_Field_embed_bij_betw by blast

lemma embedS_or_iso:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "(\<exists>g. embedS r r' g) \<or> (\<exists>h. embedS r' r h) \<or> (\<exists>f. iso r r' f)"
proof-
  {fix f assume *: "embed r r' f"
   {assume "bij_betw f (Field r) (Field r')"
    hence ?thesis using * by (auto simp add: iso_def)
   }
   moreover
   {assume "\<not> bij_betw f (Field r) (Field r')"
    hence ?thesis using * by (auto simp add: embedS_def)
   }
   ultimately have ?thesis by auto
  }
  moreover
  {fix f assume *: "embed r' r f"
   {assume "bij_betw f (Field r') (Field r)"
    hence "iso r' r f" using * by (auto simp add: iso_def)
    hence "iso r r' (inv_into (Field r') f)"
    using WELL' by (auto simp add: iso_inv_into)
    hence ?thesis by blast
   }
   moreover
   {assume "\<not> bij_betw f (Field r') (Field r)"
    hence ?thesis using * by (auto simp add: embedS_def)
   }
   ultimately have ?thesis by auto
  }
  ultimately show ?thesis using WELL WELL'
  wellorders_totally_ordered[of r r'] by blast
qed

end


section \<open>Defining the Attractor with \texttt{inductive\_set}\<close>

theory AttractorInductive
imports
  Main
  Attractor
begin

context ParityGame begin

text \<open>
  In section \ref{sec:attractor} we defined @{const attractor} manually via @{const lfp}.
  We can also define it with \texttt{inductive\_set}.  In this section, we do exactly this and
  prove that the new definition yields the same set as the old definition.
\<close>

subsection \<open>@{term attractor_inductive}\<close>

text \<open>The attractor set of a given set of nodes, defined inductively.\<close>
inductive_set attractor_inductive :: "Player \<Rightarrow> 'a set \<Rightarrow> 'a set"
  for p :: Player and W :: "'a set" where
  Base [intro!]: "v \<in> W \<Longrightarrow> v \<in> attractor_inductive p W"
| VVp: "\<lbrakk> v \<in> VV p; \<exists>w. v\<rightarrow>w \<and> w \<in> attractor_inductive p W \<rbrakk>
    \<Longrightarrow> v \<in> attractor_inductive p W"
| VVpstar: "\<lbrakk> v \<in> VV p**; \<not>deadend v; \<forall>w. v\<rightarrow>w \<longrightarrow> w \<in> attractor_inductive p W \<rbrakk>
    \<Longrightarrow> v \<in> attractor_inductive p W"

text \<open>
  We show that the inductive definition and the definition via least fixed point are the same.
\<close>
lemma attractor_inductive_is_attractor:
  assumes "W \<subseteq> V"
  shows "attractor_inductive p W = attractor p W"
proof
  show "attractor_inductive p W \<subseteq> attractor p W" proof
    fix v assume "v \<in> attractor_inductive p W"
    thus "v \<in> attractor p W" proof (induct rule: attractor_inductive.induct)
      case (Base v) thus ?case using attractor_set_base by auto
    next
      case (VVp v) thus ?case using attractor_set_VVp by auto
    next
      case (VVpstar v) thus ?case using attractor_set_VVpstar by auto
    qed
  qed
  show "attractor p W \<subseteq> attractor_inductive p W"
  proof-
    define P where "P S \<longleftrightarrow> S \<subseteq> attractor_inductive p W" for S
    from \<open>W \<subseteq> V\<close> have "P (attractor p W)" proof (induct rule: attractor_set_induction)
      case (step S)
      hence "S \<subseteq> attractor_inductive p W" using P_def by simp
      have "W \<union> S \<union> directly_attracted p S \<subseteq> attractor_inductive p W" proof
        fix v assume "v \<in> W \<union> S \<union> directly_attracted p S"
        moreover
        { assume "v \<in> W" hence "v \<in> attractor_inductive p W" by blast }
        moreover
        { assume "v \<in> S" hence "v \<in> attractor_inductive p W"
            by (meson \<open>S \<subseteq> attractor_inductive p W\<close> rev_subsetD) }
        moreover
        { assume v_attracted: "v \<in> directly_attracted p S"
          hence "v \<in> V" using \<open>S \<subseteq> V\<close> attractor_step_bounded_by_V by blast
          hence "v \<in> attractor_inductive p W" proof (cases rule: VV_cases)
            assume "v \<in> VV p"
            hence "\<exists>w. v\<rightarrow>w \<and> w \<in> S" using v_attracted directly_attracted_def by blast
            hence "\<exists>w. v\<rightarrow>w \<and> w \<in> attractor_inductive p W"
              using \<open>S \<subseteq> attractor_inductive p W\<close> by blast
            thus ?thesis by (simp add: \<open>v \<in> VV p\<close> attractor_inductive.VVp)
          next
            assume "v \<in> VV p**"
            hence *: "\<forall>w. v\<rightarrow>w \<longrightarrow> w \<in> S" using v_attracted directly_attracted_def by blast
            have "\<not>deadend v" using v_attracted directly_attracted_def by blast
            show ?thesis proof (rule ccontr)
              assume "v \<notin> attractor_inductive p W"
              hence "\<exists>w. v\<rightarrow>w \<and> w \<notin> attractor_inductive p W"
                by (metis attractor_inductive.VVpstar \<open>v \<in> VV p**\<close> \<open>\<not>deadend v\<close>)
              hence "\<exists>w. v\<rightarrow>w \<and> w \<notin> S" using \<open>S \<subseteq> attractor_inductive p W\<close> by (meson subsetCE)
              thus False using * by blast
            qed
          qed
        }
        ultimately show "v \<in> attractor_inductive p W" by (meson UnE)
      qed
      thus "P (W \<union> S \<union> directly_attracted p S)" using P_def by simp
    qed (simp add: P_def Sup_least)
    thus ?thesis using P_def by simp
  qed
qed

end

end


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

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

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "((isPermutation xs ys) ==>
      ((isPermutation ys zs) ==> (isPermutation xs zs)))"
  oops

end


theory closure_algebra
  imports operators_basic
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Closure algebra\<close>
(**We define a topological Boolean algebra with a primitive closure operator and verify a few properties.*)

(**Declares a primitive (unconstrained) closure operation and defines others from it.*)
consts \<C>::"\<sigma>\<Rightarrow>\<sigma>"
abbreviation "\<I> \<equiv> \<C>\<^sup>d" (**interior*)
abbreviation "\<B> \<equiv> \<B>\<^sub>C \<C>" (**border*)
abbreviation "\<F> \<equiv> \<F>\<^sub>C \<C>" (**frontier*)

subsection \<open>Basic properties\<close>

(**Verifies minimal conditions under which operators resulting from conversion functions coincide.*)
lemma ICdual': "\<C> \<^bold>\<equiv> \<I>\<^sup>d" using dual_symm equal_op_def by auto
lemma IB_rel: "Cl_2 \<C> \<Longrightarrow> \<I> \<^bold>\<equiv> \<I>\<^sub>B \<B>" using Br_cl_def EXP_dual1 Int_br_def compl_def dEXP_def diff_def dual_def equal_op_def meet_def by fastforce
lemma IF_rel: "Cl_2 \<C> \<Longrightarrow> \<I> \<^bold>\<equiv> \<I>\<^sub>F \<F>" by (smt EXP_def Fr_cl_def Int_fr_def compl_def diff_def dual_def equal_op_def meet_def)

(**Fixed-point and other operators are interestingly related.*)
lemma fp1: "Cl_2 \<C> \<Longrightarrow> \<I>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>c" by (smt BI_rel Br_int_def IB_rel Int_br_def compl_def diff_def dimp_def equal_op_def)
lemma fp2: "Cl_2 \<C> \<Longrightarrow> \<B>\<^sup>f\<^sup>p \<^bold>\<equiv> \<I>\<^sup>c" using fp1 by (smt compl_def dimp_def equal_op_def)
lemma fp3: "Cl_2 \<C> \<Longrightarrow> \<C>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>d" by (smt BI_rel Br_int_def CB_rel Cl_br_def compl_def diff_def dimp_def dual_def equal_op_def join_def)
lemma fp4: "Cl_2 \<C> \<Longrightarrow> (\<B>\<^sup>d)\<^sup>f\<^sup>p \<^bold>\<equiv> \<C>" by (smt dimp_def equal_op_def fp3)
lemma fp5: "Cl_2 \<C> \<Longrightarrow> \<F>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B> \<^bold>\<squnion> (\<C>\<^sup>c)" by (smt Br_cl_def CF_rel Cl_fr_def FC2 Fr_2_def compl_def dimp_def eq_ext' equal_op_def join_def meet_def)

(**Define some fixed-point predicates and prove some properties.*)
abbreviation openset ("Op") where "Op A \<equiv> fp \<I> A"
abbreviation closedset ("Cl") where "Cl A \<equiv> fp \<C> A"
abbreviation borderset ("Br") where "Br A \<equiv> fp \<B> A"
abbreviation frontierset ("Fr") where "Fr A \<equiv> fp \<F> A"

lemma Int_Open: "Cl_4 \<C> \<Longrightarrow> \<forall>A. Op(\<I> A)" using IC4 IDEM_def by blast
lemma Cl_Closed: "Cl_4 \<C> \<Longrightarrow> \<forall>A. Cl(\<C> A)" by (simp add: IDEM_def)
lemma Br_Border: "Cl_1b \<C> \<Longrightarrow> \<forall>A. Br(\<B> A)" by (metis BI_rel Br_cl_def Br_int_def CI1b MULT_a_def diff_def eq_ext' meet_def)
(**In contrast, there is no analogous fixed-point result for frontier:*)
lemma "\<CC> \<C> \<Longrightarrow> \<forall>A. Fr(\<F> A)" nitpick oops (*counterexample even if assuming all closure conditions*)

lemma OpCldual: "\<forall>A. Cl A \<longleftrightarrow> Op(\<^bold>\<midarrow>A)" by (simp add: compl_def dual_def)
lemma ClOpdual: "\<forall>A. Op A \<longleftrightarrow> Cl(\<^bold>\<midarrow>A)" by (simp add: fp_d)
lemma Fr_ClBr: "Cl_2 \<C> \<Longrightarrow> \<forall>A. Fr(A) = (Cl(A) \<and> Br(A))" using BF_rel by (metis Br_fr_def CF_rel Cl_fr_def eq_ext' join_def meet_def)
lemma Cl_F: "Cl_1b \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4 \<C> \<Longrightarrow> \<forall>A. Cl(\<F> A)" using Cl_8_def Fr_cl_def PC8 by auto

end

github-repos/isabelle/davfuenmayor-topological-semantics/topological-semantics-770a84ffa2cf8498bd5f60853d11be4d77fc8cd3/old-stuff (to migrate from old version)/TBA/closure_algebra.thy