(*:maxLineLen=78:*)

section \<open>Finite Boolean Algebra\<close>

theory Finite_Boolean_Algebra
  imports
    "HOL-Library.Finite_Lattice"
    "HOL-Library.Lattice_Syntax"
    "HOL.Transcendental"
begin

sledgehammer_params [smt_proofs = false]

text \<open> This section presents finite Boolean algebras and \<^emph>\<open>Birkoff's theorem\<close>
       @{cite birkhoffRingsSets1937}. Birkoff's theorem states that any
       finite Boolean algebra is isomorphic to a powerset, with the usual
       set-based boolean algebra operations. \<close>

text \<open> In this section and \S\ref{sec:finite-boolean-algebra-probability}
       build up to a finitary formulation of the \<^emph>\<open>collapse theorem\<close>
       to be proved in \S\ref{subsec:collapse-theorem}. \<close>

subsection \<open> Finite Boolean Algebra Axiomatization \<close>

text \<open> The class of finite boolean algebras is simply an extension of
       @{class boolean_algebra}.  In particular, we assume
       \<^term>\<open>finite UNIV\<close> as per @{class finite}.  We also extend the
       language with infina and suprema (i.e. \<open>\<Sqinter> A\<close> and \<open>\<Squnion> A\<close> respectively).
       The new axioms are \<open> \<Sqinter> A = fold (\<sqinter>) \<top> A \<close> and its dual
       \<open> \<Squnion> A = fold (\<squnion>) \<bottom> A \<close>. \<close>

class finite_boolean_algebra = boolean_algebra + finite + Inf + Sup +
  assumes Inf_def: "\<Sqinter>A = Finite_Set.fold (\<sqinter>) \<top> A"
  assumes Sup_def: "\<Squnion>A = Finite_Set.fold (\<squnion>) \<bottom> A"
begin

text \<open> Finite Boolean algebras are a subclass of complete finite
       distributive lattices. \<close>

subclass finite_distrib_lattice_complete
  using
    Inf_fin.coboundedI
    Sup_fin.coboundedI
    finite_UNIV
    le_bot
    top_unique
    Inf_def
    Sup_def
  by (unfold_locales, blast, fastforce, auto)
end

subsection \<open> Join Prime Elements \<close>

text \<open> The proof of Birkoff's theorem presented here follows
       Davey and Priestley @{cite daveyChapterRepresentationFinite2002}.
       The key to their proof is to show that the elements of a finite
       Boolean algebra have a 1-1 correspondence with sets of \<^emph>\<open>join prime\<close>
       elements of the Boolean algebra. \<close>

text \<open> Join prime elements are defined as follows. \<close>

definition (in bounded_lattice_bot) join_prime :: "'a \<Rightarrow> bool" where
  "join_prime x \<equiv> x \<noteq> \<bottom> \<and> (\<forall> y z . x \<le> y \<squnion> z \<longrightarrow> x \<le> y \<or> x \<le> z)"

text \<open> Join prime elements are also sometimes known as \<^emph>\<open>atoms\<close>. They are
       the smallest elements of the Boolean algebra distinct from \<open>\<bottom>\<close>. \<close>

lemma (in boolean_algebra) join_prime_def':
  "join_prime x = (x \<noteq> \<bottom> \<and> (\<forall> y. y \<le> x \<longrightarrow> y = \<bottom> \<or> y = x))"
proof
  assume "join_prime x"
  hence "x \<noteq> \<bottom>"
    using join_prime_def by blast
  moreover
  {
    fix y
    assume "y \<le> x" "y \<noteq> x"
    hence "x = x \<squnion> y"
      using sup.orderE by blast
    also have "\<dots> = (x \<squnion> y) \<sqinter> (y \<squnion> -y)"
      by simp
    finally have "x = (x \<sqinter> -y) \<squnion> y"
      by (simp add: sup_inf_distrib2)
    hence "x \<le> -y"
      using \<open>join_prime x\<close> \<open>y \<noteq> x\<close> \<open>y \<le> x\<close> eq_iff
      unfolding join_prime_def
      by force
    hence "y \<le> y \<sqinter> -y"
      by (metis
            \<open>x = x \<squnion> y\<close>
            inf.orderE
            inf_compl_bot_right
            inf_sup_absorb
            order_refl
            sup.commute)
    hence "y = \<bottom>"
      using sup_absorb2 by fastforce
  }
  ultimately show "x \<noteq> \<bottom> \<and> (\<forall> y. y \<le> x \<longrightarrow> y = \<bottom> \<or> y = x)" by auto
next
  assume atomic: "x \<noteq> \<bottom> \<and> (\<forall> y. y \<le> x \<longrightarrow> y = \<bottom> \<or> y = x)"
  hence "x \<noteq> \<bottom>" by auto
  moreover
  {
    fix y z
    assume "x \<le> y \<squnion> z"
    hence "x = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
      using inf.absorb1 inf_sup_distrib1 by fastforce
    moreover
    have "x \<le> y \<or> (x \<sqinter> y) = \<bottom>"
         "x \<le> z \<or> (x \<sqinter> z) = \<bottom>"
      using atomic inf.cobounded1 inf.cobounded2 by fastforce+
    ultimately have "x \<le> y \<or> x \<le> z"
      using atomic by auto
  }
  ultimately show "join_prime x"
    unfolding join_prime_def
    by auto
qed

text \<open> All join prime elements are disjoint. \<close>

lemma (in boolean_algebra) join_prime_disjoint:
  assumes "join_prime \<alpha>"
      and "join_prime \<beta>"
    shows "(\<alpha> = \<beta>) \<longleftrightarrow> (\<alpha> \<sqinter> \<beta> \<noteq> \<bottom>)"
proof
  assume "\<alpha> = \<beta>"
  hence "\<alpha> \<sqinter> \<beta> = \<alpha>"
    by simp
  thus "\<alpha> \<sqinter> \<beta> \<noteq> \<bottom>"
    using \<open>join_prime \<alpha>\<close>
    unfolding join_prime_def
    by auto
next
  assume "\<alpha> \<sqinter> \<beta> \<noteq> \<bottom>"
  show "\<alpha> = \<beta>"
  proof (rule ccontr)
    assume "\<alpha> \<noteq> \<beta>"
    hence "\<not> (\<alpha> \<le> \<beta>)"
      using \<open>join_prime \<alpha>\<close>
            \<open>join_prime \<beta>\<close>
      unfolding join_prime_def'
      by blast
    hence "\<alpha> \<le> - \<beta>"
      using assms(1) join_prime_def by force
    hence "\<alpha> \<sqinter> \<beta> = \<bottom>"
      by (metis inf.commute inf.orderE inf_compl_bot_right)
    thus False
      using \<open>\<alpha> \<sqinter> \<beta> \<noteq> \<bottom>\<close>
      by blast
  qed
qed

definition (in bounded_lattice_bot) join_primes ("\<J>") where
  "\<J> \<equiv> {a . join_prime a}"

subsection \<open> Birkoff's Theorem \label{subsection:birkoffs-theorem} \<close>

text \<open> Birkoff's theorem states that every non-\<open>\<bottom>\<close> element of a finite
       Boolean algebra can be represented by the join prime elements beneath
       it. It goes on to assert that this representation is a Boolean algebra
       isomorphism. \<close>

text \<open> In this section we merely demonstrate the representation aspect of
       Birkoff's theorem.  In \S\ref{subsection:boolean-algebra-isomorphism}
       we show this representation is a Boolean algebra isomorphism. \<close>

text \<open> The fist step to representing elements is to show that there \<^emph>\<open>exist\<close>
       join prime elements beneath them. This is done by showing if
       there is no join prime element, we can make a descending chain with
       more elements than the finite Boolean algebra we are considering. \<close>

fun (in order) descending_chain_list :: "'a list \<Rightarrow> bool" where
  "descending_chain_list [] = True"
| "descending_chain_list [x] = True"
| "descending_chain_list (x # x' # xs)
     = (x < x' \<and> descending_chain_list (x' # xs))"

lemma (in order) descending_chain_list_tail:
  assumes "descending_chain_list (s # S)"
  shows "descending_chain_list S"
  using assms
  by (induct S, auto)

lemma (in order) descending_chain_list_drop_penultimate:
  assumes "descending_chain_list (s # s' # S)"
  shows "descending_chain_list (s # S)"
  using assms
  by (induct S, simp, auto)

lemma (in order) descending_chain_list_less_than_others:
  assumes "descending_chain_list (s # S)"
  shows   "\<forall>s' \<in> set S. s < s'"
  using assms
  by (induct S, auto, simp add: descending_chain_list_drop_penultimate)

lemma (in order) descending_chain_list_distinct:
  assumes "descending_chain_list S"
  shows "distinct S"
  using assms
  by (induct S,
      simp,
      meson
        descending_chain_list_less_than_others
        descending_chain_list_tail
        distinct.simps(2)
        less_irrefl)

lemma (in finite_boolean_algebra) join_prime_lower_bound_exists:
  assumes "x \<noteq> \<bottom>"
  shows "\<exists> y \<in> \<J>. y \<le> x"
proof (rule ccontr)
  assume "\<not> (\<exists>y \<in> \<J>. y \<le> x)"
  hence fresh: "\<forall> y \<le> x. y \<noteq> \<bottom> \<longrightarrow> (\<exists>z < y. z \<noteq> \<bottom>)"
    unfolding join_primes_def
              join_prime_def'
    using dual_order.not_eq_order_implies_strict
    by fastforce
  {
    fix n :: nat
    have "\<exists> S . descending_chain_list S
                \<and> length S = n
                \<and> (\<forall>s \<in> set S. s \<noteq> \<bottom> \<and> s \<le> x)"
    proof (induct n)
      case 0
      have "descending_chain_list []
            \<and> length [] = 0
            \<and> (\<forall>s \<in> set []. s \<noteq> \<bottom> \<and> s \<le> x)"
        by auto
      then show ?case by simp
    next
      case (Suc n)
      then show ?case proof (cases "n = 0")
        case True
        hence "descending_chain_list [x]
               \<and> length [x] = Suc n
               \<and> (\<forall>s \<in> set [x]. s \<noteq> \<bottom> \<and> s \<le> x)"
          using \<open>x \<noteq> \<bottom>\<close>
          by simp
        then show ?thesis
          by blast
      next
        case False
        from this obtain s S where
          "descending_chain_list (s # S)"
          "length (s # S) = n"
          "\<forall>s \<in> set (s # S). s \<noteq> \<bottom> \<and> s \<le> x"
          using Suc.hyps length_0_conv descending_chain_list.elims(2)
          by metis
        note A = this
        from this obtain s' where
          "s' < s"
          "s' \<noteq> \<bottom>"
          using fresh list.set_intros(1)
          by metis
        note B = this
        let ?S' = "s' # s # S"
        from A and B have
          "descending_chain_list ?S'"
          "length ?S' = Suc n"
          "\<forall>s \<in> set ?S'. s \<noteq> \<bottom> \<and> s \<le> x"
            by auto
        then show ?thesis by blast
      qed
    qed
  }
  from this obtain S :: "'a list" where
    "descending_chain_list S"
    "length S = 1 + (card (UNIV::'a set))"
    by auto
  hence "card (set S) = 1 + (card (UNIV::'a set))"
    using descending_chain_list_distinct
          distinct_card
    by fastforce
  hence "\<not> card (set S) \<le> card (UNIV::'a set)"
    by presburger
  thus "False"
    using card_mono finite_UNIV by blast
qed

text \<open> Having shown that there exists a join prime element beneath every
       non-\<open>\<bottom>\<close> element, we show that elements are exactly the suprema
       of the join prime elements beneath them. \<close>

definition (in bounded_lattice_bot)
  join_prime_embedding :: "'a \<Rightarrow> 'a set" ("\<lbrace> _ \<rbrace>" [50]) where
  "\<lbrace> x \<rbrace> \<equiv> {a \<in> \<J>. a \<le> x}"

theorem (in finite_boolean_algebra) sup_join_prime_embedding_ident:
   "x = \<Squnion> \<lbrace> x \<rbrace>"
proof -
  have "\<forall> a \<in> \<lbrace> x \<rbrace>. a \<le> x" unfolding join_prime_embedding_def by auto
  hence "\<Squnion> \<lbrace> x \<rbrace> \<le> x"
    by (simp add: Sup_least)
  moreover
  {
    fix y
    assume "\<Squnion> \<lbrace> x \<rbrace> \<le> y"
    have "x \<le> y"
    proof (rule ccontr)
      assume "\<not> x \<le> y"
      hence "\<bottom> < x \<sqinter> -y"
        by (metis bot_less
                  compl_sup_top
                  inf_top_right
                  le_iff_sup
                  sup.commute
                  sup_bot_right
                  sup_inf_distrib1)
      from this obtain a where
        "a \<in> \<J>"
        "a \<le> x \<sqinter> -y"
        using join_prime_lower_bound_exists [of "x \<sqinter> -y"]
        by blast
      hence "a \<in> \<lbrace> x \<rbrace>"
        by (simp add: join_prime_embedding_def)
      hence "a \<le> y"
        using \<open>\<Squnion>\<lbrace> x \<rbrace> \<le> y\<close>
              Sup_upper
              order.trans
        by blast
      hence "a \<le> y \<sqinter> -y"
        using \<open>a \<le> x \<sqinter> - y\<close>
              inf.boundedE
              inf_greatest
        by blast
      hence "a = \<bottom>"
        by (simp add: le_bot)
      thus "False"
        using \<open>a \<in> \<J>\<close>
        unfolding join_primes_def
                  join_prime_def
        by fast
    qed
  }
  ultimately show ?thesis
    by (simp add: antisym)
qed

text \<open> Just as \<open>x = \<Squnion> \<lbrace> x \<rbrace>\<close>, the reverse is also true; \<open>\<lambda> x. \<lbrace> x \<rbrace>\<close>
       and \<open>\<lambda> S. \<Squnion> S\<close> are inverses where \<open>S \<in> \<J>\<close>. \<close>

lemma (in finite_boolean_algebra) join_prime_embedding_sup_ident:
  assumes "S \<subseteq> \<J>"
  shows "S = \<lbrace> \<Squnion> S \<rbrace>"
proof -
  have "\<forall> s \<in> S. s \<in> \<J> \<and> s \<le> \<Squnion> S"
    using \<open>S \<subseteq> \<J>\<close> Sup_upper by auto
  hence "S \<subseteq> \<lbrace> \<Squnion> S \<rbrace>"
    unfolding join_prime_embedding_def
    by blast
  moreover
  {
    fix x
    assume "x \<in> \<J>"
           "x \<le> \<Squnion> S"
    have "\<exists> s \<in> S. x \<le> s"
    proof (rule ccontr)
      assume "\<not> (\<exists> s \<in> S. x \<le> s)"
      hence "\<forall> s \<in> S. x \<sqinter> s \<noteq> x"
        using inf.order_iff
        by auto
      moreover
      have "\<forall> s \<in> S. x \<sqinter> s \<le> x"
        by simp
      hence "\<forall> s \<in> S. x \<sqinter> s = \<bottom> \<or> x \<sqinter> s = x"
        using \<open>x \<in> \<J>\<close>
        unfolding join_primes_def
                  join_prime_def'
        by blast
      ultimately have "\<forall> s \<in> S. x \<sqinter> s = \<bottom>" by blast
      hence "x \<sqinter> \<Squnion> S = \<bottom>"
        by (simp add: inf_Sup)
      hence "x = \<bottom>"
        using \<open>x \<le> \<Squnion>S\<close> inf.order_iff by blast
      thus "False"
        using \<open>x \<in> \<J>\<close>
        unfolding join_primes_def
                  join_prime_def'
        by auto
    qed
    hence "\<exists> s \<in> S. x = s"
      using \<open>x \<in> \<J>\<close>
            \<open>S \<subseteq> \<J>\<close>
      unfolding join_primes_def
                join_prime_def'
      by auto
    hence "x \<in> S" by auto
  }
  hence "\<lbrace> \<Squnion> S \<rbrace> \<subseteq> S"
    unfolding join_prime_embedding_def
    by blast
  ultimately show ?thesis by auto
qed

text \<open> Given that \<open>\<lambda> x. \<lbrace> x \<rbrace>\<close> has a left and right inverse, we can show
       it is a \<^emph>\<open>bijection\<close>.  Every finite Boolean algebra is isomorphic
       to the powerset of its join prime elements. \<close>

text \<open> The bijection below is recognizable as a form of \<^emph>\<open>Birkoff's Theorem\<close>. \<close>

theorem (in finite_boolean_algebra) birkoffs_theorem:
  "bij_betw (\<lambda> x. \<lbrace> x \<rbrace>) UNIV (Pow \<J>)"
  unfolding bij_betw_def
proof
  {
    fix x y
    assume "\<lbrace> x \<rbrace> = \<lbrace> y \<rbrace>"
    hence "\<Squnion> \<lbrace> x \<rbrace> = \<Squnion> \<lbrace> y \<rbrace>"
      by simp
    hence "x = y"
      using sup_join_prime_embedding_ident
      by auto
  }
  thus "inj (\<lambda> x. \<lbrace> x \<rbrace>)"
    unfolding inj_def
    by auto
next
  show "range (\<lambda> x. \<lbrace> x \<rbrace>) = Pow \<J>"
  proof (intro equalityI subsetI)
    fix S
    assume "S \<in> range (\<lambda> x. \<lbrace> x \<rbrace>)"
    thus "S \<in> Pow \<J>"
      unfolding join_prime_embedding_def
                Pow_def
      by auto
  next
    fix S
    assume "S \<in> Pow \<J>"
    hence "\<exists> x. \<lbrace> x \<rbrace> = S"
      using join_prime_embedding_sup_ident
      by blast
    thus "S \<in> range (\<lambda> x. \<lbrace> x \<rbrace>)"
      by blast
  qed
qed

subsection \<open> Boolean Algebra Isomorphism \label{subsection:boolean-algebra-isomorphism} \<close>

text \<open> The form of Birkoff's theorem presented in \S\ref{subsection:birkoffs-theorem}
       simply gave a bijection between a finite Boolean algebra and the
       powerset of its join prime elements.  This relationship can be
       extended to a full-blown \<^emph>\<open>Boolean algebra isomorphism\<close>.  In particular
       we have the following properties:

       \<^item> \<open>\<bottom>\<close> and \<open>\<top>\<close> are preserved; in particular \<open>\<lbrace> \<bottom> \<rbrace> = {}\<close> and
         \<open>\<lbrace> \<top> \<rbrace> = \<J>\<close>.

       \<^item> \<open>\<lambda> x . \<lbrace> x \<rbrace>\<close> is a lower complete semi-lattice homomorphism, mapping
         \<open>\<lbrace> \<Squnion> X \<rbrace> = (\<Union> x \<in> X . \<lbrace> x \<rbrace>)\<close>.

       \<^item> In addition to preserving arbitrary joins, \<open>\<lambda> x . \<lbrace> x \<rbrace>\<close> is a
         lattice homomorphism, since it also preserves finitary meets with
         \<open> \<lbrace> x \<sqinter> y \<rbrace> = \<lbrace> x \<rbrace> \<inter> \<lbrace> y \<rbrace> \<close>.

       \<^item> Complementation corresponds to relative set complementation
         via \<open>\<lbrace> - x \<rbrace> = \<J> - \<lbrace> x \<rbrace>\<close>.

       \<^item> And finally order is preserved: \<open>x \<le> y = (\<lbrace> x \<rbrace> \<subseteq> \<lbrace> y \<rbrace>)\<close>
\<close>

lemma (in finite_boolean_algebra) join_primes_bot:
  "\<lbrace> \<bottom> \<rbrace> = {}"
  unfolding
    join_prime_embedding_def
    join_primes_def
    join_prime_def
  by (simp add: bot_unique)

lemma (in finite_boolean_algebra) join_primes_top:
  "\<lbrace> \<top> \<rbrace> = \<J>"
  unfolding
    join_prime_embedding_def
  by auto

lemma (in finite_boolean_algebra) join_primes_join_homomorphism:
  "\<lbrace> x \<squnion> y \<rbrace> = \<lbrace> x \<rbrace> \<union> \<lbrace> y \<rbrace>"
proof
  show "\<lbrace> x \<squnion> y \<rbrace> \<subseteq> \<lbrace> x \<rbrace> \<union> \<lbrace> y \<rbrace>"
    unfolding
      join_prime_embedding_def
      join_primes_def
      join_prime_def
    by blast
next
  show "\<lbrace> x \<rbrace> \<union> \<lbrace> y \<rbrace> \<subseteq> \<lbrace> x \<squnion> y \<rbrace>"
    unfolding
      join_prime_embedding_def
    using
      le_supI1
      sup.absorb_iff1
      sup.assoc
    by force
qed

lemma (in finite_boolean_algebra) join_primes_sup_homomorphism:
  "\<lbrace> \<Squnion> X \<rbrace> = (\<Union> x \<in> X . \<lbrace> x \<rbrace>)"
proof -
  have "finite X"
    by simp
  thus ?thesis
  proof (induct X rule: finite_induct)
    case empty
    then show ?case by (simp add: join_primes_bot)
  next
    case (insert x X)
    then show ?case by (simp add: join_primes_join_homomorphism)
  qed
qed

lemma (in finite_boolean_algebra) join_primes_meet_homomorphism:
  "\<lbrace> x \<sqinter> y \<rbrace> = \<lbrace> x \<rbrace> \<inter> \<lbrace> y \<rbrace>"
  unfolding
    join_prime_embedding_def
  by auto

text \<open> Arbitrary meets are also preserved, but relative to a top element
       \<open>\<J>\<close>.  Perhaps a means of subtyping the algebra of sets of join
       prime elements would allow us to avoid this epicycle, but that
       is tricky to execute.  We give a less elegant formulation here. \<close>

lemma (in finite_boolean_algebra) join_primes_inf_homomorphism:
  "\<lbrace> \<Sqinter> X \<rbrace> = \<J> \<inter> (\<Inter> x \<in> X. \<lbrace> x \<rbrace>)"
proof -
  have "finite X"
    by simp
  thus ?thesis
  proof (induct X rule: finite_induct)
    case empty
    then show ?case by (simp add: join_primes_top)
  next
    case (insert x X)
    then show ?case by (simp add: join_primes_meet_homomorphism, blast)
  qed
qed

lemma (in finite_boolean_algebra) join_primes_complement_homomorphism:
  "\<lbrace> - x \<rbrace> = \<J> - \<lbrace> x \<rbrace>"
proof
  show "\<lbrace> - x \<rbrace> \<subseteq> \<J> - \<lbrace> x \<rbrace>"
  proof
    fix j
    assume "j \<in> \<lbrace> - x \<rbrace>"
    hence "j \<notin> \<lbrace> x \<rbrace>"
      unfolding
        join_prime_embedding_def
        join_primes_def
        join_prime_def
      by (metis
            (mono_tags, lifting)
            CollectD
            bot_unique
            inf.boundedI
            inf_compl_bot)
    thus "j \<in> \<J> - \<lbrace> x \<rbrace>"
      using \<open>j \<in> \<lbrace> - x \<rbrace>\<close>
      unfolding
        join_prime_embedding_def
      by blast
  qed
next
  show "\<J> - \<lbrace> x \<rbrace> \<subseteq> \<lbrace> - x \<rbrace>"
  proof
    fix j
    assume "j \<in> \<J> - \<lbrace> x \<rbrace>"
    hence "j \<in> \<J>" and "\<not> j \<le> x"
      unfolding join_prime_embedding_def
      by blast+
    moreover have "j \<le> x \<squnion> -x"
      by auto
    ultimately have "j \<le> -x"
      unfolding
        join_primes_def
        join_prime_def
      by blast
    thus "j \<in> \<lbrace> - x \<rbrace>"
      unfolding join_prime_embedding_def
      using \<open>j \<in> \<J>\<close>
      by auto
  qed
qed

lemma (in finite_boolean_algebra) join_primes_order_isomorphism:
  "x \<le> y = (\<lbrace> x \<rbrace> \<subseteq> \<lbrace> y \<rbrace>)"
  by (
    rule iffI,
    simp add: Collect_mono dual_order.trans join_prime_embedding_def,
    metis
      (full_types)
      Sup_subset_mono
      sup_join_prime_embedding_ident)

subsection \<open> Cardinality \<close>

text \<open> Another consequence of Birkoff's theorem from \S\ref{subsection:birkoffs-theorem}
       is that we can show every finite Boolean algebra has a cardinality
       which is a power of two.  This gives a bound on the number of join
       prime elements, which must be logarithmic in the size of the finite
       Boolean algebra they belong to. \<close>

lemma (in finite_boolean_algebra) UNIV_card:
  "card (UNIV::'a set) = card (Pow \<J>)"
  using bij_betw_same_card [where f="\<lambda>x. \<lbrace> x \<rbrace>"]
        birkoffs_theorem
  by blast

lemma finite_Pow_card:
  assumes "finite X"
  shows "card (Pow X) = 2 powr (card X)"
  using assms
proof (induct X rule: finite_induct)
  case empty
  then show ?case by fastforce
next
  case (insert x X)
  have "0 \<le> (2 :: real)" by auto
  hence two_powr_one: "(2 :: real) = 2 powr 1" by fastforce
  have "bij_betw (\<lambda> x. fst x \<union> snd x) ({{},{x}} \<times> Pow X) (Pow (insert x X))"
    unfolding bij_betw_def
  proof
    {
      fix y z
      assume "y \<in> {{}, {x}} \<times> Pow X"
             "z \<in> {{}, {x}} \<times> Pow X"
             "fst y \<union> snd y = fst z \<union> snd z"
             (is "?Uy = ?Uz")
      hence "x \<notin> snd y"
            "x \<notin> snd z"
            "fst y = {x} \<or> fst y = {}"
            "fst z = {x} \<or> fst z = {}"
        using insert.hyps(2) by auto
      hence "x \<in> ?Uy \<longleftrightarrow> fst y = {x}"
            "x \<in> ?Uz \<longleftrightarrow> fst z = {x}"
            "x \<notin> ?Uy \<longleftrightarrow> fst y = {}"
            "x \<notin> ?Uz \<longleftrightarrow> fst z = {}"
            "snd y = ?Uy - {x}"
            "snd z = ?Uz - {x}"
        by auto
      hence "x \<in> ?Uy \<longleftrightarrow> y = ({x}, ?Uy - {x})"
            "x \<in> ?Uz \<longleftrightarrow> z = ({x}, ?Uz - {x})"
            "x \<notin> ?Uy \<longleftrightarrow> y = ({}, ?Uy - {x})"
            "x \<notin> ?Uz \<longleftrightarrow> z = ({}, ?Uz - {x})"
        by (metis fst_conv prod.collapse)+
      hence "y = z"
        using \<open>?Uy = ?Uz\<close>
        by metis
    }
    thus "inj_on (\<lambda>x. fst x \<union> snd x) ({{}, {x}} \<times> Pow X)"
      unfolding inj_on_def
      by auto
  next
    show "(\<lambda>x. fst x \<union> snd x) ` ({{}, {x}} \<times> Pow X) = Pow (insert x X)"
    proof (intro equalityI subsetI)
      fix y
      assume "y \<in> (\<lambda>x. fst x \<union> snd x) ` ({{}, {x}} \<times> Pow X)"
      from this obtain z where
        "z \<in> ({{}, {x}} \<times> Pow X)"
        "y = fst z \<union> snd z"
        by auto
      hence "snd z \<subseteq> X"
            "fst z \<subseteq> insert x X"
        using SigmaE by auto
      thus "y \<in> Pow (insert x X)"
        using \<open>y = fst z \<union> snd z\<close> by blast
    next
      fix y
      assume "y \<in> Pow (insert x X)"
      let ?z = "(if x \<in> y then {x} else {}, y - {x})"
      have "?z \<in> ({{}, {x}} \<times> Pow X)"
        using \<open>y \<in> Pow (insert x X)\<close> by auto
      moreover have "(\<lambda>x. fst x \<union> snd x) ?z = y"
        by auto
      ultimately show "y \<in> (\<lambda>x. fst x \<union> snd x) ` ({{}, {x}} \<times> Pow X)"
        by blast
    qed
  qed
  hence "card (Pow (insert x X)) = card ({{},{x}} \<times> Pow X)"
    using bij_betw_same_card by fastforce
  also have "\<dots> = 2 * card (Pow X)"
    by (simp add: insert.hyps(1))
  also have "\<dots> = 2 * (2 powr (card X))"
    by (simp add: insert.hyps(3))
  also have "\<dots> = (2 powr 1) * 2 powr (card X)"
    using two_powr_one
    by fastforce
  also have "\<dots> = 2 powr (1 + card X)"
    by (simp add: powr_add)
  also have "\<dots> = 2 powr (card (insert x X))"
    by (simp add: insert.hyps(1) insert.hyps(2))
  finally show ?case .
qed

lemma (in finite_boolean_algebra) UNIV_card_powr_2:
  "card (UNIV::'a set) = 2 powr (card \<J>)"
  using finite [of \<J>]
        finite_Pow_card [of \<J>]
        UNIV_card
  by linarith

lemma (in finite_boolean_algebra) join_primes_card_log_2:
  "card \<J> = log 2 (card (UNIV :: 'a set))"
proof (cases "card (UNIV :: 'a set) = 1")
  case True
  hence "\<exists> x :: 'a. UNIV = {x}"
    using card_1_singletonE by blast
  hence "\<forall> x y :: 'a. x \<in> UNIV \<longrightarrow> y \<in> UNIV \<longrightarrow> x = y"
    by (metis (mono_tags) singletonD)
  hence "\<forall> x y :: 'a. x = y"
    by blast
  hence "\<forall> x. x = \<bottom>"
    by blast
  hence "\<J> = {}"
    unfolding join_primes_def
              join_prime_def
    by blast
  hence "card \<J> = (0 :: real)"
    by simp
  moreover
  have "log 2 (card (UNIV :: 'a set)) = 0"
    by (simp add: True)
  ultimately show ?thesis by auto
next
  case False
  hence "0 < 2 powr (card \<J>)" "2 powr (card \<J>) \<noteq> 1"
    using finite_UNIV_card_ge_0 finite UNIV_card_powr_2
    by (simp, linarith)
  hence "log 2 (2 powr (card \<J>)) = card \<J>"
    by simp
  then show ?thesis
    using UNIV_card_powr_2
    by simp
qed

end


section\<open>Negation Type DNF\<close>
theory Negation_Type_DNF
imports Negation_Type
begin

(*Just a draft. needed for packet_set*)

type_synonym 'a dnf = "(('a negation_type) list) list"

fun cnf_to_bool :: "('a \<Rightarrow> bool) \<Rightarrow> 'a negation_type list \<Rightarrow> bool" where
  "cnf_to_bool _ [] \<longleftrightarrow> True" |
  "cnf_to_bool f (Pos a#as) \<longleftrightarrow> (f a) \<and> cnf_to_bool f as" |
  "cnf_to_bool f (Neg a#as) \<longleftrightarrow> (\<not> f a) \<and> cnf_to_bool f as"

fun dnf_to_bool :: "('a \<Rightarrow> bool) \<Rightarrow> 'a dnf \<Rightarrow> bool" where
  "dnf_to_bool _ [] \<longleftrightarrow> False" |
  "dnf_to_bool f (as#ass) \<longleftrightarrow> (cnf_to_bool f as) \<or> (dnf_to_bool f ass)"

text\<open>representing @{const True}\<close>
definition dnf_True :: "'a dnf" where
  "dnf_True \<equiv> [[]]"

text\<open>representing @{const False}\<close>
definition dnf_False :: "'a dnf" where
  "dnf_False \<equiv> []"
lemma dnf_False: "\<not> dnf_to_bool f dnf_False"
  unfolding dnf_False_def by(simp)

lemma cnf_to_bool_append: "cnf_to_bool \<gamma> (a1 @ a2) \<longleftrightarrow> cnf_to_bool \<gamma> a1 \<and> cnf_to_bool \<gamma> a2"
  by(induction \<gamma> a1 rule: cnf_to_bool.induct) (simp_all)
lemma dnf_to_bool_append: "dnf_to_bool \<gamma> (a1 @ a2) \<longleftrightarrow> dnf_to_bool \<gamma> a1 \<or> dnf_to_bool \<gamma> a2"
  by(induction a1) (simp_all)

definition dnf_and :: "'a dnf \<Rightarrow> 'a dnf \<Rightarrow> 'a dnf" where
  "dnf_and cnf1 cnf2 = [andlist1 @ andlist2. andlist1 <- cnf1, andlist2 <- cnf2]"

value "dnf_and ([[a,b], [c,d]]) ([[v,w], [x,y]])"

lemma cnf_to_bool_set: "cnf_to_bool f cnf \<longleftrightarrow> (\<forall> c \<in> set cnf. (case c of Pos a \<Rightarrow> f a | Neg a \<Rightarrow> \<not> f a))"
  proof(induction cnf)
  case Nil thus ?case by simp
  next
  case Cons thus ?case by (simp split: negation_type.split)
  qed
lemma dnf_to_bool_set: "dnf_to_bool \<gamma> dnf \<longleftrightarrow> (\<exists> d \<in> set dnf. cnf_to_bool \<gamma> d)"
  proof(induction dnf)
  case Nil thus ?case by simp
  next
  case (Cons d d1) thus ?case by(simp)
  qed

lemma dnf_to_bool_seteq: "set ` set d1 = set ` set d2 \<Longrightarrow> dnf_to_bool \<gamma> d1 \<longleftrightarrow> dnf_to_bool \<gamma> d2"
  proof -
    assume assm: "set ` set d1 = set ` set d2"
    have helper1: "\<And>P d. (\<exists>d\<in>set d. \<forall>c\<in>set d. P c) \<longleftrightarrow> (\<exists>d\<in>set ` set d. \<forall>c\<in>d. P c)" by blast
    from assm show ?thesis
      apply(simp add: dnf_to_bool_set cnf_to_bool_set)
      apply(subst helper1)
      apply(subst helper1)
      apply(simp)
      done
  qed

lemma dnf_and_correct: "dnf_to_bool \<gamma> (dnf_and d1 d2) \<longleftrightarrow> dnf_to_bool \<gamma> d1 \<and> dnf_to_bool \<gamma> d2"
 apply(simp add: dnf_and_def)
 apply(induction d1)
  apply(simp)
 apply(simp add: dnf_to_bool_append)
 apply(simp add: dnf_to_bool_set cnf_to_bool_set)
 by (meson UnCI UnE)

subsubsection\<open>inverting a DNF\<close>
  text\<open>Example\<close>
  lemma "(\<not> ((a1 \<and> a2) \<or> b \<or> c)) = ((\<not>a1 \<and> \<not> b \<and> \<not> c) \<or> (\<not>a2 \<and> \<not> b \<and> \<not> c))" by blast
  lemma "(\<not> ((a1 \<and> a2) \<or> (b1 \<and> b2) \<or> c)) = ((\<not>a1 \<and> \<not> b1 \<and> \<not> c) \<or> (\<not>a2 \<and> \<not> b1 \<and> \<not> c) \<or> (\<not>a1 \<and> \<not> b2 \<and> \<not> c) \<or> (\<not>a2 \<and> \<not> b2 \<and> \<not> c))" by blast

  fun listprepend :: "'a list \<Rightarrow> 'a list list \<Rightarrow> 'a list list" where
    "listprepend [] ns = []" |
    "listprepend (a#as) ns = (map (\<lambda>xs. a#xs) ns) @ (listprepend as ns)"

  lemma "listprepend [a,b] [as, bs] = [a#as, a#bs, b#as, b#bs]" by simp

  lemma map_a_and: "dnf_to_bool \<gamma> (map (op # a) ds) \<longleftrightarrow> dnf_to_bool \<gamma> [[a]] \<and> dnf_to_bool \<gamma> ds"
    apply(induction ds)
     apply(simp_all)
    apply(case_tac a)
     apply(simp_all)
     apply blast+
    done

  text\<open>this is how @{const listprepend} works:\<close>
  lemma "\<not> dnf_to_bool \<gamma> (listprepend [] ds)" by(simp)
  lemma "dnf_to_bool \<gamma> (listprepend [a] ds) \<longleftrightarrow> dnf_to_bool \<gamma> [[a]] \<and> dnf_to_bool \<gamma> ds" by(simp add: map_a_and)
  lemma "dnf_to_bool \<gamma> (listprepend [a, b] ds) \<longleftrightarrow> (dnf_to_bool \<gamma> [[a]] \<and> dnf_to_bool \<gamma> ds) \<or> (dnf_to_bool \<gamma> [[b]] \<and> dnf_to_bool \<gamma> ds)"
    by(simp add: map_a_and dnf_to_bool_append)

  text\<open>We use @{text "\<exists>"} to model the big @{text "\<or>"} operation\<close>
  lemma listprepend_correct: "dnf_to_bool \<gamma> (listprepend as ds) \<longleftrightarrow> (\<exists>a\<in> set as. dnf_to_bool \<gamma> [[a]] \<and> dnf_to_bool \<gamma> ds)"
    apply(induction as)
     apply(simp)
    apply(simp)
    apply(rename_tac a as)
    apply(simp add: map_a_and cnf_to_bool_append dnf_to_bool_append)
    by blast
  lemma listprepend_correct': "dnf_to_bool \<gamma> (listprepend as ds) \<longleftrightarrow> (dnf_to_bool \<gamma> (map (\<lambda>a. [a]) as) \<and> dnf_to_bool \<gamma> ds)"
    apply(induction as)
     apply(simp)
    apply(simp)
    apply(rename_tac a as)
    apply(simp add: map_a_and cnf_to_bool_append dnf_to_bool_append)
    by blast

  lemma cnf_invert_singelton: "cnf_to_bool \<gamma> [invert a] \<longleftrightarrow> \<not> cnf_to_bool \<gamma> [a]" by(cases a, simp_all)

  lemma cnf_singleton_false: "(\<exists>a'\<in>set as. \<not> cnf_to_bool \<gamma> [a']) \<longleftrightarrow> \<not> cnf_to_bool \<gamma> as"
    by(induction \<gamma> as rule: cnf_to_bool.induct) (simp_all)

  fun dnf_not :: "'a dnf \<Rightarrow> 'a dnf" where
    "dnf_not [] = [[]]" | (*False goes to True*)
    "dnf_not (ns#nss) = listprepend (map invert ns) (dnf_not nss)"

  lemma dnf_not: "dnf_to_bool \<gamma> (dnf_not d) \<longleftrightarrow> \<not> dnf_to_bool \<gamma> d"
    apply(induction d)
     apply(simp_all)
    apply(simp add: listprepend_correct)
    apply(simp add: cnf_invert_singelton cnf_singleton_false)
    done

subsubsection\<open>Optimizing\<close>
  (*there is probably a way better way to represent the set in the Collection framework
    A list of lists can be quite inefficient
    A better datastructure can help as we actually only use a set of sets*)
  definition optimize_dfn :: "'a dnf \<Rightarrow> 'a dnf" where
    "optimize_dfn dnf = map remdups (remdups dnf)"

  lemma "dnf_to_bool f (optimize_dfn dnf) = dnf_to_bool f dnf"
    unfolding optimize_dfn_def
    apply(rule dnf_to_bool_seteq)
    apply(simp)
    by (metis image_cong image_image set_remdups)

end


theory PALandWiseMenPuzzle2021_New imports Main    (* Sebastian Reiche and Christoph Benzmüller, 2021 *)

begin
 (* Parameter settings for Nitpick *) nitpick_params[user_axioms=true, format=4, show_all]

 typedecl i (* Type of possible worlds *)
 type_synonym \<sigma> = "i\<Rightarrow>bool" (* \<D> *)
 type_synonym \<tau> = "\<sigma>\<Rightarrow>i\<Rightarrow>bool" (* Type of world depended formulas (truth sets) *)
 type_synonym \<alpha> = "i\<Rightarrow>i\<Rightarrow>bool" (* Type of accessibility relations between world *)

 (* Some useful relations (for constraining accessibility relations) *)
 definition reflexive::"\<alpha>\<Rightarrow>bool" where "reflexive R \<equiv> \<forall>x. R x x"
 definition symmetric::"\<alpha>\<Rightarrow>bool" where "symmetric R \<equiv> \<forall>x y. R x y \<longrightarrow> R y x"
 definition transitive::"\<alpha>\<Rightarrow>bool" where "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
 definition euclidean::"\<alpha>\<Rightarrow>bool" where "euclidean R \<equiv> \<forall>x y z. R x y \<and> R x z \<longrightarrow> R y z"
 definition intersection_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>\<alpha>" where "intersection_rel R Q \<equiv> \<lambda>u v. R u v \<and> Q u v"
 definition union_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>\<alpha>" where "union_rel R Q \<equiv> \<lambda>u v. R u v \<or> Q u v"
 definition sub_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"
 definition inverse_rel::"\<alpha>\<Rightarrow>\<alpha>" where "inverse_rel R \<equiv> \<lambda>u v. R v u"
 definition bigunion_rel::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<alpha>" ("\<^bold>\<Union>_") where "\<^bold>\<Union> X \<equiv> \<lambda>u v. \<exists>R. (X R) \<and> (R u v)"
 definition bigintersection_rel::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<alpha>" ("\<^bold>\<Inter>_") where "\<^bold>\<Inter> X \<equiv> \<lambda>u v. \<forall>R. (X R) \<longrightarrow> (R u v)"

 (*In HOL the transitive closure of a relation can be defined in a single line.*)
 definition tc::"\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"

 (* Lifted HOMML connectives for PAL *)
 abbreviation patom::"\<sigma>\<Rightarrow>\<tau>" ("\<^sup>A_"[79]80) where "\<^sup>Ap \<equiv> \<lambda>W w. W w \<and> p w"
 abbreviation ptop::"\<tau>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>W w. True"
 abbreviation pneg::"\<tau>\<Rightarrow>\<tau>" ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>W w. \<not>(\<phi> W w)"
 abbreviation pand::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<and> (\<psi> W w)"
 abbreviation por::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<or> (\<psi> W w)"
 abbreviation pimp::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longrightarrow> (\<psi> W w)"
 abbreviation pequ::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longleftrightarrow> (\<psi> W w)"
 abbreviation pknow::"\<alpha>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>K_ _") where "\<^bold>K r \<phi> \<equiv> \<lambda>W w.\<forall>v. (W v \<and> r w v) \<longrightarrow> (\<phi> W v)"
 abbreviation ppal::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>[\<^bold>!_\<^bold>]_") where "\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longrightarrow> (\<psi> (\<lambda>z. W z \<and> \<phi> W z) w)"

 (* Validity of \<tau>-type lifted PAL formulas *)
 abbreviation pvalid::"\<tau> \<Rightarrow> bool" ("\<^bold>\<lfloor>_\<^bold>\<rfloor>"[7]8) where "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor> \<equiv> \<forall>W.\<forall>w. W w \<longrightarrow> \<phi> W w"

 (* Agent Knowledge, Mutual Knowledge, Common Knowledge *)
 abbreviation "EVR A \<equiv> \<^bold>\<Union> A"
 abbreviation "DIS A \<equiv> \<^bold>\<Inter> A"
 abbreviation agttknows::"\<alpha>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>K\<^sub>_ _") where "\<^bold>K\<^sub>r \<phi> \<equiv>  \<^bold>K r \<phi>"
 abbreviation evrknows::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>E\<^sub>_ _") where "\<^bold>E\<^sub>A \<phi> \<equiv>  \<^bold>K (EVR A) \<phi>"
 abbreviation prck::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>C\<^sub>_\<^bold>\<lparr>_\<^bold>|_\<^bold>\<rparr>")
   where "\<^bold>C\<^sub>A\<^bold>\<lparr>\<phi>\<^bold>|\<psi>\<^bold>\<rparr> \<equiv> \<lambda>W w. \<forall>v. \<not>(tc (intersection_rel (EVR A) (\<lambda>u v. W v \<and> \<phi> W v)) w v) \<or> (\<psi> W v)"
 abbreviation pcmn::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>C\<^sub>_ _") where "\<^bold>C\<^sub>A \<phi> \<equiv>  \<^bold>C\<^sub>A\<^bold>\<lparr>\<^bold>\<top>\<^bold>|\<phi>\<^bold>\<rparr>"
 abbreviation disknows :: "(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>D\<^sub>_ _") where "\<^bold>D\<^sub>A \<phi> \<equiv> \<^bold>K (DIS A) \<phi>"

 (* Introducing "Defs" as the set of the above definitions; useful for convenient unfolding *)
 named_theorems Defs
 declare reflexive_def[Defs] symmetric_def[Defs] transitive_def[Defs] euclidean_def[Defs]
   intersection_rel_def[Defs] union_rel_def[Defs] sub_rel_def[Defs] inverse_rel_def[Defs]
   bigunion_rel_def[Defs] tc_def[Defs]

 (***********************************************************************************************)
 (*****                         Experiments                                                 *****)
 (***********************************************************************************************)
 (*Some useful lemmata *)
 lemma trans_tc: "transitive (tc R)" unfolding Defs by metis
 lemma trans_inv_tc: "transitive (inverse_rel (tc R))" unfolding Defs by metis
 lemma sub_rel_tc: "symmetric R \<longrightarrow> (sub_rel R (inverse_rel (tc R)))" unfolding Defs by smt
 lemma sub_rel_tc_tc: "symmetric R \<longrightarrow> (sub_rel (tc R) (inverse_rel (tc R)))"
   using sub_rel_def sub_rel_tc tc_def trans_inv_tc by fastforce
 lemma symm_tc: "symmetric R \<longrightarrow> symmetric (tc R)"
   using inverse_rel_def sub_rel_def sub_rel_tc_tc symmetric_def by auto

 (* System K: is implied by the semantical embedding *)
 lemma tautologies: "\<^bold>\<lfloor>\<^bold>\<top>\<^bold>\<rfloor>" by auto
 lemma axiom_K: "\<A> i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>i (\<phi> \<^bold>\<rightarrow> \<psi>)) \<^bold>\<rightarrow> ((\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> (\<^bold>K\<^sub>i \<psi>))\<^bold>\<rfloor>" by auto
 lemma modusponens: assumes 1: "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<psi>\<^bold>\<rfloor>" and 2: "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<^bold>\<lfloor>\<psi>\<^bold>\<rfloor>" using 1 2 by auto
 lemma necessitation: assumes 1: "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<A> i \<Longrightarrow> \<^bold>\<lfloor>\<^bold>K\<^sub>i \<phi>\<^bold>\<rfloor>" using 1 by auto
 (* More axioms: implied by the semantical embedding  *)
 lemma axiom_T: "reflexive i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> \<phi>\<^bold>\<rfloor>" using reflexive_def by auto
 lemma axiom_4: "transitive i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> (\<^bold>K\<^sub>i (\<^bold>K\<^sub>i \<phi>))\<^bold>\<rfloor>" using transitive_def by meson
 lemma axiom_5: "euclidean i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>\<not>\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> (\<^bold>K\<^sub>i (\<^bold>\<not>\<^bold>K\<^sub>i \<phi>))\<^bold>\<rfloor>" using euclidean_def by meson
 (*Reduction axioms: implied by the semantical embedding *)
 lemma atomic_permanence: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>]\<^sup>Ap) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> \<^sup>Ap)\<^bold>\<rfloor>" by auto
 lemma conjunction: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>](\<psi> \<^bold>\<and> \<chi>)) \<^bold>\<rightarrow> ((\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>) \<^bold>\<and> (\<^bold>[\<^bold>!\<phi>\<^bold>]\<chi>))\<^bold>\<rfloor>" by auto
 lemma part_func: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>]\<^bold>\<not>\<psi>) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> (\<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>))\<^bold>\<rfloor>" by auto
 lemma action_knowledge: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>K\<^sub>i \<psi>)) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> (\<^bold>K\<^sub>i (\<phi> \<^bold>\<rightarrow> (\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>))))\<^bold>\<rfloor>" by auto
 lemma "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<psi>\<^bold>\<rparr>)) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<phi>\<^bold>\<and>(\<^bold>[\<^bold>!\<phi>\<^bold>]\<chi>)\<^bold>|\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>\<^bold>\<rparr>))\<^bold>\<rfloor>"
   by (smt intersection_rel_def sub_rel_def tc_def transitive_def)

 declare [[smt_solver=cvc4,smt_oracle]]

 abbreviation "S5Agent i \<equiv> reflexive i \<and> transitive i \<and> euclidean i"
 abbreviation "S5Agents A \<equiv> \<forall>i. (A i \<longrightarrow> S5Agent i)"

 (* Axiom schemes for RCK: implied by the semantical embedding *)
 lemma \<C>_normality: "\<^bold>\<lfloor>\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rightarrow>\<psi>\<^bold>\<rparr> \<^bold>\<rightarrow>(\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr> \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<psi>\<^bold>\<rparr>)\<^bold>\<rfloor>" unfolding Defs by blast

 lemma mix_axiom1: "\<^bold>\<lfloor>\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr> \<^bold>\<rightarrow> \<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))\<^bold>\<rfloor>" unfolding Defs by smt

 lemma mix_axiom2': "A = (\<lambda>x. False) \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))) \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
  unfolding Defs by (metis (full_types))
 lemma mix_axiom2'': "A = (\<lambda>x. True) \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))) \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
  unfolding Defs by (metis (full_types)) (* takes long *)
 lemma mix_axiom2''': "A = (\<lambda>x. x = a) \<and> S5Agent a \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))) \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
  unfolding Defs  (* sledgehammer finds proof, but reconstruction times✕out *) oops
 lemma mix_axiom2'''': "A = (\<lambda>x. x = a \<or> x = b) \<and> S5Agent a  \<and> S5Agent b \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))) \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
  unfolding Defs (* sledgehammer and nitpick timeout *) oops
 lemma mix_axiom2_general: "\<^bold>\<lfloor>(\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))) \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>" unfolding Defs  (* timeout *) oops

 lemma induction_axiom': "A = (\<lambda>x. False) \<Longrightarrow> \<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
  unfolding Defs by (metis (full_types))
 lemma induction_axiom'': "A = (\<lambda>x. True) \<Longrightarrow> \<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
  unfolding Defs  (* sledgehammer finds proof, but reconstruction times✕out *) oops
 lemma induction_axiom''': "A = (\<lambda>x. x = a)  \<and> S5Agent a  \<Longrightarrow> \<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
  unfolding Defs  (* sledgehammer finds proof, but reconstruction times✕out *) oops
 lemma induction_axiom'''': "A = (\<lambda>x. x = a \<or> x = b) \<and> S5Agent a  \<and> S5Agent b  \<Longrightarrow> \<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
   unfolding Defs (* sledgehammer and nitpick timeout *) oops
 lemma induction_axiom_general: "\<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
   unfolding Defs (* sledgehammer and nitpick timeout *) oops

 (* Necessitation rules: implied by the semantical embedding *)
 lemma announcement_nec: assumes "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<psi>\<^bold>]\<phi>\<^bold>\<rfloor>" by (simp add: assms)
 lemma rkc_necessitation: assumes "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<^bold>\<lfloor>(\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
   by (smt assms intersection_rel_def sub_rel_def tc_def transitive_def)

 (* Further axioms: implied for atomic formulas, but not implied in general *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>a \<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>a \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>r \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>(\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap\<^bold>](\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap)\<^bold>\<rfloor>" by blast
 lemma "\<^bold>\<lfloor>(\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<phi>\<^bold>](\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "S5Agent r \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>r \<^sup>Ap) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap)\<^bold>\<rfloor>" using reflexive_def by auto
 lemma "S5Agent r \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>r \<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>r \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "S5Agent r \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>r \<^sup>Ap) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap)\<^bold>\<rfloor>" using  reflexive_def by auto
 lemma "S5Agent r \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>r \<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)

 (* Further checks on the atomic versus general validity. *)

 lemma "\<^bold>\<lfloor>p \<^bold>\<leftrightarrow> q\<^bold>\<rfloor> \<Longrightarrow> \<forall>W v. (p W v \<longleftrightarrow> q W v)" unfolding Defs nitpick oops (* countermodel *)
 lemma "\<forall>W v. (p W v \<longleftrightarrow> q W v) \<Longrightarrow> \<^bold>\<lfloor>p \<^bold>\<leftrightarrow> q\<^bold>\<rfloor>" unfolding Defs by simp
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<leftrightarrow> \<^sup>Aq\<^bold>\<rfloor> \<Longrightarrow> \<forall>v. (p v \<longleftrightarrow> q v)" unfolding Defs by simp
 lemma "\<forall>v. (p v \<longleftrightarrow> q v) \<Longrightarrow> \<^bold>\<lfloor>\<^sup>Ap \<^bold>\<leftrightarrow> \<^sup>Aq\<^bold>\<rfloor>" unfolding Defs by simp

 (* Concrete models can be defined and studied (check requested by a reviewer). *)

 lemma assumes "W = (\<lambda>x. x = w1 \<or> x = w2 \<or> x = w3)" "w1 \<noteq> w2" "w1 \<noteq> w3" "w2 \<noteq> w3"
               "p W w1" "p W w2" "\<not>(p W w3)"
               "a w1 w1" "a w1 w2" "(a w2 w1)" "a w2 w2" "\<not>(a w1 w3)" "\<not>(a w3 w1)" "\<not>(a w2 w3)" "\<not>(a w3 w2)" "a w3 w3"
               "b w1 w1" "\<not>(b w1 w2)" "\<not>(b w2 w1)" "b w2 w2" "\<not>(b w1 w3)" "\<not>(b w3 w1)" "b w2 w3" "b w3 w2" "b w3 w3"
       shows "((p \<^bold>\<and> (\<^bold>K\<^sub>a p) \<^bold>\<and> (\<^bold>K\<^sub>b p)) \<^bold>\<and> \<^bold>\<not>(\<^bold>K\<^sub>a (\<^bold>K\<^sub>b p))) W w1"
   unfolding Defs
     nitpick[satisfy,atoms=w1 w2 w3] (* model *)
     using assms(1) assms(12) assms(21) assms(23) assms(5) assms(6) assms(7) assms(9) by blast (* proof *)

 (***********************************************************************************************)
 (*****                         Wise Men Puzzle                                             *****)
 (***********************************************************************************************)
 (*** Encoding of the wise men puzzle in PAL ***)
 (* Agents *)
 consts a::"\<alpha>" b::"\<alpha>" c::"\<alpha>" (* Agents modeled as accessibility relations *)
 abbreviation  Agent::"\<alpha>\<Rightarrow>bool" ("\<A>") where "\<A> x \<equiv> x = a \<or> x = b \<or> x = c"
 axiomatization where  group_S5: "S5Agents \<A>"

 (* Common knowledge: At least one of a, b and c has a white spot *)
 consts ws::"\<alpha>\<Rightarrow>\<sigma>"
 axiomatization where WM1: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^sup>Aws a \<^bold>\<or> \<^sup>Aws b \<^bold>\<or> \<^sup>Aws c)\<^bold>\<rfloor>"

 axiomatization where
   (* Common knowledge: If x does not have a white spot then y know this *)
   WM2ab: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
   WM2ac: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
   WM2ba: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
   WM2bc: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
   WM2ca: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>" and
   WM2cb: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>"

 (* Positive introspection principles are implied *)
 lemma WM2ab': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^sup>Aws a)))\<^bold>\<rfloor>" using WM2ab group_S5 unfolding Defs by metis
 lemma WM2ac': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^sup>Aws a)))\<^bold>\<rfloor>" using WM2ac group_S5 unfolding Defs by metis
 lemma WM2ba': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^sup>Aws b)))\<^bold>\<rfloor>" using WM2ba group_S5 unfolding Defs by metis
 lemma WM2bc': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^sup>Aws b)))\<^bold>\<rfloor>" using WM2bc group_S5 unfolding Defs by metis
 lemma WM2ca': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^sup>Aws c)))\<^bold>\<rfloor>" using WM2ca group_S5 unfolding Defs by metis
 lemma WM2cb': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^sup>Aws c)))\<^bold>\<rfloor>" using WM2cb group_S5 unfolding Defs by metis

 (* Automated solutions of the Wise Men Puzzle *)
 theorem whitespot_c_1: "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>a(\<^sup>Aws a)\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>b(\<^sup>Aws b)\<^bold>](\<^bold>K\<^sub>c (\<^sup>Aws c)))\<^bold>\<rfloor>"
   using WM1 WM2ba WM2ca WM2cb unfolding Defs by (smt (verit))

 theorem whitespot_c_2:
   "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>a (\<^sup>Aws a)) \<^bold>\<or> (\<^bold>K\<^sub>a (\<^bold>\<not>\<^sup>Aws a)))\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>b (\<^sup>Aws b)) \<^bold>\<or> (\<^bold>K\<^sub>b (\<^bold>\<not>\<^sup>Aws b)))\<^bold>](\<^bold>K\<^sub>c (\<^sup>Aws c)))\<^bold>\<rfloor>"
   using WM1 WM2ba WM2ca WM2cb unfolding Defs by (smt (verit))

 (* Consistency confirmed by nitpick *)
 lemma True nitpick [satisfy,show_all] oops  (* model found *)
end


(* Title:      Boolean N-Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Boolean N-Semirings\<close>

theory N_Semirings_Boolean

imports N_Semirings

begin

class an =
  fixes an :: "'a \<Rightarrow> 'a"

class an_semiring = bounded_idempotent_left_zero_semiring + L + n + an + uminus +
  assumes an_complement: "an(x) \<squnion> n(x) = 1"
  assumes an_dist_sup  : "an(x \<squnion> y) = an(x) * an(y)"
  assumes an_export    : "an(an(x) * y) = n(x) \<squnion> an(y)"
  assumes an_mult_zero : "an(x) = an(x * bot)"
  assumes an_L_split   : "x * n(y) * L = x * bot \<squnion> n(x * y) * L"
  assumes an_split     : "an(x * L) * x \<le> x * bot"
  assumes an_uminus    : "-x = an(x * L)"
begin

text \<open>Theorem 21\<close>

lemma n_an_def:
  "n(x) = an(an(x) * L)"
  by (metis an_dist_sup an_export an_split bot_least mult_right_isotone semiring.add_nonneg_eq_0_iff sup.orderE top_greatest vector_bot_closed)

text \<open>Theorem 21\<close>

lemma an_complement_bot:
  "an(x) * n(x) = bot"
  by (metis an_dist_sup an_split bot_least le_iff_sup mult_left_zero sup_commute n_an_def)

text \<open>Theorem 21\<close>

lemma an_n_def:
  "an(x) = n(an(x) * L)"
  by (smt (verit, ccfv_threshold) an_complement_bot an_complement mult.right_neutral mult_left_dist_sup mult_right_dist_sup sup_commute n_an_def)

lemma an_case_split_left:
  "an(z) * x \<le> y \<and> n(z) * x \<le> y \<longleftrightarrow> x \<le> y"
  by (metis le_sup_iff an_complement mult_left_one mult_right_dist_sup)

lemma an_case_split_right:
  "x * an(z) \<le> y \<and> x * n(z) \<le> y \<longleftrightarrow> x \<le> y"
  by (metis le_sup_iff an_complement mult_1_right mult_left_dist_sup)

lemma split_sub:
  "x * y \<le> z \<squnion> x * top"
  by (simp add: le_supI2 mult_right_isotone)

text \<open>Theorem 21\<close>

subclass n_semiring
  apply unfold_locales
  apply (metis an_dist_sup an_split mult_left_zero sup.absorb2 sup_bot_left sup_commute n_an_def)
  apply (metis sup_left_top an_complement an_dist_sup an_export mult_assoc n_an_def)
  apply (metis an_dist_sup an_export mult_assoc n_an_def)
  apply (metis an_dist_sup an_export an_n_def mult_right_dist_sup n_an_def)
  apply (metis sup_idem an_dist_sup an_mult_zero n_an_def)
  apply (simp add: an_L_split)
  by (meson an_case_split_left an_split le_supI1 split_sub)

lemma n_complement_bot:
  "n(x) * an(x) = bot"
  by (metis an_complement_bot an_n_def n_an_def)

lemma an_bot:
  "an(bot) = 1"
  by (metis sup_bot_right an_complement n_bot)

lemma an_one:
  "an(1) = 1"
  by (metis sup_bot_right an_complement n_one)

lemma an_L:
  "an(L) = bot"
  using an_one n_one n_an_def by auto

lemma an_top:
  "an(top) = bot"
  by (metis mult_left_one n_complement_bot n_top)

lemma an_export_n:
  "an(n(x) * y) = an(x) \<squnion> an(y)"
  by (metis an_export an_n_def n_an_def)

lemma n_export_an:
  "n(an(x) * y) = an(x) * n(y)"
  by (metis an_n_def n_export)

lemma n_an_mult_commutative:
  "n(x) * an(y) = an(y) * n(x)"
  by (metis sup_commute an_dist_sup n_an_def)

lemma an_mult_commutative:
  "an(x) * an(y) = an(y) * an(x)"
  by (metis sup_commute an_dist_sup)

lemma an_mult_idempotent:
  "an(x) * an(x) = an(x)"
  by (metis sup_idem an_dist_sup)

lemma an_sub_one:
  "an(x) \<le> 1"
  using an_complement sup.cobounded1 by fastforce

text \<open>Theorem 21\<close>

lemma an_antitone:
  "x \<le> y \<Longrightarrow> an(y) \<le> an(x)"
  by (metis an_n_def an_dist_sup n_order sup.absorb1)

lemma an_mult_left_upper_bound:
  "an(x * y) \<le> an(x)"
  by (metis an_antitone an_mult_zero mult_right_isotone bot_least)

lemma an_mult_right_zero:
  "an(x) * bot = bot"
  by (metis an_n_def n_mult_right_bot)

lemma n_mult_an:
  "n(x * an(y)) = n(x)"
  by (metis an_n_def n_mult_n)

lemma an_mult_n:
  "an(x * n(y)) = an(x)"
  by (metis an_n_def n_an_def n_mult_n)

lemma an_mult_an:
  "an(x * an(y)) = an(x)"
  by (metis an_mult_n an_n_def)

lemma an_mult_left_absorb_sup:
  "an(x) * (an(x) \<squnion> an(y)) = an(x)"
  by (metis an_n_def n_mult_left_absorb_sup)

lemma an_mult_right_absorb_sup:
  "(an(x) \<squnion> an(y)) * an(y) = an(y)"
  by (metis an_n_def n_mult_right_absorb_sup)

lemma an_sup_left_absorb_mult:
  "an(x) \<squnion> an(x) * an(y) = an(x)"
  using an_case_split_right sup_absorb1 by blast

lemma an_sup_right_absorb_mult:
  "an(x) * an(y) \<squnion> an(y) = an(y)"
  using an_case_split_left sup_absorb2 by blast

lemma an_sup_left_dist_mult:
  "an(x) \<squnion> an(y) * an(z) = (an(x) \<squnion> an(y)) * (an(x) \<squnion> an(z))"
  by (metis an_n_def n_sup_left_dist_mult)

lemma an_sup_right_dist_mult:
  "an(x) * an(y) \<squnion> an(z) = (an(x) \<squnion> an(z)) * (an(y) \<squnion> an(z))"
  by (simp add: an_sup_left_dist_mult sup_commute)

lemma an_n_order:
  "an(x) \<le> an(y) \<longleftrightarrow> n(y) \<le> n(x)"
  by (smt (verit) an_n_def an_dist_sup le_iff_sup n_dist_sup n_mult_right_absorb_sup sup.orderE n_an_def)

lemma an_order:
  "an(x) \<le> an(y) \<longleftrightarrow> an(x) * an(y) = an(x)"
  by (metis an_n_def n_order)

lemma an_mult_left_lower_bound:
  "an(x) * an(y) \<le> an(x)"
  using an_case_split_right by blast

lemma an_mult_right_lower_bound:
  "an(x) * an(y) \<le> an(y)"
  by (simp add: an_sup_right_absorb_mult le_iff_sup)

lemma an_n_mult_left_lower_bound:
  "an(x) * n(y) \<le> an(x)"
  using an_case_split_right by blast

lemma an_n_mult_right_lower_bound:
  "an(x) * n(y) \<le> n(y)"
  using an_case_split_left by auto

lemma n_an_mult_left_lower_bound:
  "n(x) * an(y) \<le> n(x)"
  using an_case_split_right by auto

lemma n_an_mult_right_lower_bound:
  "n(x) * an(y) \<le> an(y)"
  using an_case_split_left by blast

lemma an_mult_least_upper_bound:
  "an(x) \<le> an(y) \<and> an(x) \<le> an(z) \<longleftrightarrow> an(x) \<le> an(y) * an(z)"
  by (metis an_mult_idempotent an_mult_left_lower_bound an_mult_right_lower_bound order.trans mult_isotone)

lemma an_mult_left_divisibility:
  "an(x) \<le> an(y) \<longleftrightarrow> (\<exists>z . an(x) = an(y) * an(z))"
  by (metis an_mult_commutative an_mult_left_lower_bound an_order)

lemma an_mult_right_divisibility:
  "an(x) \<le> an(y) \<longleftrightarrow> (\<exists>z . an(x) = an(z) * an(y))"
  by (simp add: an_mult_commutative an_mult_left_divisibility)

lemma an_split_top:
  "an(x * L) * x * top \<le> x * bot"
  by (metis an_split mult_assoc mult_left_isotone mult_left_zero)

lemma an_n_L:
  "an(n(x) * L) = an(x)"
  using an_n_def n_an_def by auto

lemma an_galois:
  "an(y) \<le> an(x) \<longleftrightarrow> n(x) * L \<le> y"
  by (simp add: an_n_order n_galois)

lemma an_mult:
  "an(x * n(y) * L) = an(x * y)"
  by (metis an_n_L n_mult)

lemma n_mult_top:
  "an(x * n(y) * top) = an(x * y)"
  by (metis an_n_L n_mult_top)

lemma an_n_equal:
  "an(x) = an(y) \<longleftrightarrow> n(x) = n(y)"
  by (metis an_n_L n_an_def)

lemma an_top_L:
  "an(x * top) = an(x * L)"
  by (simp add: an_n_equal n_top_L)

lemma an_case_split_left_equal:
  "an(z) * x = an(z) * y \<Longrightarrow> n(z) * x = n(z) * y \<Longrightarrow> x = y"
  using an_complement case_split_left_equal by blast

lemma an_case_split_right_equal:
  "x * an(z) = y * an(z) \<Longrightarrow> x * n(z) = y * n(z) \<Longrightarrow> x = y"
  using an_complement case_split_right_equal by blast

lemma an_equal_complement:
  "n(x) \<squnion> an(y) = 1 \<and> n(x) * an(y) = bot \<longleftrightarrow> an(x) = an(y)"
  by (metis sup_commute an_complement an_dist_sup mult_left_one mult_right_dist_sup n_complement_bot)

lemma n_equal_complement:
  "n(x) \<squnion> an(y) = 1 \<and> n(x) * an(y) = bot \<longleftrightarrow> n(x) = n(y)"
  by (simp add: an_equal_complement an_n_equal)

lemma an_shunting:
  "an(z) * x \<le> y \<longleftrightarrow> x \<le> y \<squnion> n(z) * top"
  apply (rule iffI)
  apply (meson an_case_split_left le_supI1 split_sub)
  by (metis sup_bot_right an_case_split_left an_complement_bot mult_assoc mult_left_dist_sup mult_left_zero mult_right_isotone order_refl order_trans)

lemma an_shunting_an:
  "an(z) * an(x) \<le> an(y) \<longleftrightarrow> an(x) \<le> n(z) \<squnion> an(y)"
  apply (rule iffI)
  apply (smt sup_ge1 sup_ge2 an_case_split_left n_an_mult_left_lower_bound order_trans)
  by (metis sup_bot_left sup_ge2 an_case_split_left an_complement_bot mult_left_dist_sup mult_right_isotone order_trans)

lemma an_L_zero:
  "an(x * L) * x = an(x * L) * x * bot"
  by (metis an_complement_bot n_split_equal sup_monoid.add_0_right vector_bot_closed mult_assoc n_export_an)

lemma n_plus_complement_intro_n:
  "n(x) \<squnion> an(x) * n(y) = n(x) \<squnion> n(y)"
  by (metis sup_commute an_complement an_n_def mult_1_right n_sup_right_dist_mult n_an_mult_commutative)

lemma n_plus_complement_intro_an:
  "n(x) \<squnion> an(x) * an(y) = n(x) \<squnion> an(y)"
  by (metis an_n_def n_plus_complement_intro_n)

lemma an_plus_complement_intro_n:
  "an(x) \<squnion> n(x) * n(y) = an(x) \<squnion> n(y)"
  by (metis an_n_def n_an_def n_plus_complement_intro_n)

lemma an_plus_complement_intro_an:
  "an(x) \<squnion> n(x) * an(y) = an(x) \<squnion> an(y)"
  by (metis an_n_def an_plus_complement_intro_n)

lemma n_mult_complement_intro_n:
  "n(x) * (an(x) \<squnion> n(y)) = n(x) * n(y)"
  by (simp add: mult_left_dist_sup n_complement_bot)

lemma n_mult_complement_intro_an:
  "n(x) * (an(x) \<squnion> an(y)) = n(x) * an(y)"
  by (simp add: semiring.distrib_left n_complement_bot)

lemma an_mult_complement_intro_n:
  "an(x) * (n(x) \<squnion> n(y)) = an(x) * n(y)"
  by (simp add: an_complement_bot mult_left_dist_sup)

lemma an_mult_complement_intro_an:
  "an(x) * (n(x) \<squnion> an(y)) = an(x) * an(y)"
  by (simp add: an_complement_bot semiring.distrib_left)

lemma an_preserves_equation:
  "an(y) * x \<le> x * an(y) \<longleftrightarrow> an(y) * x = an(y) * x * an(y)"
  by (metis an_n_def n_preserves_equation)

lemma wnf_lemma_1:
  "(n(p * L) * n(q * L) \<squnion> an(p * L) * an(r * L)) * n(p * L) = n(p * L) * n(q * L)"
  by (smt sup_commute an_n_def n_sup_left_absorb_mult n_sup_right_dist_mult n_export n_mult_commutative n_mult_complement_intro_n)

lemma wnf_lemma_2:
  "(n(p * L) * n(q * L) \<squnion> an(r * L) * an(q * L)) * n(q * L) = n(p * L) * n(q * L)"
  by (metis an_mult_commutative n_mult_commutative wnf_lemma_1)

lemma wnf_lemma_3:
  "(n(p * L) * n(r * L) \<squnion> an(p * L) * an(q * L)) * an(p * L) = an(p * L) * an(q * L)"
  by (metis an_n_def sup_commute wnf_lemma_1 n_an_def)

lemma wnf_lemma_4:
  "(n(r * L) * n(q * L) \<squnion> an(p * L) * an(q * L)) * an(q * L) = an(p * L) * an(q * L)"
  by (metis an_mult_commutative n_mult_commutative wnf_lemma_3)

lemma wnf_lemma_5:
  "n(p \<squnion> q) * (n(q) * x \<squnion> an(q) * y) = n(q) * x \<squnion> an(q) * n(p) * y"
  by (smt sup_bot_right mult_assoc mult_left_dist_sup n_an_mult_commutative n_complement_bot n_dist_sup n_mult_right_absorb_sup)

definition ani :: "'a \<Rightarrow> 'a"
  where "ani x \<equiv> an(x) * L"

lemma ani_bot:
  "ani(bot) = L"
  using an_bot ani_def by auto

lemma ani_one:
  "ani(1) = L"
  using an_one ani_def by auto

lemma ani_L:
  "ani(L) = bot"
  by (simp add: an_L ani_def)

lemma ani_top:
  "ani(top) = bot"
  by (simp add: an_top ani_def)

lemma ani_complement:
  "ani(x) \<squnion> ni(x) = L"
  by (metis an_complement ani_def mult_right_dist_sup n_top ni_def ni_top)

lemma ani_mult_zero:
  "ani(x) = ani(x * bot)"
  using ani_def an_mult_zero by auto

lemma ani_antitone:
  "y \<le> x \<Longrightarrow> ani(x) \<le> ani(y)"
  by (simp add: an_antitone ani_def mult_left_isotone)

lemma ani_mult_left_upper_bound:
  "ani(x * y) \<le> ani(x)"
  by (simp add: an_mult_left_upper_bound ani_def mult_left_isotone)

lemma ani_involutive:
  "ani(ani(x)) = ni(x)"
  by (simp add: ani_def ni_def n_an_def)

lemma ani_below_L:
  "ani(x) \<le> L"
  using an_case_split_left ani_def by auto

lemma ani_left_zero:
  "ani(x) * y = ani(x)"
  by (simp add: ani_def L_left_zero mult_assoc)

lemma ani_top_L:
  "ani(x * top) = ani(x * L)"
  by (simp add: an_top_L ani_def)

lemma ani_ni_order:
  "ani(x) \<le> ani(y) \<longleftrightarrow> ni(y) \<le> ni(x)"
  by (metis an_n_L ani_antitone ani_def ani_involutive ni_def)

lemma ani_ni_equal:
  "ani(x) = ani(y) \<longleftrightarrow> ni(x) = ni(y)"
  by (metis ani_ni_order order.antisym order_refl)

lemma ni_ani:
  "ni(ani(x)) = ani(x)"
  using an_n_def ani_def ni_def by auto

lemma ani_ni:
  "ani(ni(x)) = ani(x)"
  by (simp add: an_n_L ani_def ni_def)

lemma ani_mult:
  "ani(x * ni(y)) = ani(x * y)"
  using ani_ni_equal ni_mult by blast

lemma ani_an_order:
  "ani(x) \<le> ani(y) \<longleftrightarrow> an(x) \<le> an(y)"
  using an_galois ani_ni_order ni_def ni_galois by auto

lemma ani_an_equal:
  "ani(x) = ani(y) \<longleftrightarrow> an(x) = an(y)"
  by (metis an_n_def ani_def)

lemma n_mult_ani:
  "n(x) * ani(x) = bot"
  by (metis an_L ani_L ani_def mult_assoc n_complement_bot)

lemma an_mult_ni:
  "an(x) * ni(x) = bot"
  by (metis an_n_def ani_def n_an_def n_mult_ani ni_def)

lemma n_mult_ni:
  "n(x) * ni(x) = ni(x)"
  by (metis n_export n_order ni_def ni_export order_refl)

lemma an_mult_ani:
  "an(x) * ani(x) = ani(x)"
  by (metis an_n_def ani_def n_mult_ni ni_def)

lemma ani_ni_meet:
  "x \<le> ani(y) \<Longrightarrow> x \<le> ni(y) \<Longrightarrow> x = bot"
  by (metis an_case_split_left an_mult_ni bot_unique mult_right_isotone n_mult_ani)

lemma ani_galois:
  "ani(x) \<le> y \<longleftrightarrow> ni(x \<squnion> y) = L"
  apply (rule iffI)
  apply (smt (z3) an_L an_mult_commutative an_mult_right_zero ani_def an_dist_sup ni_L ni_n_equal sup.absorb1 mult_assoc n_an_def n_complement_bot)
  by (metis an_L an_galois an_mult_ni an_n_def an_shunting_an ani_def an_dist_sup an_export idempotent_bot_closed n_bot transitive_bot_closed)

lemma an_ani:
  "an(ani(x)) = n(x)"
  by (simp add: ani_def n_an_def)

lemma n_ani:
  "n(ani(x)) = an(x)"
  using an_n_def ani_def by auto

lemma an_ni:
  "an(ni(x)) = an(x)"
  by (simp add: an_n_L ni_def)

lemma ani_an:
  "ani(an(x)) = L"
  by (metis an_mult_right_zero an_mult_zero an_bot ani_def mult_left_one)

lemma ani_n:
  "ani(n(x)) = L"
  by (simp add: ani_an n_an_def)

lemma ni_an:
  "ni(an(x)) = bot"
  using an_L ani_an ani_def ni_n_bot n_an_def by force

lemma ani_mult_n:
  "ani(x * n(y)) = ani(x)"
  by (simp add: an_mult_n ani_def)

lemma ani_mult_an:
  "ani(x * an(y)) = ani(x)"
  by (simp add: an_mult_an ani_def)

lemma ani_export_n:
  "ani(n(x) * y) = ani(x) \<squnion> ani(y)"
  by (simp add: an_export_n ani_def mult_right_dist_sup)

lemma ani_export_an:
  "ani(an(x) * y) = ni(x) \<squnion> ani(y)"
  by (simp add: ani_def an_export ni_def semiring.distrib_right)

lemma ni_export_an:
  "ni(an(x) * y) = an(x) * ni(y)"
  by (simp add: an_mult_right_zero ni_split)

lemma ani_mult_top:
  "ani(x * n(y) * top) = ani(x * y)"
  using ani_def n_mult_top by auto

lemma ani_an_bot:
  "ani(x) = bot \<longleftrightarrow> an(x) = bot"
  using an_L ani_L ani_an_equal by force

lemma ani_an_L:
  "ani(x) = L \<longleftrightarrow> an(x) = 1"
  using an_bot ani_an_equal ani_bot by force

text \<open>Theorem 21\<close>

subclass tests
  apply unfold_locales
  apply (simp add: mult_assoc)
  apply (simp add: an_mult_commutative an_uminus)
  apply (smt an_sup_left_dist_mult an_export_n an_n_L an_uminus n_an_def n_complement_bot n_export)
  apply (metis an_dist_sup an_n_def an_uminus n_an_def)
  using an_complement_bot an_uminus n_an_def apply fastforce
  apply (simp add: an_bot an_uminus)
  using an_export_n an_mult an_uminus n_an_def apply fastforce
  using an_order an_uminus apply force
  by (simp add: less_le_not_le)

end

class an_itering = n_itering + an_semiring + while +
  assumes while_circ_def: "p \<star> y = (p * y)\<^sup>\<circ> * -p"
begin

subclass test_itering
  apply unfold_locales
  by (rule while_circ_def)

lemma an_circ_left_unfold:
  "an(x\<^sup>\<circ>) = an(x * x\<^sup>\<circ>)"
  by (metis an_dist_sup an_one circ_left_unfold mult_left_one)

lemma an_circ_x_n_circ:
  "an(x\<^sup>\<circ>) * x * n(x\<^sup>\<circ>) \<le> x * bot"
  by (metis an_circ_left_unfold an_mult an_split mult_assoc n_mult_right_bot)

lemma an_circ_invariant:
  "an(x\<^sup>\<circ>) * x \<le> x * an(x\<^sup>\<circ>)"
proof -
  have 1: "an(x\<^sup>\<circ>) * x * an(x\<^sup>\<circ>) \<le> x * an(x\<^sup>\<circ>)"
    by (metis an_case_split_left mult_assoc order_refl)
  have "an(x\<^sup>\<circ>) * x * n(x\<^sup>\<circ>) \<le> x * an(x\<^sup>\<circ>)"
    by (metis an_circ_x_n_circ order_trans mult_right_isotone bot_least)
  thus ?thesis
    using 1 an_case_split_right by blast
qed

lemma ani_circ:
  "ani(x)\<^sup>\<circ> = 1 \<squnion> ani(x)"
  by (simp add: ani_def mult_L_circ)

lemma ani_circ_left_unfold:
  "ani(x\<^sup>\<circ>) = ani(x * x\<^sup>\<circ>)"
  by (simp add: an_circ_left_unfold ani_def)

lemma an_circ_import:
  "an(y) * x \<le> x * an(y) \<Longrightarrow> an(y) * x\<^sup>\<circ> = an(y) * (an(y) * x)\<^sup>\<circ>"
  by (metis an_n_def n_circ_import)

lemma preserves_L:
  "preserves L (-p)"
  using L_left_zero preserves_equation_test mult_assoc by force

end

class an_omega_algebra = n_omega_algebra_2 + an_semiring + while +
  assumes while_Omega_def: "p \<star> y = (p * y)\<^sup>\<Omega> * -p"
begin

lemma an_split_omega_omega:
  "an(x\<^sup>\<omega>) * x\<^sup>\<omega> \<le> x\<^sup>\<omega> * bot"
  by (meson an_antitone an_split mult_left_isotone omega_sub_vector order_trans)

lemma an_omega_below_an_star:
  "an(x\<^sup>\<omega>) \<le> an(x\<^sup>\<star>)"
  by (simp add: an_n_order n_star_below_n_omega)

lemma an_omega_below_an:
  "an(x\<^sup>\<omega>) \<le> an(x)"
  by (simp add: an_n_order n_below_n_omega)

lemma an_omega_induct:
  "an(x * y \<squnion> z) \<le> an(y) \<Longrightarrow> an(x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z) \<le> an(y)"
  by (simp add: an_n_order n_omega_induct)

lemma an_star_mult:
  "an(y) \<le> an(x * y) \<Longrightarrow> an(x\<^sup>\<star> * y) = an(x\<^sup>\<star>) * an(y)"
  by (metis an_dist_sup an_n_L an_n_order n_dist_sup n_star_mult)

lemma an_omega_mult:
  "an(x\<^sup>\<omega> * y) = an(x\<^sup>\<omega>)"
  by (simp add: an_n_equal n_omega_mult)

lemma an_star_left_unfold:
  "an(x\<^sup>\<star>) = an(x * x\<^sup>\<star>)"
  by (simp add: an_n_equal n_star_left_unfold)

lemma an_star_x_n_star:
  "an(x\<^sup>\<star>) * x * n(x\<^sup>\<star>) \<le> x * bot"
  by (metis an_n_L an_split n_mult n_mult_right_bot n_star_left_unfold mult_assoc)

lemma an_star_invariant:
  "an(x\<^sup>\<star>) * x \<le> x * an(x\<^sup>\<star>)"
proof -
  have 1: "an(x\<^sup>\<star>) * x * an(x\<^sup>\<star>) \<le> x * an(x\<^sup>\<star>)"
    using an_case_split_left mult_assoc by auto
  have "an(x\<^sup>\<star>) * x * n(x\<^sup>\<star>) \<le> x * an(x\<^sup>\<star>)"
    by (metis an_star_x_n_star order_trans mult_right_isotone bot_least)
  thus ?thesis
    using 1 an_case_split_right by auto
qed

lemma n_an_star_unfold_invariant:
  "n(an(x\<^sup>\<star>) * x\<^sup>\<omega>) \<le> an(x) * n(x * an(x\<^sup>\<star>) * x\<^sup>\<omega>)"
proof -
  have "n(an(x\<^sup>\<star>) * x\<^sup>\<omega>) \<le> an(x)"
    using an_star_left_unfold an_case_split_right an_mult_left_upper_bound n_export_an by fastforce
  thus ?thesis
    by (smt an_star_invariant le_iff_sup mult_assoc mult_right_dist_sup n_isotone n_order omega_unfold)
qed

lemma ani_omega_below_ani_star:
  "ani(x\<^sup>\<omega>) \<le> ani(x\<^sup>\<star>)"
  by (simp add: an_omega_below_an_star ani_an_order)

lemma ani_omega_below_ani:
  "ani(x\<^sup>\<omega>) \<le> ani(x)"
  by (simp add: an_omega_below_an ani_an_order)

lemma ani_star:
  "ani(x)\<^sup>\<star> = 1 \<squnion> ani(x)"
  by (simp add: ani_def mult_L_star)

lemma ani_omega:
  "ani(x)\<^sup>\<omega> = ani(x) * L"
  by (simp add: L_left_zero ani_def mult_L_omega mult_assoc)

lemma ani_omega_induct:
  "ani(x * y \<squnion> z) \<le> ani(y) \<Longrightarrow> ani(x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z) \<le> ani(y)"
  by (simp add: an_omega_induct ani_an_order)

lemma ani_omega_mult:
  "ani(x\<^sup>\<omega> * y) = ani(x\<^sup>\<omega>)"
  by (simp add: an_omega_mult ani_def)

lemma ani_star_left_unfold:
  "ani(x\<^sup>\<star>) = ani(x * x\<^sup>\<star>)"
  by (simp add: an_star_left_unfold ani_def)

lemma an_star_import:
  "an(y) * x \<le> x * an(y) \<Longrightarrow> an(y) * x\<^sup>\<star> = an(y) * (an(y) * x)\<^sup>\<star>"
  by (metis an_n_def n_star_import)

lemma an_omega_export:
  "an(y) * x \<le> x * an(y) \<Longrightarrow> an(y) * x\<^sup>\<omega> = (an(y) * x)\<^sup>\<omega>"
  by (metis an_n_def n_omega_export)

lemma an_omega_import:
  "an(y) * x \<le> x * an(y) \<Longrightarrow> an(y) * x\<^sup>\<omega> = an(y) * (an(y) * x)\<^sup>\<omega>"
  by (simp add: an_mult_idempotent omega_import)

end

text \<open>Theorem 22\<close>

sublocale an_omega_algebra < nL_omega: an_itering where circ = Omega
  apply unfold_locales
  by (rule while_Omega_def)

context an_omega_algebra
begin

lemma preserves_star:
  "nL_omega.preserves x (-p) \<Longrightarrow> nL_omega.preserves (x\<^sup>\<star>) (-p)"
  by (simp add: nL_omega.preserves_def star.circ_simulate)

end

end


(* Author: Tobias Nipkow *)

section "Abstract Interpretation (ITP)"

theory Complete_Lattice_ix
imports Main
begin

subsection "Complete Lattice (indexed)"

text{* A complete lattice is an ordered type where every set of elements has
a greatest lower (and thus also a leats upper) bound. Sets are the
prototypical complete lattice where the greatest lower bound is
intersection. Sometimes that set of all elements of a type is not a complete
lattice although all elements of the same shape form a complete lattice, for
example lists of the same length, where the list elements come from a
complete lattice. We will have exactly this situation with annotated
commands. This theory introduces a slightly generalised version of complete
lattices where elements have an ``index'' and only the set of elements with
the same index form a complete lattice; the type as a whole is a disjoint
union of complete lattices. Because sets are not types, this requires a
special treatment. *}

locale Complete_Lattice_ix =
fixes L :: "'i \<Rightarrow> 'a::order set"
and Glb :: "'i \<Rightarrow> 'a set \<Rightarrow> 'a"
assumes Glb_lower: "A \<subseteq> L i \<Longrightarrow> a \<in> A \<Longrightarrow> (Glb i A) \<le> a"
and Glb_greatest: "b : L i \<Longrightarrow> \<forall>a\<in>A. b \<le> a \<Longrightarrow> b \<le> (Glb i A)"
and Glb_in_L: "A \<subseteq> L i \<Longrightarrow> Glb i A : L i"
begin

definition lfp :: "('a \<Rightarrow> 'a) \<Rightarrow> 'i \<Rightarrow> 'a" where
"lfp f i = Glb i {a : L i. f a \<le> a}"

lemma index_lfp: "lfp f i : L i"
by(auto simp: lfp_def intro: Glb_in_L)

lemma lfp_lowerbound:
  "\<lbrakk> a : L i;  f a \<le> a \<rbrakk> \<Longrightarrow> lfp f i \<le> a"
by (auto simp add: lfp_def intro: Glb_lower)

lemma lfp_greatest:
  "\<lbrakk> a : L i;  \<And>u. \<lbrakk> u : L i; f u \<le> u\<rbrakk> \<Longrightarrow> a \<le> u \<rbrakk> \<Longrightarrow> a \<le> lfp f i"
by (auto simp add: lfp_def intro: Glb_greatest)

end

end


section \<open>Termination proof for congruence closure\<close>
theory CC_Termination
  imports CC_Invars
begin

abbreviation root_set
  where
    "root_set l \<equiv> {i | i. i < length l \<and> l ! i = i}"

text \<open>To prove the termination of \<open>propagate\<close>, we show that the amount of equivalence classes
decreases at each step of \<open>propagate\<close>.\<close>
definition nr_eq_classes :: "nat list \<Rightarrow> nat"
  where
    "nr_eq_classes l = card (root_set l)"

lemma ufa_union_decreases_nr_eq_classes:
  assumes "ufa_invar l" "a < length l"
    "rep_of l a \<noteq> rep_of l b"
  shows "nr_eq_classes (ufa_union l a b) = nr_eq_classes l - 1"
proof-
  have "rep_of l a \<in> root_set l"
    by (simp add: assms rep_of_less_length_l rep_of_root)
  have "root_set l = root_set (ufa_union l a b) \<union> {rep_of l a}"
    by (auto simp add: nth_list_update' assms rep_of_bound rep_of_min \<open>rep_of l a \<in> root_set l\<close>)
  moreover have "rep_of l a \<notin> root_set (ufa_union l a b)"
    using assms by auto
  ultimately show ?thesis unfolding nr_eq_classes_def
    by simp
qed

lemma nr_eq_classes_gt_0:
  assumes "ufa_invar l" "length l > 0"
  shows "nr_eq_classes l > 0"
proof(rule ccontr)
  assume "\<not> 0 < nr_eq_classes l"
  then have no_eq_classes: "nr_eq_classes l = 0"
    by blast
  then obtain i where i: "i < length l"
    using assms by auto
  have "\<not> rep_of_dom (l, i)"
    using assms(1) i assms(2) proof(induction rule: rep_of_induct)
    case (base i)
    then have "l ! i \<noteq> i"
      using no_eq_classes unfolding nr_eq_classes_def by simp
    then show ?case
      using base by blast
  next
    case (step i)
    then show ?case
      using rep_of_domain by auto
  qed
  then show "False"
    using assms(1) i ufa_invarD(1) by auto
qed

lemma propagate_domain:
  assumes "cc_invar cc" "nr_vars cc > 0"
  shows "propagate_dom cc"
  using assms proof(induction "nr_eq_classes (cc_list cc)" arbitrary: cc)
  case 0
  then have "0 < nr_eq_classes (cc_list cc)"
    using nr_eq_classes_gt_0 unfolding cc_list_invar_def by blast
  then show ?case
    using 0 by linarith
next
  case (Suc x)
  then show ?case
  proof(cases "pending cc")
    case Nil
    then show ?thesis using propagate.domintros
      by (metis congruence_closure.cases congruence_closure.select_convs(4))
  next
    case (Cons eq pe)
    define a b where a_b: "a = left eq" "b = right eq"
    obtain l u t pf pfl ip where
      cc: "cc = \<lparr>cc_list = l, use_list = u, lookup = t, pending = (eq # pe), proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
      using Cons  by (metis congruence_closure.cases congruence_closure.select_convs(4))
    then show ?thesis proof(cases "rep_of l a = rep_of l b")
      case True
      let ?step = "\<lparr>cc_list = l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
      have "cc_invar ?step"
        using Suc.prems(1) True a_b cc cc_invar_step2 by blast
      then have "propagate_dom ?step" using True Suc(1)
      proof (induction pe)
        case Nil
        then show ?case using propagate.domintros by blast
      next
        case (Cons eq2 pe2)
        then show ?case proof(cases "rep_of l (left eq2) = rep_of l (right eq2)")
          case True
          let ?step = "\<lparr>cc_list = l, use_list = u, lookup = t, pending = pe2, proof_forest = pf, pf_labels = pfl,
        input = ip\<rparr>"
          from True have *: "cc_invar ?step" using cc_invar_step2
            using Cons.prems(1) by blast
          with Cons have "propagate_dom ?step"
            by blast
          then show ?thesis using propagate.domintros Cons True by presburger
        next
          case False
          let ?step = "(propagate_step l u t pe2 pf pfl ip (left eq2) (right eq2) eq2)"
          have *: "cc_list ?step = ufa_union l (left eq2) (right eq2)" by (simp add: cc_list_loop)
          have "(left eq2) < length l" "ufa_invar l"  using Cons
             apply (metis  pending_left_right_valid)
            using Suc unfolding cc_list_invar_def cc by simp
          then have "nr_eq_classes (ufa_union l (left eq2) (right eq2)) = nr_eq_classes l - 1"
            using ufa_union_decreases_nr_eq_classes Suc * False by blast
          then have "propagate_dom ?step"
            by (metis "*" Cons.prems(1) False Suc.hyps(1) Suc.hyps(2) Suc.prems(2) cc cc_invar_step congruence_closure.select_convs(1) diff_Suc_1 length_list_update)
          then show ?thesis using propagate.domintros
            using False by presburger
        qed
      qed
      then show ?thesis using cc propagate.domintros True a_b by blast
    next
      case False
      let ?step = "(propagate_step l u t pe pf pfl ip a b eq)"
      have *: "cc_list ?step = ufa_union l a b"
        by (simp add: cc_list_loop)
      have "a < length l" "ufa_invar l" using a_b Suc
         apply (metis cc pending_left_right_valid)
        using Suc unfolding cc_list_invar_def cc by simp
      then have "nr_eq_classes (ufa_union l a b) = nr_eq_classes l - 1"
        using ufa_union_decreases_nr_eq_classes Suc * False by blast
      then have "propagate_dom ?step"
        using Suc False a_b cc cc_invar_step cc_list_loop by auto
      then show ?thesis using cc propagate.domintros False a_b by blast
    qed
  qed
qed

lemma valid_vars_imp_nr_vars_gt_0:
  assumes "valid_vars eq (nr_vars cc)"
  shows "nr_vars cc > 0"
proof(cases eq)
  case (Constants x11 x12)
  with assms have "x11 < nr_vars cc"
    by simp
  then show ?thesis
    by simp
next
  case (Function x21 x22 x23)
  with assms have "x21 < nr_vars cc"
    by simp
  then show ?thesis
    by simp
qed

corollary propagate_domain':
  assumes "cc_invar cc" "valid_vars eq (nr_vars cc)"
  shows "propagate_dom cc"
  using propagate_domain valid_vars_imp_nr_vars_gt_0 assms by blast

end


(*  Title:      TwoSquares.thy
    Author:     Roelof Oosterhuis, 2007  Rijksuniversiteit Groningen
*)

header {* Sums of two squares *}

theory TwoSquares
imports "../Fermat3_4/IntNatAux" "~~/src/HOL/Old_Number_Theory/Euler"
begin

text {* Show that $(\frac{-1}{p}) = +1$ for primes $p \equiv 1 \bmod 4$. *}

definition
  sum2sq :: "int \<times> int \<Rightarrow> int" where
  "sum2sq = (\<lambda>(a,b). a^2+b^2)"

definition
  is_sum2sq :: "int \<Rightarrow> bool" where
  "is_sum2sq x \<longleftrightarrow> (\<exists> a b. sum2sq(a,b) = x)"

lemma mult_sum2sq: "sum2sq(a,b) * sum2sq(p,q) =
  sum2sq(a*p+b*q, a*q-b*p)"
  by (unfold sum2sq_def, simp add: eval_nat_numeral field_simps)

lemma is_mult_sum2sq: "is_sum2sq x \<Longrightarrow> is_sum2sq y \<Longrightarrow> is_sum2sq (x*y)"
  by (unfold is_sum2sq_def, auto simp only: mult_sum2sq, blast)

lemma Legendre_1mod4: "zprime (4*m+1) \<Longrightarrow> (Legendre (-1) (4*m+1)) = 1"
proof -
  let ?p = "4*m+1"
  let ?L = "Legendre (-1) ?p"
  assume p: "zprime ?p"
  have "m \<ge> 1"
  proof (rule ccontr)
    assume "\<not> m \<ge> 1" hence "m \<le> 0" by auto
    hence "?p \<le> 1" by auto
    with p show False by (simp add: zprime_def)
  qed
  hence p2: "?p > 2" by simp
  with p have "[?L = (-1)^nat((?p - 1) div 2)] (mod ?p)"
    by (simp only: Euler_Criterion)
  hence "[?L = (-1)^(2*nat m)] (mod ?p)" by (auto simp add: nat_mult_distrib)
  hence "[1 = ?L] (mod ?p)" by (auto simp add: power_mult power2_minus zcong_sym)
  hence "?p dvd 1-?L" by (simp add: zcong_def)
  moreover have "?L=1 \<or> ?L=0 \<or> ?L=-1" by (simp add: Legendre_def)
  ultimately have "?L = 1 \<or> ?p dvd 1 \<or> ?p dvd 2" by auto
  moreover
  { assume "?p dvd 1 \<or> ?p dvd 2"
    with p2 have False by (auto simp add: zdvd_not_zless) }
  ultimately show ?thesis by auto
qed

text {* Use this to prove that such primes can be written as the sum of two squares. *}

lemma qf1_prime_exists: "zprime (4*m+1) \<Longrightarrow> \<exists> x y. x^2 + y^2 = 4*m+1"
proof -
  let ?p = "4*m+1"
  assume p: "zprime ?p"
  hence "Legendre (-1) ?p = 1" by (rule Legendre_1mod4)
  moreover
  { assume "\<not> QuadRes ?p (-1)"
    hence "Legendre (-1) ?p \<noteq> 1" by (unfold Legendre_def, auto) }
  ultimately have "QuadRes ?p (-1)" by auto
  then obtain s1 where s1: "[s1^2 = -1] (mod ?p)" by (auto simp add: QuadRes_def)
  from p have p0: "?p > 0" by (simp add: zprime_def)
  hence "\<exists>! s. 0 \<le> s \<and> s < ?p \<and> [s1 = s] (mod ?p)"
    by (simp only: zcong_zless_unique)
  then obtain s where s0p: "0 \<le> s \<and> s < ?p \<and> [s1 = s] (mod ?p)"
    by auto
  hence "[s^2 = s1^2] (mod ?p)" by (simp only: zcong_sym power2_eq_square zcong_zmult)
  with s1 have s: "[s^2 = -1] (mod ?p)" by (auto dest: zcong_trans)
  hence "?p dvd s^2 - (-1::int)" by (unfold zcong_def, simp)
  moreover have "s^2 -(-1::int) = s^2 + 1" by arith
  ultimately have "?p dvd s^2 + 1" by simp
  then obtain t where t: "s^2 + 1 = ?p*t" by (auto simp add: dvd_def)
  hence "sum2sq(s,1) = ?p*t" by (simp add: sum2sq_def)
  hence qf1pt: "is_sum2sq (?p*t)" by (auto simp add: is_sum2sq_def)
  have t_l_p: "t < ?p"
  proof (rule ccontr)
    assume "\<not> t < ?p" hence "t > ?p - 1" by simp
    with p0 have "?p*(?p - 1) < ?p*t" by (simp only: zmult_zless_mono2)
    also with t have "\<dots> = s^2 + 1" by simp
    also have "\<dots> \<le> ?p*(?p - 1) - ?p + 2"
    proof -
      from s0p have "s \<le> ?p - 1" by (auto simp add: less_le)
      with s0p have "s^2 \<le> (?p - 1)^2" by (simp only: power_mono)
      also have "\<dots> = ?p*(?p - 1) - 1*(?p - 1)"
        by (simp only: power2_eq_square left_diff_distrib)
      finally show ?thesis by auto
    qed
    finally have "?p < 2" by arith
    with p show False by (unfold zprime_def, auto)
  qed
  have tpos: "t \<ge> 1"
  proof (rule ccontr)
    assume "\<not> t \<ge> 1" hence "t < 1" by auto
    moreover
    { assume "t = 0" with t have "s^2 + 1 = 0" by simp }
     moreover
    { assume "t < 0"
      with p0 have "?p*t < ?p*0" by (simp only: zmult_zless_mono2)
      with t have "s^2 + 1 < 0" by auto }
    moreover have "s^2 \<ge> 0" by (simp only: zero_le_power2)
    ultimately show False by (auto simp add: less_le)
  qed
  moreover
  { assume "t = 1"
    with qf1pt have "is_sum2sq ?p" by auto
    hence ?thesis by (unfold is_sum2sq_def sum2sq_def, auto) }
  moreover
  { assume t1: "t > 1"
    then obtain tn where tn: "tn = (nat t) - 1" and tn0: "tn > 0" by auto
    have "is_sum2sq (?p*(1+ int 0))" (is "?Q 0")
      -- "So, $Q~n =$ there exist $x,y$ such that $x^2+y^2 =(p*(1+ int(n)))$"
    proof (rule ccontr)
      assume nQ1: "\<not> ?Q 0"
      have "(1+int tn) < ?p \<Longrightarrow> \<not> ?Q tn"
      proof (induct tn rule: infinite_descent0)
        case 0
        from nQ1 show "1+int 0 < ?p \<Longrightarrow> \<not> ?Q 0" by simp
      next
        case (smaller n)
        hence n0: "n > 0" and IH: "1+int n < ?p \<and> ?Q n" by auto
        then obtain x y where xy: "x^2 + y^2 = ?p*(1+int n)"
          by (unfold is_sum2sq_def sum2sq_def, auto)
        let ?n1 = "(1+int n)"
        from n0 have n1pos: "?n1 > 0" by simp
        then obtain r v where rv: "v = x-r*?n1 \<and> 2*\<bar>v\<bar> \<le> ?n1"
          by (frule_tac x="?n1" in best_division_abs, auto)
        from n1pos obtain s w where sw: "w = y-s*?n1 \<and> 2*\<bar>w\<bar> \<le> ?n1"
          by (frule_tac x="?n1" in best_division_abs, auto)
        let ?C = "v^2 + w^2"
        have "?n1 dvd ?C"
        proof
          from rv sw have "?C = (x-r*?n1)^2 + (y-s*?n1)^2" by simp
          also have "\<dots> =
            x^2 + y^2 - 2*x*(r*?n1) - 2*y*(s*?n1) + (r*?n1)^2 + (s*?n1)^2"
            by (simp only: zdiff_power2)
          also with xy have "\<dots> =
            ?n1*?p - ?n1*(2*x*r) - ?n1*(2*y*s) + ?n1^2*r^2 + ?n1^2*s^2"
            by (simp only: ac_simps power_mult_distrib)
          finally show "?C = ?n1*(?p - 2*x*r - 2*y*s + ?n1*(r^2 + s^2))"
            by (simp only: power_mult_distrib distrib_left ac_simps
          left_diff_distrib right_diff_distrib power2_eq_square)
        qed
        then obtain m1 where m1: "?C = ?n1*m1" by (auto simp add: dvd_def)
        have mn: "m1 < ?n1"
        proof (rule ccontr)
          assume "\<not> m1 < ?n1" hence "?n1-m1 \<le> 0" by simp
          hence "4*?n1 - 4*m1 \<le> 0" by simp
          with n1pos have "2*?n1 - 4*m1 < 0" by simp
          moreover from n1pos have "?n1 > 0" by simp
          ultimately have "?n1*(2*?n1 - 4*m1) < ?n1*0" by (simp only: zmult_zless_mono2)
          hence contr: "?n1*(2*?n1- 4*m1) < 0" by simp
          have hlp: "2*\<bar>v\<bar> \<ge> 0 \<and> 2*\<bar>w\<bar> \<ge> 0" by simp
          from m1 have "4*?n1*m1 = 4*v^2 + 4*w^2" by arith
          also have "\<dots> = (2*\<bar>v\<bar>)^2 + (2*\<bar>w\<bar>)^2"
            by (auto simp add: power2_abs power_mult_distrib)
          also from rv hlp have "\<dots> \<le> ?n1^2 + (2*\<bar>w\<bar>)^2"
            by (auto simp add: power_mono)
          also from sw hlp have "\<dots> \<le> ?n1^2 + ?n1^2"
            by (auto simp add: power_mono)
          finally have "?n1*m1*4 \<le> ?n1*?n1*2"
            by (simp add: power2_eq_square ac_simps)
          hence "?n1*(2*?n1- 4*m1) \<ge> 0"
            by (simp only: right_diff_distrib ac_simps)
          hence "?n1*(2*?n1- 4*m1) > -1" by auto
          with contr show False by auto
        qed
        have "(r*v + s*w + m1)^2 + (r*w - s*v)^2 = ?p*m1"
        proof -
          from m1 xy have "(?p*?n1)*?C = (x^2+y^2)*(v^2+w^2)" by simp
          also have "\<dots> = (x*v + y*w)^2 + (x*w - y*v)^2"
            by (simp add: eval_nat_numeral field_simps)
          also with rv sw have "\<dots> =
            ((r*?n1+v)*v + (s*?n1+w)*w)^2 + ((r*?n1+v)*w - (s*?n1+w)*v)^2"
            by simp
          also have "\<dots> =
             (?n1*(r*v) + ?n1*(s*w) + (v^2+w^2))^2 + (?n1*(r*w) - ?n1*(s*v))^2"
            by (simp add: eval_nat_numeral field_simps)
          also from m1 have "\<dots> =
             (?n1*(r*v) + ?n1*(s*w) + ?n1*m1)^2 + (?n1*(r*w) - ?n1*(s*v))^2"
            by simp
          finally have
            "(?p*?n1)*?C = ?n1^2*(r*v + s*w + m1)^2 + ?n1^2*(r*w - s*v)^2"
            by (simp add: eval_nat_numeral field_simps)
          with m1 have
            "?n1^2*(?p*m1) = ?n1^2*((r*v + s*w + m1)^2 + (r*w - s*v)^2)"
            by (simp only: ac_simps power2_eq_square, simp add: distrib_left)
          hence "?n1^2*(?p*m1 - (r*v+s*w+m1)^2 - (r*w-s*v)^2) = 0"
            by (auto simp add: distrib_left right_diff_distrib)
          moreover from n1pos have "?n1^2 \<noteq> 0" by (simp add: power2_eq_square)
          ultimately show ?thesis by simp
        qed
        hence qf1pm1: "is_sum2sq (?p*m1)" by (unfold is_sum2sq_def sum2sq_def, auto)
        have m1pos: "m1 > 0"
        proof -
          { assume "v^2 + w^2 = 0"
            moreover
            { assume "v \<noteq> 0"
              hence "v^2 > 0" by (simp add: zero_less_power2)
              moreover have "w^2 \<ge> 0" by (rule zero_le_power2)
              ultimately have "v^2 + w^2 > 0" by arith }
            moreover
            { assume "w \<noteq> 0"
              hence "w^2 > 0" by (simp add: zero_less_power2)
              moreover have "v^2 \<ge> 0" by (rule zero_le_power2)
              ultimately have "v^2 + w^2 > 0" by arith }
            ultimately have "v = 0 \<and> w = 0" by auto
            with rv sw have "?n1 dvd x \<and> ?n1 dvd y" by (unfold dvd_def, auto)
            hence "?n1^2 dvd x^2 \<and> ?n1^2 dvd y^2" by (simp add: zpower_zdvd_mono)
            hence "?n1^2 dvd x^2 + y^2" by (simp only: dvd_add)
            with xy have "?n1*?n1 dvd ?n1*?p"
              by (simp only: power2_eq_square ac_simps)
            moreover from n1pos have "?n1 \<noteq> 0" by simp
            ultimately have "?n1 dvd ?p" by (rule zdvd_mult_cancel)
            with n1pos have "?n1 \<ge> 0 \<and> ?n1 dvd ?p" by simp
            with p have "?n1 = 1 \<or> ?n1 = ?p" by (unfold zprime_def, blast)
            with IH have "?Q 0" by auto
            with nQ1 have False by simp }
          moreover
          { assume "v^2 + 1*w^2 \<noteq> 0"
            moreover have "v^2 + w^2 \<ge> 0"
            proof -
              have "v^2 \<ge> 0 \<and> w^2 \<ge> 0" by (auto simp only: zero_le_power2)
              thus ?thesis by arith
            qed
            ultimately have vwpos: "v^2 + w^2 > 0" by arith
            with m1 have "m1 \<noteq> 0" by auto
            moreover have "m1 \<ge> 0"
            proof (rule ccontr)
              assume "\<not> m1 \<ge> 0" hence "m1 < 0" by simp
              with n1pos have "?n1*m1 < ?n1*0" by (simp only: zmult_zless_mono2)
              with m1 vwpos show False by simp
            qed
            ultimately have ?thesis "m1 > 0" by auto }
          ultimately show ?thesis by auto
        qed
        hence "1 + int((nat m1) - 1) = m1" by arith
        with qf1pm1 have Qm1: "?Q ((nat m1) - 1)" by auto
        then obtain mm where tmp: "mm = (nat m1) - 1 \<and> ?Q mm" by auto
        moreover have "mm<n"
        proof -
          from tmp mn m1pos have "int mm < int n" by arith
          thus ?thesis by arith
        qed
        moreover with IH have "1 + int mm < ?p" by auto
        ultimately show "\<exists> m. m<n \<and> \<not> (1 + int m < ?p \<longrightarrow> \<not> ?Q m)" by auto
      qed
      moreover from tn tpos t_l_p have "1 + int tn < ?p \<and> tn = nat t- 1"
        by arith
      ultimately have "\<not> ?Q ((nat t) - 1)" by simp
      moreover from tpos have "1 + int ((nat t) - 1) = t" by arith
      ultimately have "\<not> is_sum2sq (?p*t)" by auto
      with qf1pt show False by simp
    qed
    hence ?thesis by (unfold is_sum2sq_def sum2sq_def, auto) }
  ultimately show ?thesis by (auto simp add: less_le)
qed

end