(*  Title:      HOL/Algebra/Ring_Divisibility.thy
    Author:     Paulo Emílio de Vilhena
*)

theory Ring_Divisibility
imports Ideal Divisibility QuotRing Multiplicative_Group

begin

(* TEMPORARY ====================================================================== *)
definition mult_of :: "('a, 'b) ring_scheme \<Rightarrow> 'a monoid" where
  "mult_of R \<equiv> \<lparr> carrier = carrier R - {\<zero>\<^bsub>R\<^esub>}, mult = mult R, one = \<one>\<^bsub>R\<^esub>\<rparr>"

lemma carrier_mult_of [simp]: "carrier (mult_of R) = carrier R - {\<zero>\<^bsub>R\<^esub>}"
  by (simp add: mult_of_def)

lemma mult_mult_of [simp]: "mult (mult_of R) = mult R"
 by (simp add: mult_of_def)

lemma nat_pow_mult_of: "([^]\<^bsub>mult_of R\<^esub>) = (([^]\<^bsub>R\<^esub>) :: _ \<Rightarrow> nat \<Rightarrow> _)"
  by (simp add: mult_of_def fun_eq_iff nat_pow_def)

lemma one_mult_of [simp]: "\<one>\<^bsub>mult_of R\<^esub> = \<one>\<^bsub>R\<^esub>"
  by (simp add: mult_of_def)
(* ================================================================================ *)

section \<open>The Arithmetic of Rings\<close>

text \<open>In this section we study the links between the divisibility theory and that of rings\<close>

subsection \<open>Definitions\<close>

locale factorial_domain = domain + factorial_monoid "mult_of R"

locale noetherian_ring = ring +
  assumes finetely_gen: "ideal I R \<Longrightarrow> \<exists>A \<subseteq> carrier R. finite A \<and> I = Idl A"

locale noetherian_domain = noetherian_ring + domain

locale principal_domain = domain +
  assumes exists_gen: "ideal I R \<Longrightarrow> \<exists>a \<in> carrier R. I = PIdl a"

locale euclidean_domain =
  domain R for R (structure) + fixes \<phi> :: "'a \<Rightarrow> nat"
  assumes euclidean_function:
  " \<lbrakk> a \<in> carrier R - { \<zero> }; b \<in> carrier R - { \<zero> } \<rbrakk> \<Longrightarrow>
   \<exists>q r. q \<in> carrier R \<and> r \<in> carrier R \<and> a = (b \<otimes> q) \<oplus> r \<and> ((r = \<zero>) \<or> (\<phi> r < \<phi> b))"

definition ring_irreducible :: "('a, 'b) ring_scheme \<Rightarrow> 'a \<Rightarrow> bool" ("ring'_irreducible\<index>")
  where "ring_irreducible\<^bsub>R\<^esub> a \<longleftrightarrow> (a \<noteq> \<zero>\<^bsub>R\<^esub>) \<and> (irreducible R a)"

definition ring_prime :: "('a, 'b) ring_scheme \<Rightarrow> 'a \<Rightarrow> bool" ("ring'_prime\<index>")
  where "ring_prime\<^bsub>R\<^esub> a \<longleftrightarrow> (a \<noteq> \<zero>\<^bsub>R\<^esub>) \<and> (prime R a)"

subsection \<open>The cancellative monoid of a domain. \<close>

sublocale domain < mult_of: comm_monoid_cancel "mult_of R"
  rewrites "mult (mult_of R) = mult R"
       and "one  (mult_of R) =  one R"
  using m_comm m_assoc
  by (auto intro!: comm_monoid_cancelI comm_monoidI
         simp add: m_rcancel integral_iff)

sublocale factorial_domain < mult_of: factorial_monoid "mult_of R"
  rewrites "mult (mult_of R) = mult R"
       and "one  (mult_of R) =  one R"
  using factorial_monoid_axioms by auto

lemma (in ring) noetherian_ringI:
  assumes "\<And>I. ideal I R \<Longrightarrow> \<exists>A \<subseteq> carrier R. finite A \<and> I = Idl A"
  shows "noetherian_ring R"
  using assms by unfold_locales auto

lemma (in domain) euclidean_domainI:
  assumes "\<And>a b. \<lbrakk> a \<in> carrier R - { \<zero> }; b \<in> carrier R - { \<zero> } \<rbrakk> \<Longrightarrow>
           \<exists>q r. q \<in> carrier R \<and> r \<in> carrier R \<and> a = (b \<otimes> q) \<oplus> r \<and> ((r = \<zero>) \<or> (\<phi> r < \<phi> b))"
  shows "euclidean_domain R \<phi>"
  using assms by unfold_locales auto

subsection \<open>Passing from \<^term>\<open>R\<close> to \<^term>\<open>mult_of R\<close> and vice-versa. \<close>

lemma divides_mult_imp_divides [simp]: "a divides\<^bsub>(mult_of R)\<^esub> b \<Longrightarrow> a divides\<^bsub>R\<^esub> b"
  unfolding factor_def by auto

lemma (in domain) divides_imp_divides_mult [simp]:
  "\<lbrakk> a \<in> carrier R; b \<in> carrier R - { \<zero> } \<rbrakk> \<Longrightarrow> a divides\<^bsub>R\<^esub> b \<Longrightarrow> a divides\<^bsub>(mult_of R)\<^esub> b"
  unfolding factor_def using integral_iff by auto

lemma (in cring) divides_one:
  assumes "a \<in> carrier R"
  shows "a divides \<one> \<longleftrightarrow> a \<in> Units R"
  using assms m_comm unfolding factor_def Units_def by force

lemma (in ring) one_divides:
  assumes "a \<in> carrier R" shows "\<one> divides a"
  using assms unfolding factor_def by simp

lemma (in ring) divides_zero:
  assumes "a \<in> carrier R" shows "a divides \<zero>"
  using r_null[OF assms] unfolding factor_def by force

lemma (in ring) zero_divides:
  shows "\<zero> divides a \<longleftrightarrow> a = \<zero>"
  unfolding factor_def by auto

lemma (in domain) divides_mult_zero:
  assumes "a \<in> carrier R" shows "a divides\<^bsub>(mult_of R)\<^esub> \<zero> \<Longrightarrow> a = \<zero>"
  using integral[OF _ assms] unfolding factor_def by auto

lemma (in ring) divides_mult:
  assumes "a \<in> carrier R" "c \<in> carrier R"
  shows "a divides b \<Longrightarrow> (c \<otimes> a) divides (c \<otimes> b)"
  using m_assoc[OF assms(2,1)] unfolding factor_def by auto

lemma (in domain) mult_divides:
  assumes "a \<in> carrier R" "b \<in> carrier R" "c \<in> carrier R - { \<zero> }"
  shows "(c \<otimes> a) divides (c \<otimes> b) \<Longrightarrow> a divides b"
  using assms m_assoc[of c] unfolding factor_def by (simp add: m_lcancel)

lemma (in domain) assoc_iff_assoc_mult:
  assumes "a \<in> carrier R" and "b \<in> carrier R"
  shows "a \<sim> b \<longleftrightarrow> a \<sim>\<^bsub>(mult_of R)\<^esub> b"
proof
  assume "a \<sim>\<^bsub>(mult_of R)\<^esub> b" thus "a \<sim> b"
    unfolding associated_def factor_def by auto
next
  assume A: "a \<sim> b"
  then obtain c1 c2
    where c1: "c1 \<in> carrier R" "a = b \<otimes> c1" and c2: "c2 \<in> carrier R" "b = a \<otimes> c2"
    unfolding associated_def factor_def by auto
  show "a \<sim>\<^bsub>(mult_of R)\<^esub> b"
  proof (cases "a = \<zero>")
    assume a: "a = \<zero>" then have b: "b = \<zero>"
      using c2 by auto
    show ?thesis
      unfolding associated_def factor_def a b by auto
  next
    assume a: "a \<noteq> \<zero>"
    hence b: "b \<noteq> \<zero>" and c1_not_zero: "c1 \<noteq> \<zero>"
      using c1 assms by auto
    hence c2_not_zero: "c2 \<noteq> \<zero>"
      using c2 assms by auto
    show ?thesis
      unfolding associated_def factor_def using c1 c2 c1_not_zero c2_not_zero a b by auto
  qed
qed

lemma (in domain) Units_mult_eq_Units [simp]: "Units (mult_of R) = Units R"
  unfolding Units_def using insert_Diff integral_iff by auto

lemma (in domain) ring_associated_iff:
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "a \<sim> b \<longleftrightarrow> (\<exists>u \<in> Units R. a = u \<otimes> b)"
proof (cases "a = \<zero>")
  assume [simp]: "a = \<zero>" show ?thesis
  proof
    assume "a \<sim> b" thus "\<exists>u \<in> Units R. a = u \<otimes> b"
      using zero_divides unfolding associated_def by force
  next
    assume "\<exists>u \<in> Units R. a = u \<otimes> b" then have "b = \<zero>"
      by (metis Units_closed Units_l_cancel \<open>a = \<zero>\<close> assms r_null)
    thus "a \<sim> b"
      using zero_divides[of \<zero>] by auto
  qed
next
  assume a: "a \<noteq> \<zero>" show ?thesis
  proof (cases "b = \<zero>")
    assume "b = \<zero>" thus ?thesis
      using assms a zero_divides[of a] r_null unfolding associated_def by blast
  next
    assume b: "b \<noteq> \<zero>"
    have "(\<exists>u \<in> Units R. a = u \<otimes> b) \<longleftrightarrow> (\<exists>u \<in> Units R. a = b \<otimes> u)"
      using m_comm[OF assms(2)] Units_closed by auto
    thus ?thesis
      using mult_of.associated_iff[of a b] a b assms
      unfolding assoc_iff_assoc_mult[OF assms] Units_mult_eq_Units
      by auto
  qed
qed

lemma (in domain) properfactor_mult_imp_properfactor:
  "\<lbrakk> a \<in> carrier R; b \<in> carrier R \<rbrakk> \<Longrightarrow> properfactor (mult_of R) b a \<Longrightarrow> properfactor R b a"
proof -
  assume A: "a \<in> carrier R" "b \<in> carrier R" "properfactor (mult_of R) b a"
  then obtain c where c: "c \<in> carrier (mult_of R)" "a = b \<otimes> c"
    unfolding properfactor_def factor_def by auto
  have "a \<noteq> \<zero>"
  proof (rule ccontr)
    assume a: "\<not> a \<noteq> \<zero>"
    hence "b = \<zero>" using c A integral[of b c] by auto
    hence "b = a \<otimes> \<one>" using a A by simp
    hence "a divides\<^bsub>(mult_of R)\<^esub> b"
      unfolding factor_def by auto
    thus False using A unfolding properfactor_def by simp
  qed
  hence "b \<noteq> \<zero>"
    using c A integral_iff by auto
  thus "properfactor R b a"
    using A divides_imp_divides_mult[of a b] unfolding properfactor_def
    by (meson DiffI divides_mult_imp_divides empty_iff insert_iff)
qed

lemma (in domain) properfactor_imp_properfactor_mult:
  "\<lbrakk> a \<in> carrier R - { \<zero> }; b \<in> carrier R \<rbrakk> \<Longrightarrow> properfactor R b a \<Longrightarrow> properfactor (mult_of R) b a"
  unfolding properfactor_def factor_def by auto

lemma (in domain) properfactor_of_zero:
  assumes "b \<in> carrier R"
  shows "\<not> properfactor (mult_of R) b \<zero>" and "properfactor R b \<zero> \<longleftrightarrow> b \<noteq> \<zero>"
  using divides_mult_zero[OF assms] divides_zero[OF assms] unfolding properfactor_def by auto

subsection \<open>Irreducible\<close>

text \<open>The following lemmas justify the need for a definition of irreducible specific to rings:
      for \<^term>\<open>irreducible R\<close>, we need to suppose we are not in a field (which is plausible,
      but \<^term>\<open>\<not> field R\<close> is an assumption we want to avoid; for \<^term>\<open>irreducible (mult_of R)\<close>, zero
      is allowed. \<close>

lemma (in domain) zero_is_irreducible_mult:
  shows "irreducible (mult_of R) \<zero>"
  unfolding irreducible_def Units_def properfactor_def factor_def
  using integral_iff by fastforce

lemma (in domain) zero_is_irreducible_iff_field:
  shows "irreducible R \<zero> \<longleftrightarrow> field R"
proof
  assume irr: "irreducible R \<zero>"
  have "\<And>a. \<lbrakk> a \<in> carrier R; a \<noteq> \<zero> \<rbrakk> \<Longrightarrow> properfactor R a \<zero>"
    unfolding properfactor_def factor_def by (auto, metis r_null zero_closed)
  hence "carrier R - { \<zero> } = Units R"
    using irr unfolding irreducible_def by auto
  thus "field R"
    using field.intro[OF domain_axioms] unfolding field_axioms_def by simp
next
  assume field: "field R" show "irreducible R \<zero>"
    using field.field_Units[OF field]
    unfolding irreducible_def properfactor_def factor_def by blast
qed

lemma (in domain) irreducible_imp_irreducible_mult:
  "\<lbrakk> a \<in> carrier R; irreducible R a \<rbrakk> \<Longrightarrow> irreducible (mult_of R) a"
  using zero_is_irreducible_mult Units_mult_eq_Units properfactor_mult_imp_properfactor
  by (cases "a = \<zero>") (auto simp add: irreducible_def)

lemma (in domain) irreducible_mult_imp_irreducible:
  "\<lbrakk> a \<in> carrier R - { \<zero> }; irreducible (mult_of R) a \<rbrakk> \<Longrightarrow> irreducible R a"
    unfolding irreducible_def using properfactor_imp_properfactor_mult properfactor_divides by fastforce

lemma (in domain) ring_irreducibleE:
  assumes "r \<in> carrier R" and "ring_irreducible r"
  shows "r \<noteq> \<zero>" "irreducible R r" "irreducible (mult_of R) r" "r \<notin> Units R"
    and "\<And>a b. \<lbrakk> a \<in> carrier R; b \<in> carrier R \<rbrakk> \<Longrightarrow> r = a \<otimes> b \<Longrightarrow> a \<in> Units R \<or> b \<in> Units R"
proof -
  show "irreducible (mult_of R) r" "irreducible R r"
    using assms irreducible_imp_irreducible_mult unfolding ring_irreducible_def by auto
  show "r \<noteq> \<zero>" "r \<notin> Units R"
    using assms unfolding ring_irreducible_def irreducible_def by auto
next
  fix a b assume a: "a \<in> carrier R" and b: "b \<in> carrier R" and r: "r = a \<otimes> b"
  show "a \<in> Units R \<or> b \<in> Units R"
  proof (cases "properfactor R a r")
    assume "properfactor R a r" thus ?thesis
      using a assms(2) unfolding ring_irreducible_def irreducible_def by auto
  next
    assume not_proper: "\<not> properfactor R a r"
    hence "r divides a"
      using r b unfolding properfactor_def by auto
    then obtain c where c: "c \<in> carrier R" "a = r \<otimes> c"
      unfolding factor_def by auto
    have "\<one> = c \<otimes> b"
      using r c(1) b assms m_assoc m_lcancel[OF _ assms(1) one_closed m_closed[OF c(1) b]]
      unfolding c(2) ring_irreducible_def by auto
    thus ?thesis
      using c(1) b m_comm unfolding Units_def by auto
  qed
qed

lemma (in domain) ring_irreducibleI:
  assumes "r \<in> carrier R - { \<zero> }" "r \<notin> Units R"
    and "\<And>a b. \<lbrakk> a \<in> carrier R; b \<in> carrier R \<rbrakk> \<Longrightarrow> r = a \<otimes> b \<Longrightarrow> a \<in> Units R \<or> b \<in> Units R"
  shows "ring_irreducible r"
  unfolding ring_irreducible_def
proof
  show "r \<noteq> \<zero>" using assms(1) by blast
next
  show "irreducible R r"
  proof (rule irreducibleI[OF assms(2)])
    fix a assume a: "a \<in> carrier R" "properfactor R a r"
    then obtain b where b: "b \<in> carrier R" "r = a \<otimes> b"
      unfolding properfactor_def factor_def by blast
    hence "a \<in> Units R \<or> b \<in> Units R"
      using assms(3)[OF a(1) b(1)] by simp
    thus "a \<in> Units R"
    proof (auto)
      assume "b \<in> Units R"
      hence "r \<otimes> inv b = a" and "inv b \<in> carrier R"
        using b a by (simp add: m_assoc)+
      thus ?thesis
        using a(2) unfolding properfactor_def factor_def by blast
    qed
  qed
qed

lemma (in domain) ring_irreducibleI':
  assumes "r \<in> carrier R - { \<zero> }" "irreducible (mult_of R) r"
  shows "ring_irreducible r"
  unfolding ring_irreducible_def
  using irreducible_mult_imp_irreducible[OF assms] assms(1) by auto

subsection \<open>Primes\<close>

lemma (in domain) zero_is_prime: "prime R \<zero>" "prime (mult_of R) \<zero>"
  using integral unfolding prime_def factor_def Units_def by auto

lemma (in domain) prime_eq_prime_mult:
  assumes "p \<in> carrier R"
  shows "prime R p \<longleftrightarrow> prime (mult_of R) p"
proof (cases "p = \<zero>", auto simp add: zero_is_prime)
  assume "p \<noteq> \<zero>" "prime R p" thus "prime (mult_of R) p"
    unfolding prime_def
    using divides_mult_imp_divides Units_mult_eq_Units mult_mult_of
    by (metis DiffD1 assms carrier_mult_of divides_imp_divides_mult)
next
  assume p: "p \<noteq> \<zero>" "prime (mult_of R) p" show "prime R p"
  proof (rule primeI)
    show "p \<notin> Units R"
      using p(2) Units_mult_eq_Units unfolding prime_def by simp
  next
    fix a b assume a: "a \<in> carrier R" and b: "b \<in> carrier R" and dvd: "p divides a \<otimes> b"
    then obtain c where c: "c \<in> carrier R" "a \<otimes> b = p \<otimes> c"
      unfolding factor_def by auto
    show "p divides a \<or> p divides b"
    proof (cases "a \<otimes> b = \<zero>")
      case True thus ?thesis
        using integral[OF _ a b] c unfolding factor_def by force
    next
      case False
      hence "p divides\<^bsub>(mult_of R)\<^esub> (a \<otimes> b)"
        using divides_imp_divides_mult[OF assms _ dvd] m_closed[OF a b] by simp
      moreover have "a \<noteq> \<zero>" "b \<noteq> \<zero>" "c \<noteq> \<zero>"
        using False a b c p l_null integral_iff by (auto, simp add: assms)
      ultimately show ?thesis
        using a b p unfolding prime_def
        by (auto, metis Diff_iff divides_mult_imp_divides singletonD)
    qed
  qed
qed

lemma (in domain) ring_primeE:
  assumes "p \<in> carrier R" "ring_prime p"
  shows "p \<noteq> \<zero>" "prime (mult_of R) p" "prime R p"
  using assms prime_eq_prime_mult unfolding ring_prime_def by auto

lemma (in ring) ring_primeI: (* in ring only to avoid instantiating R *)
  assumes "p \<noteq> \<zero>" "prime R p" shows "ring_prime p"
  using assms unfolding ring_prime_def by auto

lemma (in domain) ring_primeI':
  assumes "p \<in> carrier R - { \<zero> }" "prime (mult_of R) p"
  shows "ring_prime p"
  using assms prime_eq_prime_mult unfolding ring_prime_def by auto

subsection \<open>Basic Properties\<close>

lemma (in cring) to_contain_is_to_divide:
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "PIdl b \<subseteq> PIdl a \<longleftrightarrow> a divides b"
proof
  show "PIdl b \<subseteq> PIdl a \<Longrightarrow> a divides b"
  proof -
    assume "PIdl b \<subseteq> PIdl a"
    hence "b \<in> PIdl a"
      by (meson assms(2) local.ring_axioms ring.cgenideal_self subsetCE)
    thus ?thesis
      unfolding factor_def cgenideal_def using m_comm assms(1) by blast
  qed
  show "a divides b \<Longrightarrow> PIdl b \<subseteq> PIdl a"
  proof -
    assume "a divides b" then obtain c where c: "c \<in> carrier R" "b = c \<otimes> a"
      unfolding factor_def using m_comm[OF assms(1)] by blast
    show "PIdl b \<subseteq> PIdl a"
    proof
      fix x assume "x \<in> PIdl b"
      then obtain d where d: "d \<in> carrier R" "x = d \<otimes> b"
        unfolding cgenideal_def by blast
      hence "x = (d \<otimes> c) \<otimes> a"
        using c d m_assoc assms by simp
      thus "x \<in> PIdl a"
        unfolding cgenideal_def using m_assoc assms c d by blast
    qed
  qed
qed

lemma (in cring) associated_iff_same_ideal:
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "a \<sim> b \<longleftrightarrow> PIdl a = PIdl b"
  unfolding associated_def
  using to_contain_is_to_divide[OF assms]
        to_contain_is_to_divide[OF assms(2,1)] by auto

lemma (in cring) ideal_eq_carrier_iff:
  assumes "a \<in> carrier R"
  shows "carrier R = PIdl a \<longleftrightarrow> a \<in> Units R"
proof
  assume "carrier R = PIdl a"
  hence "\<one> \<in> PIdl a"
    by auto
  then obtain b where "b \<in> carrier R" "\<one> = a \<otimes> b" "\<one> = b \<otimes> a"
    unfolding cgenideal_def using m_comm[OF assms] by auto
  thus "a \<in> Units R"
    using assms unfolding Units_def by auto
next
  assume "a \<in> Units R"
  then have inv_a: "inv a \<in> carrier R" "inv a \<otimes> a = \<one>"
    by auto
  have "carrier R \<subseteq> PIdl a"
  proof
    fix b assume "b \<in> carrier R"
    hence "(b \<otimes> inv a) \<otimes> a = b" and "b \<otimes> inv a \<in> carrier R"
      using m_assoc[OF _ inv_a(1) assms] inv_a by auto
    thus "b \<in> PIdl a"
      unfolding cgenideal_def by force
  qed
  thus "carrier R = PIdl a"
    using assms by (simp add: cgenideal_eq_rcos r_coset_subset_G subset_antisym)
qed

lemma (in domain) primeideal_iff_prime:
  assumes "p \<in> carrier R - { \<zero> }"
  shows "primeideal (PIdl p) R \<longleftrightarrow> ring_prime p"
proof
  assume PIdl: "primeideal (PIdl p) R" show "ring_prime p"
  proof (rule ring_primeI)
    show "p \<noteq> \<zero>" using assms by simp
  next
    show "prime R p"
    proof (rule primeI)
      show "p \<notin> Units R"
        using ideal_eq_carrier_iff[of p] assms primeideal.I_notcarr[OF PIdl] by auto
    next
      fix a b assume a: "a \<in> carrier R" and b: "b \<in> carrier R" and dvd: "p divides a \<otimes> b"
      hence "a \<otimes> b \<in> PIdl p"
        by (meson assms DiffD1 cgenideal_self contra_subsetD m_closed to_contain_is_to_divide)
      hence "a \<in> PIdl p \<or> b \<in> PIdl p"
        using primeideal.I_prime[OF PIdl a b] by simp
      thus "p divides a \<or> p divides b"
        using assms a b Idl_subset_ideal' cgenideal_eq_genideal to_contain_is_to_divide by auto
    qed
  qed
next
  assume prime: "ring_prime p" show "primeideal (PIdl p) R"
  proof (rule primeidealI[OF cgenideal_ideal cring_axioms])
    show "p \<in> carrier R" and "carrier R \<noteq> PIdl p"
      using ideal_eq_carrier_iff[of p] assms prime
      unfolding ring_prime_def prime_def by auto
  next
    fix a b assume a: "a \<in> carrier R" and b: "b \<in> carrier R" "a \<otimes> b \<in> PIdl p"
    hence "p divides a \<otimes> b"
      using assms Idl_subset_ideal' cgenideal_eq_genideal to_contain_is_to_divide by auto
    hence "p divides a \<or> p divides b"
      using a b assms primeE[OF ring_primeE(3)[OF _ prime]] by auto
    thus "a \<in> PIdl p \<or> b \<in> PIdl p"
      using a b assms Idl_subset_ideal' cgenideal_eq_genideal to_contain_is_to_divide by auto
  qed
qed

subsection \<open>Noetherian Rings\<close>

lemma (in ring) chain_Union_is_ideal:
  assumes "subset.chain { I. ideal I R } C"
  shows "ideal (if C = {} then { \<zero> } else (\<Union>C)) R"
proof (cases "C = {}")
  case True thus ?thesis by (simp add: zeroideal)
next
  case False have "ideal (\<Union>C) R"
  proof (rule idealI[OF ring_axioms])
    show "subgroup (\<Union>C) (add_monoid R)"
    proof
      show "\<Union>C \<subseteq> carrier (add_monoid R)"
        using assms subgroup.subset[OF additive_subgroup.a_subgroup]
        unfolding pred_on.chain_def ideal_def by auto

      obtain I where I: "I \<in> C" "ideal I R"
        using False assms unfolding pred_on.chain_def by auto
      thus "\<one>\<^bsub>add_monoid R\<^esub> \<in> \<Union>C"
        using additive_subgroup.zero_closed[OF ideal.axioms(1)[OF I(2)]] by auto
    next
      fix x y assume "x \<in> \<Union>C" "y \<in> \<Union>C"
      then obtain I where I: "I \<in> C" "x \<in> I" "y \<in> I"
        using assms unfolding pred_on.chain_def by blast
      hence ideal: "ideal I R"
        using assms unfolding pred_on.chain_def by auto
      thus "x \<otimes>\<^bsub>add_monoid R\<^esub> y \<in> \<Union>C"
        using UnionI I additive_subgroup.a_closed unfolding ideal_def by fastforce

      show "inv\<^bsub>add_monoid R\<^esub> x \<in> \<Union>C"
        using UnionI I additive_subgroup.a_inv_closed ideal unfolding ideal_def a_inv_def by metis
    qed
  next
    fix a x assume a: "a \<in> \<Union>C" and x: "x \<in> carrier R"
    then obtain I where I: "ideal I R" "a \<in> I" and "I \<in> C"
      using assms unfolding pred_on.chain_def by auto
    thus "x \<otimes> a \<in> \<Union>C" and "a \<otimes> x \<in> \<Union>C"
      using ideal.I_l_closed[OF I x] ideal.I_r_closed[OF I x] by auto
  qed
  thus ?thesis
    using False by simp
qed

lemma (in noetherian_ring) ideal_chain_is_trivial:
  assumes "C \<noteq> {}" "subset.chain { I. ideal I R } C"
  shows "\<Union>C \<in> C"
proof -
  { fix S assume "finite S" "S \<subseteq> \<Union>C"
    hence "\<exists>I. I \<in> C \<and> S \<subseteq> I"
    proof (induct S)
      case empty thus ?case
        using assms(1) by blast
    next
      case (insert s S)
      then obtain I where I: "I \<in> C" "S \<subseteq> I"
        by blast
      moreover obtain I' where I': "I' \<in> C" "s \<in> I'"
        using insert(4) by blast
      ultimately have "I \<subseteq> I' \<or> I' \<subseteq> I"
        using assms unfolding pred_on.chain_def by blast
      thus ?case
        using I I' by blast
    qed } note aux_lemma = this

  obtain S where S: "finite S" "S \<subseteq> carrier R" "\<Union>C = Idl S"
    using finetely_gen[OF chain_Union_is_ideal[OF assms(2)]] assms(1) by auto
  then obtain I where I: "I \<in> C" and "S \<subseteq> I"
    using aux_lemma[OF S(1)] genideal_self[OF S(2)] by blast
  hence "Idl S \<subseteq> I"
    using assms unfolding pred_on.chain_def
    by (metis genideal_minimal mem_Collect_eq rev_subsetD)
  hence "\<Union>C = I"
    using S(3) I by auto
  thus ?thesis
    using I by simp
qed

lemma (in ring) trivial_ideal_chain_imp_noetherian:
  assumes "\<And>C. \<lbrakk> C \<noteq> {}; subset.chain { I. ideal I R } C \<rbrakk> \<Longrightarrow> \<Union>C \<in> C"
  shows "noetherian_ring R"
proof (rule noetherian_ringI)
  fix I assume I: "ideal I R"
  have in_carrier: "I \<subseteq> carrier R" and add_subgroup: "additive_subgroup I R"
    using ideal.axioms(1)[OF I] additive_subgroup.a_subset by auto

  define S where "S = { Idl S' | S'. S' \<subseteq> I \<and> finite S' }"
  have "\<exists>M \<in> S. \<forall>S' \<in> S. M \<subseteq> S' \<longrightarrow> S' = M"
  proof (rule subset_Zorn)
    fix C assume C: "subset.chain S C"
    show "\<exists>U \<in> S. \<forall>S' \<in> C. S' \<subseteq> U"
    proof (cases "C = {}")
      case True
      have "{ \<zero> } \<in> S"
        using additive_subgroup.zero_closed[OF add_subgroup] genideal_zero
        by (auto simp add: S_def)
      thus ?thesis
        using True by auto
    next
      case False
      have "S \<subseteq> { I. ideal I R }"
        using additive_subgroup.a_subset[OF add_subgroup] genideal_ideal
        by (auto simp add: S_def)
      hence "subset.chain { I. ideal I R } C"
        using C unfolding pred_on.chain_def by auto
      then have "\<Union>C \<in> C"
        using assms False by simp
      thus ?thesis
        by (meson C Union_upper pred_on.chain_def subsetCE)
    qed
  qed
  then obtain M where M: "M \<in> S" "\<And>S'. \<lbrakk>S' \<in> S; M \<subseteq> S' \<rbrakk> \<Longrightarrow> S' = M"
    by auto
  then obtain S' where S': "S' \<subseteq> I" "finite S'" "M = Idl S'"
    by (auto simp add: S_def)
  hence "M \<subseteq> I"
    using I genideal_minimal by (auto simp add: S_def)
  moreover have "I \<subseteq> M"
  proof (rule ccontr)
    assume "\<not> I \<subseteq> M"
    then obtain a where a: "a \<in> I" "a \<notin> M"
      by auto
    have "M \<subseteq> Idl (insert a S')"
      using S' a(1) genideal_minimal[of "Idl (insert a S')" S']
            in_carrier genideal_ideal genideal_self
      by (meson insert_subset subset_trans)
    moreover have "Idl (insert a S') \<in> S"
      using a(1) S' by (auto simp add: S_def)
    ultimately have "M = Idl (insert a S')"
      using M(2) by auto
    hence "a \<in> M"
      using genideal_self S'(1) a (1) in_carrier by (meson insert_subset subset_trans)
    from \<open>a \<in> M\<close> and \<open>a \<notin> M\<close> show False by simp
  qed
  ultimately have "M = I" by simp
  thus "\<exists>A \<subseteq> carrier R. finite A \<and> I = Idl A"
    using S' in_carrier by blast
qed

lemma (in noetherian_domain) factorization_property:
  assumes "a \<in> carrier R - { \<zero> }" "a \<notin> Units R"
  shows "\<exists>fs. set fs \<subseteq> carrier (mult_of R) \<and> wfactors (mult_of R) fs a" (is "?factorizable a")
proof (rule ccontr)
  assume a: "\<not> ?factorizable a"
  define S where "S = { PIdl r | r. r \<in> carrier R - { \<zero> } \<and> r \<notin> Units R \<and> \<not> ?factorizable r }"
  then obtain C where C: "subset.maxchain S C"
    using subset.Hausdorff by blast
  hence chain: "subset.chain S C"
    using pred_on.maxchain_def by blast
  moreover have "S \<subseteq> { I. ideal I R }"
    using cgenideal_ideal by (auto simp add: S_def)
  ultimately have "subset.chain { I. ideal I R } C"
    by (meson dual_order.trans pred_on.chain_def)
  moreover have "PIdl a \<in> S"
    using assms a by (auto simp add: S_def)
  hence "subset.chain S { PIdl a }"
    unfolding pred_on.chain_def by auto
  hence "C \<noteq> {}"
    using C unfolding pred_on.maxchain_def by auto
  ultimately have "\<Union>C \<in> C"
    using ideal_chain_is_trivial by simp
  hence "\<Union>C \<in> S"
    using chain unfolding pred_on.chain_def by auto
  then obtain r where r: "\<Union>C = PIdl r" "r \<in> carrier R - { \<zero> }" "r \<notin> Units R" "\<not> ?factorizable r"
    by (auto simp add: S_def)
  have "\<exists>p. p \<in> carrier R - { \<zero> } \<and> p \<notin> Units R \<and> \<not> ?factorizable p \<and> p divides r \<and> \<not> r divides p"
  proof -
    have "wfactors (mult_of R) [ r ] r" if "irreducible (mult_of R) r"
      using r(2) that unfolding wfactors_def by auto
    hence "\<not> irreducible (mult_of R) r"
      using r(2,4) by auto
    hence "\<not> ring_irreducible r"
      using ring_irreducibleE(3) r(2) by auto
    then obtain p1 p2
      where p1_p2: "p1 \<in> carrier R" "p2 \<in> carrier R" "r = p1 \<otimes> p2" "p1 \<notin> Units R" "p2 \<notin> Units R"
      using ring_irreducibleI[OF r(2-3)] by auto
    hence in_carrier: "p1 \<in> carrier (mult_of R)" "p2 \<in> carrier (mult_of R)"
      using r(2) by auto

    have "\<lbrakk> ?factorizable p1; ?factorizable p2 \<rbrakk> \<Longrightarrow> ?factorizable r"
      using mult_of.wfactors_mult[OF _ _ in_carrier] p1_p2(3) by (metis le_sup_iff set_append)
    hence "\<not> ?factorizable p1 \<or> \<not> ?factorizable p2"
      using r(4) by auto

    moreover
    have "\<And>p1 p2. \<lbrakk> p1 \<in> carrier R; p2 \<in> carrier R; r = p1 \<otimes> p2; r divides p1 \<rbrakk> \<Longrightarrow> p2 \<in> Units R"
    proof -
      fix p1 p2 assume A: "p1 \<in> carrier R" "p2 \<in> carrier R" "r = p1 \<otimes> p2" "r divides p1"
      then obtain c where c: "c \<in> carrier R" "p1 = r \<otimes> c"
        unfolding factor_def by blast
      hence "\<one> = c \<otimes> p2"
        using A m_lcancel[OF _ _ one_closed, of r "c \<otimes> p2"] r(2) by (auto, metis m_assoc m_closed)
      thus "p2 \<in> Units R"
        unfolding Units_def using c A(2) m_comm[OF c(1) A(2)] by auto
    qed
    hence "\<not> r divides p1" and "\<not> r divides p2"
      using p1_p2 m_comm[OF p1_p2(1-2)] by blast+

    ultimately show ?thesis
      using p1_p2 in_carrier by (metis carrier_mult_of dividesI' m_comm)
  qed
  then obtain p
    where p: "p \<in> carrier R - { \<zero> }" "p \<notin> Units R" "\<not> ?factorizable p" "p divides r" "\<not> r divides p"
    by blast
  hence "PIdl p \<in> S"
    unfolding S_def by auto
  moreover have "\<Union>C \<subset> PIdl p"
    using p r to_contain_is_to_divide unfolding r(1) by (metis Diff_iff psubsetI)
  ultimately have "subset.chain S (insert (PIdl p) C)" and "C \<subset> (insert (PIdl p) C)"
    unfolding pred_on.chain_def by (metis C psubsetE subset_maxchain_max, blast)
  thus False
    using C unfolding pred_on.maxchain_def by blast
qed

lemma (in noetherian_domain) exists_irreducible_divisor:
  assumes "a \<in> carrier R - { \<zero> }" and "a \<notin> Units R"
  obtains b where "b \<in> carrier R" and "ring_irreducible b" and "b divides a"
proof -
  obtain fs where set_fs: "set fs \<subseteq> carrier (mult_of R)" and "wfactors (mult_of R) fs a"
    using factorization_property[OF assms] by blast
  hence "a \<in> Units R" if "fs = []"
    using that assms(1) Units_cong assoc_iff_assoc_mult unfolding wfactors_def by (simp, blast)
  hence "fs \<noteq> []"
    using assms(2) by auto
  then obtain f' fs' where fs: "fs = f' # fs'"
    using list.exhaust by blast
  from \<open>wfactors (mult_of R) fs a\<close> have "f' divides a"
    using mult_of.wfactors_dividesI[OF _ set_fs] assms(1) unfolding fs by auto
  moreover from \<open>wfactors (mult_of R) fs a\<close> have "ring_irreducible f'" and "f' \<in> carrier R"
    using set_fs ring_irreducibleI'[of f'] unfolding wfactors_def fs by auto
  ultimately show thesis
    using that by blast
qed

subsection \<open>Principal Domains\<close>

sublocale principal_domain \<subseteq> noetherian_domain
proof
  fix I assume "ideal I R"
  then obtain i where "i \<in> carrier R" "I = Idl { i }"
    using exists_gen cgenideal_eq_genideal by auto
  thus "\<exists>A \<subseteq> carrier R. finite A \<and> I = Idl A"
    by blast
qed

lemma (in principal_domain) irreducible_imp_maximalideal:
  assumes "p \<in> carrier R"
    and "ring_irreducible p"
  shows "maximalideal (PIdl p) R"
proof (rule maximalidealI)
  show "ideal (PIdl p) R"
    using assms(1) by (simp add: cgenideal_ideal)
next
  show "carrier R \<noteq> PIdl p"
    using ideal_eq_carrier_iff[OF assms(1)] ring_irreducibleE(4)[OF assms] by auto
next
  fix J assume J: "ideal J R" "PIdl p \<subseteq> J" "J \<subseteq> carrier R"
  then obtain q where q: "q \<in> carrier R" "J = PIdl q"
    using exists_gen[OF J(1)] cgenideal_eq_rcos by metis
  hence "q divides p"
    using to_contain_is_to_divide[of q p] using assms(1) J(1-2) by simp
  then obtain r where r: "r \<in> carrier R" "p = q \<otimes> r"
    unfolding factor_def by auto
  hence "q \<in> Units R \<or> r \<in> Units R"
    using ring_irreducibleE(5)[OF assms q(1)] by auto
  thus "J = PIdl p \<or> J = carrier R"
  proof
    assume "q \<in> Units R" thus ?thesis
      using ideal_eq_carrier_iff[OF q(1)] q(2) by auto
  next
    assume "r \<in> Units R" hence "p \<sim> q"
      using assms(1) r q(1) associatedI2' by blast
    thus ?thesis
      unfolding associated_iff_same_ideal[OF assms(1) q(1)] q(2) by auto
  qed
qed

corollary (in principal_domain) primeness_condition:
  assumes "p \<in> carrier R"
  shows "ring_irreducible p \<longleftrightarrow> ring_prime p"
proof
  show "ring_irreducible p \<Longrightarrow> ring_prime p"
    using maximalideal_prime[OF irreducible_imp_maximalideal] ring_irreducibleE(1)
          primeideal_iff_prime assms by auto
next
  show "ring_prime p \<Longrightarrow> ring_irreducible p"
    using mult_of.prime_irreducible ring_primeI[of p] ring_irreducibleI' assms
    unfolding ring_prime_def prime_eq_prime_mult[OF assms] by auto
qed

lemma (in principal_domain) domain_iff_prime:
  assumes "a \<in> carrier R - { \<zero> }"
  shows "domain (R Quot (PIdl a)) \<longleftrightarrow> ring_prime a"
  using quot_domain_iff_primeideal[of "PIdl a"] primeideal_iff_prime[of a]
        cgenideal_ideal[of a] assms by auto

lemma (in principal_domain) field_iff_prime:
  assumes "a \<in> carrier R - { \<zero> }"
  shows "field (R Quot (PIdl a)) \<longleftrightarrow> ring_prime a"
proof
  show "ring_prime a \<Longrightarrow> field  (R Quot (PIdl a))"
    using  primeness_condition[of a] irreducible_imp_maximalideal[of a]
           maximalideal.quotient_is_field[of "PIdl a" R] is_cring assms by auto
next
  show "field  (R Quot (PIdl a)) \<Longrightarrow> ring_prime a"
    unfolding field_def using domain_iff_prime[of a] assms by auto
qed

sublocale principal_domain < mult_of: primeness_condition_monoid "mult_of R"
  rewrites "mult (mult_of R) = mult R"
       and "one  (mult_of R) = one R"
    unfolding primeness_condition_monoid_def
              primeness_condition_monoid_axioms_def
proof (auto simp add: mult_of.is_comm_monoid_cancel)
  fix a assume a: "a \<in> carrier R" "a \<noteq> \<zero>" "irreducible (mult_of R) a"
  show "prime (mult_of R) a"
    using primeness_condition[OF a(1)] irreducible_mult_imp_irreducible[OF _ a(3)] a(1-2)
    unfolding ring_prime_def ring_irreducible_def prime_eq_prime_mult[OF a(1)] by auto
qed

sublocale principal_domain < mult_of: factorial_monoid "mult_of R"
  rewrites "mult (mult_of R) = mult R"
       and "one  (mult_of R) = one R"
  using mult_of.wfactors_unique factorization_property mult_of.is_comm_monoid_cancel
  by (auto intro!: mult_of.factorial_monoidI)

sublocale principal_domain \<subseteq> factorial_domain
  unfolding factorial_domain_def using domain_axioms mult_of.factorial_monoid_axioms by simp

lemma (in principal_domain) ideal_sum_iff_gcd:
  assumes "a \<in> carrier R" "b \<in> carrier R" "d \<in> carrier R"
  shows "PIdl d = PIdl a <+>\<^bsub>R\<^esub> PIdl b \<longleftrightarrow> d gcdof a b"
proof -
  { fix a b d
    assume in_carrier: "a \<in> carrier R" "b \<in> carrier R" "d \<in> carrier R"
       and ideal_eq: "PIdl d = PIdl a <+>\<^bsub>R\<^esub> PIdl b"
    have "d gcdof a b"
    proof (auto simp add: isgcd_def)
      have "a \<in> PIdl d" and "b \<in> PIdl d"
        using in_carrier(1-2)[THEN cgenideal_ideal] additive_subgroup.zero_closed[OF ideal.axioms(1)]
              in_carrier(1-2)[THEN cgenideal_self] in_carrier(1-2)
        unfolding ideal_eq set_add_def' by force+
      thus "d divides a" and "d divides b"
        using in_carrier(1,2)[THEN to_contain_is_to_divide[OF in_carrier(3)]]
              cgenideal_minimal[OF cgenideal_ideal[OF in_carrier(3)]] by simp+
    next
      fix c assume c: "c \<in> carrier R" "c divides a" "c divides b"
      hence "PIdl a \<subseteq> PIdl c" and "PIdl b \<subseteq> PIdl c"
        using to_contain_is_to_divide in_carrier by auto
      hence "PIdl a <+>\<^bsub>R\<^esub> PIdl b \<subseteq> PIdl c"
        by (metis Un_subset_iff c(1) in_carrier(1-2) cgenideal_ideal genideal_minimal union_genideal)
      thus "c divides d"
        using ideal_eq to_contain_is_to_divide[OF c(1) in_carrier(3)] by simp
    qed } note aux_lemma = this

  have "PIdl d = PIdl a <+>\<^bsub>R\<^esub> PIdl b \<Longrightarrow> d gcdof a b"
    using aux_lemma assms by simp

  moreover
  have "d gcdof a b \<Longrightarrow> PIdl d = PIdl a <+>\<^bsub>R\<^esub> PIdl b"
  proof -
    assume d: "d gcdof a b"
    obtain c where c: "c \<in> carrier R" "PIdl c = PIdl a <+>\<^bsub>R\<^esub> PIdl b"
      using exists_gen[OF add_ideals[OF assms(1-2)[THEN cgenideal_ideal]]] by blast
    hence "c gcdof a b"
      using aux_lemma assms by simp
    from \<open>d gcdof a b\<close> and \<open>c gcdof a b\<close> have "d \<sim> c"
      using assms c(1) by (simp add: associated_def isgcd_def)
    thus ?thesis
      using c(2) associated_iff_same_ideal[OF assms(3) c(1)] by simp
  qed

  ultimately show ?thesis by auto
qed

lemma (in principal_domain) bezout_identity:
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "PIdl a <+>\<^bsub>R\<^esub> PIdl b = PIdl (somegcd R a b)"
proof -
  have "\<exists>d \<in> carrier R. d gcdof a b"
    using exists_gen[OF add_ideals[OF assms(1-2)[THEN cgenideal_ideal]]]
          ideal_sum_iff_gcd[OF assms(1-2)] by auto
  thus ?thesis
    using ideal_sum_iff_gcd[OF assms(1-2)] somegcd_def
    by (metis (no_types, lifting) tfl_some)
qed

subsection \<open>Euclidean Domains\<close>

sublocale euclidean_domain \<subseteq> principal_domain
  unfolding principal_domain_def principal_domain_axioms_def
proof (auto)
  show "domain R" by (simp add: domain_axioms)
next
  fix I assume I: "ideal I R" have "principalideal I R"
  proof (cases "I = { \<zero> }")
    case True thus ?thesis by (simp add: zeropideal)
  next
    case False hence A: "I - { \<zero> } \<noteq> {}"
      using I additive_subgroup.zero_closed ideal.axioms(1) by auto
    define phi_img :: "nat set" where "phi_img = (\<phi> ` (I - { \<zero> }))"
    hence "phi_img \<noteq> {}" using A by simp
    then obtain m where "m \<in> phi_img" "\<And>k. k \<in> phi_img \<Longrightarrow> m \<le> k"
      using exists_least_iff[of "\<lambda>n. n \<in> phi_img"] not_less by force
    then obtain a where a: "a \<in> I - { \<zero> }" "\<And>b. b \<in> I - { \<zero> } \<Longrightarrow> \<phi> a \<le> \<phi> b"
      using phi_img_def by blast
    have "I = PIdl a"
    proof (rule ccontr)
      assume "I \<noteq> PIdl a"
      then obtain b where b: "b \<in> I" "b \<notin> PIdl a"
        using I \<open>a \<in> I - {\<zero>}\<close> cgenideal_minimal by auto
      hence "b \<noteq> \<zero>"
        by (metis DiffD1 I a(1) additive_subgroup.zero_closed cgenideal_ideal ideal.Icarr ideal.axioms(1))
      then obtain q r
        where eucl_div: "q \<in> carrier R" "r \<in> carrier R" "b = (a \<otimes> q) \<oplus> r" "r = \<zero> \<or> \<phi> r < \<phi> a"
        using euclidean_function[of b a] a(1) b(1) ideal.Icarr[OF I] by auto
      hence "r = \<zero> \<Longrightarrow> b \<in> PIdl a"
        unfolding cgenideal_def using m_comm[of a] ideal.Icarr[OF I] a(1) by auto
      hence 1: "\<phi> r < \<phi> a \<and> r \<noteq> \<zero>"
        using eucl_div(4) b(2) by auto

      have "r = (\<ominus> (a \<otimes> q)) \<oplus> b"
        using eucl_div(1-3) a(1) b(1) ideal.Icarr[OF I] r_neg1 by auto
      moreover have "\<ominus> (a \<otimes> q) \<in> I"
        using eucl_div(1) a(1) I
        by (meson DiffD1 additive_subgroup.a_inv_closed ideal.I_r_closed ideal.axioms(1))
      ultimately have 2: "r \<in> I"
        using b(1) additive_subgroup.a_closed[OF ideal.axioms(1)[OF I]] by auto

      from 1 and 2 show False
        using a(2) by fastforce
    qed
    thus ?thesis
      by (meson DiffD1 I cgenideal_is_principalideal ideal.Icarr local.a(1))
  qed
  thus "\<exists>a \<in> carrier R. I = PIdl a"
    by (simp add: cgenideal_eq_genideal principalideal.generate)
qed

sublocale field \<subseteq> euclidean_domain R "\<lambda>_. 0"
proof (rule euclidean_domainI)
  fix a b
  let ?eucl_div = "\<lambda>q r. q \<in> carrier R \<and> r \<in> carrier R \<and> a = b \<otimes> q \<oplus> r \<and> (r = \<zero> \<or> 0 < 0)"

  assume a: "a \<in> carrier R - { \<zero> }" and b: "b \<in> carrier R - { \<zero> }"
  hence "a = b \<otimes> ((inv b) \<otimes> a) \<oplus> \<zero>"
    by (metis DiffD1 Units_inv_closed Units_r_inv field_Units l_one m_assoc r_zero)
  hence "?eucl_div _ ((inv b) \<otimes> a) \<zero>"
    using a b field_Units by auto
  thus "\<exists>q r. ?eucl_div _ q r"
    by blast
qed

end


(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section \<open>Connection between @{text "mod_ring"} and @{text "mod_type"}\<close>

text \<open>This file shows that the type @{text "mod_ring"}, which is defined in the
  Berlekamp--Zassenhaus development, is an instantiation of the type class @{text "mod_type"}.\<close>

theory Finite_Field_Mod_Type_Connection
  imports
  Berlekamp_Zassenhaus.Finite_Field
  Rank_Nullity_Theorem.Mod_Type
begin

instantiation mod_ring :: (finite) ord
begin
definition less_eq_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> bool"
  where "less_eq_mod_ring x y = (to_int_mod_ring x \<le> to_int_mod_ring y)"

definition less_mod_ring :: "'a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> bool"
  where "less_mod_ring x y = (to_int_mod_ring x < to_int_mod_ring y)"

instance proof qed
end

instantiation mod_ring :: (finite) linorder
begin
instance by (intro_classes, unfold less_eq_mod_ring_def less_mod_ring_def) (transfer, auto)
end

instance mod_ring :: (finite) wellorder
proof -
have "wf {(x :: 'a mod_ring, y). x < y}"
    by (auto simp add: trancl_def tranclp_less intro!: finite_acyclic_wf acyclicI)
  thus "OFCLASS('a mod_ring, wellorder_class)"
    by(rule wf_wellorderI) intro_classes
qed

lemma strict_mono_to_int_mod_ring: "strict_mono to_int_mod_ring"
  unfolding strict_mono_def unfolding less_mod_ring_def by auto

instantiation mod_ring :: (nontriv) mod_type
begin
definition Rep_mod_ring :: "'a mod_ring \<Rightarrow> int"
  where "Rep_mod_ring x = to_int_mod_ring x"

definition Abs_mod_ring :: "int \<Rightarrow> 'a mod_ring"
  where "Abs_mod_ring x = of_int_mod_ring x"

instance
proof (intro_classes)
  show "type_definition (Rep::'a mod_ring \<Rightarrow> int) Abs {0..<int CARD('a mod_ring)}"
    unfolding Rep_mod_ring_def Abs_mod_ring_def type_definition_def by (transfer, auto)
  show "1 < int CARD('a mod_ring)" using less_imp_of_nat_less nontriv by fastforce
  show "0 = (Abs::int \<Rightarrow> 'a mod_ring) 0"
    by (simp add: Abs_mod_ring_def)
  show "1 = (Abs::int \<Rightarrow> 'a mod_ring) 1"
    by (metis (mono_tags, opaque_lifting) Abs_mod_ring_def of_int_hom.hom_one of_int_of_int_mod_ring)
  fix x y::"'a mod_ring"
  show "x + y = Abs ((Rep x + Rep y) mod int CARD('a mod_ring))"
    unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto)
  show "- x = Abs (- Rep x mod int CARD('a mod_ring))"
    unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto simp add: zmod_zminus1_eq_if)
  show "x * y = Abs (Rep x * Rep y mod int CARD('a mod_ring))"
    unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto)
  show "x - y = Abs ((Rep x - Rep y) mod int CARD('a mod_ring))"
    unfolding Abs_mod_ring_def Rep_mod_ring_def by (transfer, auto)
  show "strict_mono (Rep::'a mod_ring \<Rightarrow> int)" unfolding Rep_mod_ring_def
    by (rule strict_mono_to_int_mod_ring)
qed
end
end


theory List_Demo
imports Main
begin

datatype 'a list = Nil | Cons "'a" "'a list"

term "Nil"

declare [[names_short]]

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

value "rev(Cons True (Cons False Nil))"

value "rev(Cons a (Cons b Nil))"

theorem rev_rev: "rev (rev xs) = xs"
apply (induction xs)
apply (auto)
done

end


theory CoBinaryTree
imports "$HIPSTER_HOME/IsaHipster"

begin
setup Misc_Data.set_noisy
setup Tactic_Data.set_sledgehammer_coinduct
(* setup Tactic_Data.set_no_proof *) (* If we only want to do exploration, no proofs *)
setup Misc_Data.set_time (* Print out timing info *)
setup Misc_Data.set_hammer_timeout_medium (* set sledgehammer timeout to 20 s*)

codatatype 'a Tree =
  Node (left: "'a Tree") (lab: 'a) (right: "'a Tree")

primcorec mirror :: "'a Tree => 'a Tree"
where
  "mirror t = (case t of (Node l x r) \<Rightarrow> Node (mirror r) x (mirror l))"

primcorec tmap :: "('a => 'b) => 'a Tree => 'b Tree"
where
 "tmap f t = (case t of (Node l x r) \<Rightarrow> Node (tmap f l) (f x) (tmap f r))"
cohipster mirror
lemma lemma_a [thy_expl]: "mirror (mirror y) = y"
  by(coinduction arbitrary: y rule: Tree.coinduct_strong)
    (simp add: Tree.case_eq_if)

lemma lemma_aa [thy_expl]: "Node (mirror x2) z (mirror y) = mirror (Node y z x2)"
by (simp add: mirror.code)

lemma lemma_ab [thy_expl]: "mirror (Node x2 z (mirror y)) = Node y z (mirror x2)"
  by (metis lemma_a lemma_aa)

lemma lemma_ac [thy_expl]: "mirror (Node (mirror x2) z y) = Node (mirror y) z x2"
  by (metis lemma_a lemma_aa)

cohipster mirror tmap
lemma lemma_ad [thy_expl]: "tmap z (mirror x2) = mirror (tmap z x2)"
by(coinduction arbitrary: x2 z rule: Tree.coinduct_strong)
  (smt Tree.case_eq_if mirror.simps(1) mirror.simps(2) mirror.simps(3) tmap.simps(1) tmap.simps(2) tmap.simps(3))

primcorec tsum :: "nat Tree \<Rightarrow> nat Tree \<Rightarrow> nat Tree"
  where  "tsum t u = (case t of (Node tle tx tr) \<Rightarrow> case u of (Node ul ux ur) \<Rightarrow> Node (tsum tle ul) (tx+ux) (tsum tr ur))"

cohipster tsum mirror
lemma lemma_ae [thy_expl]: "tsum y x = tsum x y"
  by(coinduction arbitrary: x y rule: Tree.coinduct_strong)
    (smt Tree.case_eq_if add.commute tsum.simps(1) tsum.simps(2) tsum.simps(3))

lemma lemma_af [thy_expl]: "tsum (tsum x y) z = tsum x (tsum y z)"
  by(coinduction arbitrary: x y z rule: Tree.coinduct_strong)
(smt Tree.case_eq_if ab_semigroup_add_class.add_ac(1) tsum.simps(1) tsum.simps(2) tsum.simps(3))

lemma lemma_ag [thy_expl]: "mirror (tsum y (mirror x)) = tsum x (mirror y)"
by(coinduction arbitrary: x y rule: Tree.coinduct_strong)
  (smt Tree.case_eq_if lemma_ae mirror.simps(1) mirror.simps(2) mirror.simps(3) tsum.simps(1) tsum.simps(2) tsum.simps(3))

lemma lemma_ah [thy_expl]: "tsum (mirror x) (mirror y) = mirror (tsum x y)"
  by (metis lemma_a lemma_ae lemma_ag)

lemma lemma_ai [thy_expl]: "mirror (tsum x (tsum y (mirror z))) = tsum (mirror (tsum x y)) z"
  by (metis lemma_ae lemma_af lemma_ag)

end


(*<*)
theory  T8TeoriaHintikkaIngles
imports T7ConjuntoMaximalIngles
begin
(*>*)

subsection \<open> Conjuntos de Hintikka y models de Hintikka \<close>

text \<open>
  \label{hintikka}
  En esta sección introducimos el concepto de conjunto de
  Hintikka y demostramos que en un lenguaje proposicional, cualquier
  subconjunto de un {\em {conjunto de Hintikka}} es {\em satisfiable}.
\<close>

text \<open>
  \begin{definicion}\label{DefhintikkaP}
  Un conjunto $H$ de fórmulas proposicionales es un {\bf{conjunto de
  Hintikka}} si cumple las siguientes condiciones:
  \begin{enumerate}
  \item Para cualquier fórmula atómica $P$, $P\notin H$ o $\neg P\notin H$.
  \item $\bot\notin H$ y $\neg \top\notin H$.
  \item Si $\neg \neg F \in H$ entonces $F\in H$.
  \item Si $\alpha\in H$ entonces, $\alpha_1 \in H$ y $\alpha_2 \in H$.
  \item Si $\beta\in H$ entonces, $\beta_1\in H$ o $\beta_2\in H$.
  \end{enumerate}
  \end{definicion}

  \noindent Su formalización es:
\<close>

definition hintikkaP :: "'b formula set \<Rightarrow> bool" where
  "hintikkaP H = ((\<forall>P. \<not> (atom P \<in> H \<and> (\<not>.atom P) \<in> H)) \<and>
                 FF \<notin> H \<and> (\<not>.TT) \<notin> H \<and>
                 (\<forall>F. (\<not>.\<not>.F) \<in> H \<longrightarrow> F \<in> H) \<and>
                 (\<forall>F. ((FormulaAlfa F) \<and> F \<in> H) \<longrightarrow>
                      ((Comp1 F) \<in> H \<and> (Comp2 F) \<in> H)) \<and>
                 (\<forall>F. ((FormulaBeta F) \<and> F \<in> H) \<longrightarrow>
                      ((Comp1 F) \<in> H \<or> (Comp2 F) \<in> H)))"

subsection \<open> Satisfactibilidad de conjuntos de Hintikka \<close>

text\<open>
  \label{interpretacionhintikka}
  En esta sección mostramos que cualquier conjunto de Hintikka
  proposicional tiene un model (definición \ref{modelP}). Para la
  demostración, a cada conjunto de Hintikka le asocia\-mos una {\em
  interpretación de Hintikka}.

  \begin{definicion}
  Sea $H$ un conjunto de fórmulas proposicionales, definimos la
  interpretación $I_H$ como sigue: sea $P$ un símbolo proposicional,
  entonces
  \newline \hspace*{1cm}
  \[I_H(P) = \begin{cases}
             \V, & \text{si $P\in H$} \\
             \F, & \text{en otro caso.}
           \end{cases}
  \]

  Si $H$ es un conjunto de Hintikka, $I_H$ es llamada una
  {\bf{interpretación de Hintikka}}.
  \end{definicion}
\<close>

text \<open>
  La formalización en Isabelle de la interpretacion $I_H$ es la siguiente:
\<close>

fun IH :: "'b formula set  \<Rightarrow> 'b \<Rightarrow> v_truth" where
  "IH H P = (if atom P \<in> H then Ttrue else Ffalse)"

text \<open>

  A continuación demostramos que si $H$ es de Hintikka entonces $I_H$ es
  un mode\-lo de $H$.  Para la demostración probamos por inducción bien
  fundamentada sobre el {\em tamaño} de una fórmula la siguiente
  afirmación equivalente: {\em dado un conjunto de Hintikka} $H$,
  {\em si} $F\in {H}$ {\em entonces} $I'_H(F)=\V$, {\em y} {\em si}
  $\neg F\in H$ {\em entonces} $I'_H(\neg F)=\V$.

  En general, si tenemos una relación $\prec$ bien fundamentada en un
  conjunto $A$ y una propiedad $P$ sobre $A$, la regla de inferencia por
  inducción bien fundamentada se enuncia de la siguiente manera:
  \[\begin{array}{c}
      [\forall y (y\prec x \Rightarrow P(y))]\\
      \vdots\\
      \displaystyle \frac{P(x)}{P(a)}
    \end{array}
  \]

  Es decir, para demostrar $P(a)$ para un elemento $a\in A$, es
  suficiente demostrar $P(x)$ para un $x$ arbitrario usando como
  hipótesis, si $y\prec x$ entonces $P(y)$.

  En Isabelle esta regla de inducción @{text "wf_induct"}, se expresa de
  la siguiente forma:

  \begin{center}
  @{thm[mode=Rule] wf_induct[no_vars]}
  \end{center}

  \noindent
  o también,

  \begin{center}
  @{thm wf_induct[no_vars]}
  \end{center}

  En donde {\em wf r} afirma que la relación $r$ es {\em bien
  fundamentada}.
\<close>

text \<open>
  \begin{teorema}\label{hintikkaP-model-aux}
  Sea $H$ un conjunto de Hintikka. Si $F\in {H}$ entonces
  $I'_H(F)=\V$, y si $\neg F\in H$ entonces $I'_H(\neg F)=\V$.
  \end{teorema}

  {\bf{Demostración:}}
  La demostración es por inducción bien fundamentada.  Para definir la
  relación bien fundamentada $\prec$ en el conjunto de fórmulas,
  conside\-ramos la función {\em tamaño}, que determina el tamaño de una
  fórmula.

\begin{definicion}\label{tamano} Sean $F$ y $G$ fórmulas, entonces
  \begin{itemize}
    \item tamaño(F) = 1 si $F$ es una fórmula atómica, $\bot$ o $\top$
    \item tamaño$(\neg F)$ = 1 + tamaño(F)\
    \item tamaño$(F\wedge G)$ = tamaño$(F\vee G)$ =
          tamaño$(F \rightarrow G)$ = 1+tamaño(F)+ tamaño(G)
  \end{itemize}
  \end{definicion}
\<close>

(*<*)
primrec tamano :: "'b formula \<Rightarrow> nat" where
  "tamano FF = 1"
| "tamano TT = 1"
| "tamano (atom P) = 1"
| "tamano (\<not>. F) = (tamano F) + 1"
| "tamano (F \<and>. G) = (tamano F) + (tamano G) + 1"
| "tamano (F \<or>. G) = (tamano F) + (tamano G) + 1"
| "tamano (F \<rightarrow>. G) = (tamano F) + (tamano G) + 1"

lemma ptamano: "0 < tamano F"
by (induct F) auto
(*>*)

text \<open>

  Así, la relación $\prec$ es igual a la imagen inversa de la relación
  en $\mathbb{N}$ inducida por la función de medida {\em tamaño},
  $$F \prec G \Longleftrightarrow \mbox{\em tamaño}(F)<\mbox{\em tamaño}(G).$$

  Puesto que la relación $<$ ({\em menor que}) en $\mathbb{N}$ es bien
  fundamentada entonces, $\prec$ es bien fundamentada.

  Sea $F$ una fórmula arbitraria, la hipótesis de inducción afirma que
  si $G \prec F$ entonces, si $G\in H$ entonces $I'_H(G) =\V$, y si
  $\neg G\in H$ entonces $I'_H(\neg G)=\V$.

  Hay que demostrar que,
  si $F\in H$, entonces $I'_H(F)=\V$ y
  si $\neg F\in H$, entonces $I'_H(\neg F) = \V$.

  La demostración es por casos en la fórmula $F$.

  {\bf{Caso 1:}} Supongamos que $F$ es la fórmula $\bot$.

  {\bf{Caso 1.a:}} Por hipótesis $H$ es un conjunto de Hintikka, luego
  $\bot\notin H$.  Por lo tanto la implicación, si $\bot\in H$ entonces
  $I'_H(\bot)=\V$, es verdadera.

  {\bf{Caso 1.b:}} Por definición,
  $I'_H(\neg \bot) = \neg I'_H(\bot)= \V$.
  Por lo tanto, la implicación, si
  $\neg \bot\in H$ entonces $\neg I'_H(\bot)=\V$, es verdadera.

  {\bf{Caso 2:}} Supongamos que $F$ es la fórmula $\top$.

  {\bf{Caso 2.a:}} Por definición, $I'_H(\top)=\V$. Por lo tanto la
  implicación, si $\top\in H$ entonces $I'_H(\top)=\V$, es verdadera.

  {\bf{Caso 2.b:}} Por hipótesis $H$ es un conjunto de Hintikka, luego
  $\neg {\top}\notin H$. Por lo tanto la implicación, si $\neg \top\in
  H$ entonces $I'_H(\neg \top)=\V$, es verdadera.

  {\bf{Caso 3:}} Supongamos que $F$ es la fórmula atómica $P$.

  {\bf{Caso 3.a:}} Supongamos que $P\in H$, entonces, por definición de
  $I_H$, $I'_H(P)=\V$.

  {\bf{Caso 3.b:}} Supongamos que $\neg P\in H$. Puesto que $H$ es de
  Hintikka, se tiene que $P\notin H$ o $\neg P \notin H$. Luego,
  $P\notin H$ ya que $\neg P \in H$. Por lo tanto $I'_H(P)= \F$, por
  definición de $I_H$.  De esta forma,
  $I'_H(\neg P) = \neg (I'_H(P)) = \V$.

  {\bf{Caso 4:}} Sea $F$ la fórmula $F_1 \wedge F_2$.

  {\bf{Caso 4.a:}} Supongamos que $F_1 \wedge F_2\in H$.  Puesto que $H$
  es de Hintikka se tiene que, $F_1 \in H$ y $F_2 \in H$.  También, por
  la definición del tamaño de una fórmula se tiene que
  $F_1 \prec (F_1 \wedge F_2)$ y $F_2 \prec (F_1 \wedge F_2)$,
  por consiguiente usando la hipótesis de inducción te\-nemos que las
  siguientes dos implicaciones son verdaderas:

  Si $F_1\in H$ entonces $I'_H(F_1)=\V$, y si $F_2\in H$ entonces
  $I'_H(F_2)=\V$.

  De esta forma, $I'_H(F_1)=\V$ y $I'_H(F_2) = \V$. Luego, por la
  definición del t_v_evaluation de una fórmula tenemos que,
  $I'_H(F_1\wedge F_2)= I'_H(F_1)\wedge I'_H(F_2) = \V$.

  {\bf{Caso 4.b:}} Supongamos que $\neg (F_1\wedge F_2)\in H$.  Puesto
  que $H$ es de Hintikka se tiene que,
  $\neg F_1 \in H$ o $\neg F_2 \in H$.  A partir de la anterior
  disyunción mostramos, por eliminación de la disyunción, que
  $I'_H(\neg (F_1\wedge F_2))=\V$.

  {\bf{Caso 4.b.1:}} Supongamos que $\neg F_1 \in H$.  Por la definición
  del tamaño de una fórmula se tiene que
  $\neg F_1 \prec (F_1 \wedge F_2)$ y por lo tanto por la hipótesis de
  inducción tenemos que la implicación, si
  $\neg F_1\in H$ entonces $I'_H(\neg F_1)=\V$ es verdadera.  De lo
  anterior, se tiene que $I'_H(\neg F_1)=\V$, es decir, $\neg
  (I'_H(F_1))=\V$.  Por lo tanto, $I'_H(\neg (F_1\wedge F_2)) = \V$.

  {\bf{Caso 4.b.2:}} Supongamos que $\neg F_2 \in H$. La demostración es
  igual que la del caso anterior.

  Los otros casos, cuando $F$ es $F_1 \vee F_2, F_1 \rightarrow F_2$ o
  $\neg F$, se demuestran en forma similar a los anteriores.
\<close>

(*<*)
text \<open>
  {\bf{Caso 5:}} Supongamos que $F$ es la fórmula $F_1 \vee F_2.$

  {\bf{Caso 5.a:}} Supongamos que $F_1 \vee F_2\in H$.  Puesto que $H$
  es de Hintikka se tiene que, $F_1 \in H$ o $F_2 \in H$.  A partir de
  la anterior disyunción mostramos, por eliminación de la disyunción,
  que $I'_H(F_1\vee F_2)=\V$.

  {\bf{Caso 5.a.1:}} Supongamos $F_1 \in H.$ Por la definición del
  tamaño de una fórmula se tiene que \linebreak
  $F_1 \prec (F_1 \vee F_2)$ y por lo tanto por la hipótesis de
  inducción tenemos que la implicación es verdadera, si
  $F_1\in H$ entonces $I'_H(F_1)=\V$. De lo anterior, $I'_H(F_1)=\V$.
  Por lo tanto, $I'_H(F_1\vee F_2) = I'_H(F_1)\vee I'_H(F_2)= \V$.

  {\bf{Caso 5.a.2:}} Supongamos $F_2 \in H.$ La demostración es igual
  que la del caso (a.1).

  {\bf{Caso 5.b:}} Supongamos que $\neg(F_1 \vee F_2)\in H$.  Puesto que
  $H$ es de Hintikka se tiene que, $\neg F_1 \in H$ y $\neg F_2 \in H$
  ya que $\neg(F_1 \vee F_2)\in H$.  Por la definición del tamaño de una
  fórmula se tiene que $\neg F_1 \prec (F_1 \vee F_2)$ y $\neg F_2 \prec (F_1 \vee
  F_2)$, por consiguiente usando la hipótesis de inducción tenemos que
  las siguientes dos implicaciones son verdaderas, si $\neg F_1\in H$
  entonces $I'_H(\neg F_1)=\V$, y si $\neg F_2\in H$ y $F_2$ entonces
  $I'_H(\neg F_2)=\V$.

  De esta forma, $I'_H(\neg F_1)=\V$ y $I'_H(\neg F_2)=\V$. Luego, por
  la definición del t_v_evaluation de una fórmula tenemos que,\\

  $\begin{array}{lll}
      I'_H(\neg (F_1\vee F_2)) & = & \neg I'_H(F_1 \vee F_2)\\
                               & = & \neg(I'_H(F_1)\vee I'_H(F_2))\\
                               & = & \neg I'_H(F_1)\wedge \neg I'_H(F_2)\\
                               & = & I'_H(\neg F_1)\wedge I'_H(\neg F_2)\\
                               & = & \V.\\
   \end{array}$

  {\bf{Caso 6:}} Supongamos que $F$ es la fórmula $F_1 \rightarrow F_2.$

  {\bf{Caso 6.a:}} Supongamos que $F_1 \rightarrow F_2\in H$.  Puesto
  que $H$ es de Hintikka se tiene que, $\neg F_1 \in H$ o $F_2 \in H$.
  A partir de la anterior disyunción mostramos, por eliminación de la
  disyunción, que $I'_H(F_1\rightarrow F_2)=\V$.

  {\bf{Caso 6.a.1:}} Supongamos $\neg F_1 \in H.$ Por la definición del
  tamaño de una fórmula se tiene que $\neg F_1 \prec (F_1 \rightarrow F_2)$ y
  por lo tanto por la hipótesis de inducción tenemos que la siguiente
  implicación es verdadera, si $\neg F_1\in H$ entonces $I'_H(\neg
  F_1)=\V$.

  De lo anterior, $I'_H(\neg F_1)=\V$, es decir, $\neg I'_H(F_1)=\V$.
  Por lo tanto, $I'_H(F_1\rightarrow F_2)= I'_H(F_1)\rightarrow
  I'_H(F_2) = \V$.

  {\bf{Caso 6.a.2:}} Supongamos $F_2 \in H.$ Por la definición del
  tamaño de una fórmula se tiene que $F_2 \prec (F_1 \rightarrow F_2)$ y
  por lo tanto por la hipótesis de inducción tenemos que la siguiente
  implicación es verdadera, si $F_2\in H$ entonces $I'_H(F_2)=\V$.  De
  lo anterior, $I'_H(F_2)=\V$.  Por lo tanto, $I'_H(F_1\rightarrow F_2)
  = I'_H(F_1) \rightarrow I'_H(F_2) = \V$.

  {\bf{Caso 6.b:}} Supongamos que $\neg(F_1 \rightarrow F_2)\in H$.
  Puesto que $H$ es de Hintikka se tiene que, $F_1 \in H$ y $\neg F_2
  \in H$.  Por la definición del tamaño de una fórmula se tiene que $F_1
  \prec (F_1 \rightarrow F_2)$ y $\neg F_2 \prec (F_1 \rightarrow F_2)$, por
  consiguiente usando la hipótesis de inducción tenemos que las
  siguientes dos implicaciones son verdaderas, si $F_1\in H$ entonces
  $I'_H(F_1)=\V$, y si $\neg F_2\in H$ entonces $I'_H(\neg F_2)=\V$.  De
  esta forma, $I'_H(F_1)=\V$ y $I'_H(\neg F_2)=\V$.

  Por lo tanto $I'_H(F_1) \rightarrow I'_H(F_2) = \F$.  Luego, por la
  definición del t_v_evaluation de una fórmula tenemos que, $I'_H(\neg (F_1
  \rightarrow F_2)) = \neg I'_H(F_1 \rightarrow F_2) = \neg (I'_H(F_1)
  \rightarrow I'_H(F_2))=\V .$

  {\bf{Caso 7:}} Supongamos que $F$ es la fórmula $\neg F.$

  {\bf{Caso 7.a:}} Supongamos que $\neg F\in H$.  Por la definición del
  tamaño de una fórmula se tiene que $F \prec \neg F$, por consiguiente
  usando la hipótesis de inducción tenemos que la siguiente implicación
  es verdadera, si $\neg F\in H$ entonces $I'_H(\neg F) = \V$. De esta
  forma, $I'_H(\neg F) = \V$.

  {\bf{Caso 7.b:}} Supongamos que $\neg \neg F\in H$.  Puesto que $H$ es
  de Hintikka se tiene que $F\in H$.  Por la definición del tamaño de
  una fórmula se tiene que $F \prec \neg F$, por lo tanto usando la
  hipótesis de inducción tenemos que la siguiente implicación es
  verdadera, si $F\in H$ entonces $I'_H(F) = \V$. De esta forma,
  $I'_H(F) = \V$. De esto último por la definición del t_v_evaluation de una
  fórmula se tiene que, $\neg \neg I'_H(F)= \V$.
\<close>

(*>*)
text \<open>
  Los diferentes casos del teorema anterior se formalizan por medio de
  los si\-guientes lemas.  La relación @{text "measure tamano"} en
  Isabelle corresponde a la formalización de la relación $\prec$.
\<close>

lemma casoP1:
assumes hip1: "hintikkaP H" and
hip2: "\<forall>G. (G, FF) \<in> measure tamano \<longrightarrow>
(G \<in> H \<longrightarrow> t_v_evaluation (IH H) G = Ttrue) \<and> ((\<not>.G) \<in> H  \<longrightarrow> t_v_evaluation (IH H) (\<not>.G)= Ttrue)"
shows "(FF \<in> H \<longrightarrow> t_v_evaluation (IH H) FF = Ttrue) \<and> ((\<not>.FF) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.FF)=Ttrue)"
(*<*)
proof(rule conjI)
  show "(FF \<in> H \<longrightarrow>  t_v_evaluation (IH H) FF = Ttrue)"
  proof -
    have "FF \<notin> H" using hip1 by (unfold hintikkaP_def) auto
    thus "FF \<in> H \<longrightarrow> t_v_evaluation (IH H) FF = Ttrue" by simp
  qed
  next
  show "(\<not>.FF) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.FF)=Ttrue"
  proof -
    have "t_v_evaluation (IH H) (\<not>.FF)= Ttrue" by(simp add: v_negation_def)
    thus ?thesis by simp
  qed
qed
(*>*)
text\<open> \<close>
lemma casoP2:
assumes hip1: "hintikkaP H" and
hip2: "\<forall>G. (G, TT) \<in> measure tamano \<longrightarrow>
(G \<in> H \<longrightarrow> t_v_evaluation (IH H) G = Ttrue) \<and> ((\<not>.G) \<in> H  \<longrightarrow> t_v_evaluation (IH H) (\<not>.G)= Ttrue)"
shows
"(TT \<in> H \<longrightarrow> t_v_evaluation (IH H) TT = Ttrue) \<and> ((\<not>.TT) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.TT)=Ttrue)"
(*<*)
proof(rule conjI)
  show "TT \<in> H \<longrightarrow> t_v_evaluation (IH H) TT = Ttrue"
  by simp
  next
  show "(\<not>.TT) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.TT)=Ttrue"
  proof -
    have "(\<not>.TT) \<notin> H" using hip1 by (unfold hintikkaP_def) auto
    thus "(\<not>.TT) \<in> H  \<longrightarrow> t_v_evaluation (IH H) (\<not>.TT)=Ttrue"
    by simp
  qed
qed
(*>*)
text\<open> \<close>
lemma casoP3:
assumes hip1: "hintikkaP H" and
hip2: "\<forall>G. (G, atom P) \<in> measure tamano \<longrightarrow>
(G \<in> H \<longrightarrow> t_v_evaluation (IH H) G = Ttrue) \<and> ((\<not>.G) \<in> H  \<longrightarrow> t_v_evaluation (IH H) (\<not>.G)= Ttrue)"
shows "(atom P \<in> H  \<longrightarrow> t_v_evaluation (IH H) (atom P) = Ttrue) \<and>
((\<not>.atom P) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.atom P) = Ttrue)"
(*<*)
proof(rule conjI)
  show "(atom P)  \<in> H \<longrightarrow> t_v_evaluation (IH H) (atom P) = Ttrue" by simp
  next
  show "(\<not>.atom P) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.atom P) = Ttrue"
  proof(rule conjI impI)
    assume h1: "\<not>.atom P \<in> H"
    show "t_v_evaluation (IH H) (\<not>.atom P) = Ttrue"
    proof -
      have "\<forall>p. \<not> (atom p \<in> H \<and> (\<not>.atom p) \<in> H)"
      using hip1 conjunct1 by(unfold hintikkaP_def)
      hence "atom P \<notin> H" using h1 by auto
      hence "t_v_evaluation (IH H) (atom P) = Ffalse" by simp
      thus ?thesis by(simp add: v_negation_def)
    qed
  qed
qed
(*>*)
text\<open> \<close>
lemma casoP4:
assumes hip1: "hintikkaP H" and
hip2: "\<forall>G. (G, F1 \<and>. F2) \<in> measure tamano \<longrightarrow>
(G \<in> H \<longrightarrow> t_v_evaluation (IH H) G = Ttrue) \<and> ((\<not>.G) \<in> H  \<longrightarrow> t_v_evaluation (IH H) (\<not>.G) = Ttrue)"
shows "((F1 \<and>. F2) \<in> H \<longrightarrow> t_v_evaluation (IH H) (F1 \<and>. F2) = Ttrue) \<and>
((\<not>.(F1 \<and>. F2)) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.(F1 \<and>. F2)) = Ttrue)"
(*<*)
proof(rule conjI)
  show "((F1 \<and>. F2) \<in> H \<longrightarrow> t_v_evaluation (IH H) (F1 \<and>. F2) = Ttrue)"
  proof(rule conjI impI)
    assume h2: "(F1 \<and>. F2) \<in> H"
    show  "t_v_evaluation (IH H) (F1 \<and>. F2) = Ttrue"
    proof -
      have "FormulaAlfa (F1 \<and>. F2)" by simp
      hence "Comp1 (F1 \<and>. F2) \<in> H \<and> Comp2 (F1 \<and>. F2) \<in> H"
      using hip1 h2 by(auto simp add: hintikkaP_def)
      hence "F1 \<in> H" and "F2 \<in> H" by(unfold Comp1_def, unfold Comp2_def, auto)
      moreover
      have "(F1, F1 \<and>. F2) \<in> measure tamano" and
      "(F2, F1 \<and>. F2) \<in> measure tamano"
      by auto
      hence "(F1 \<in> H \<longrightarrow> t_v_evaluation (IH H) F1 = Ttrue)" and
      "(F2 \<in> H \<longrightarrow> t_v_evaluation (IH H) F2 = Ttrue)"
      using hip2 by auto
      ultimately
      have "t_v_evaluation (IH H) F1 = Ttrue" and "t_v_evaluation (IH H) F2 = Ttrue"
      by auto
      thus ?thesis by (simp add: v_conjunction_def)
    qed
  qed
  next
  show "\<not>.(F1 \<and>. F2) \<in> H \<longrightarrow> t_v_evaluation (IH H)  (\<not>.(F1 \<and>. F2)) = Ttrue"
  proof(rule impI)
    assume h2: "(\<not>.(F1 \<and>. F2)) \<in> H"
    show "t_v_evaluation (IH H) (\<not>.(F1 \<and>. F2)) = Ttrue"
    proof -
      have "FormulaBeta (\<not>.(F1 \<and>. F2))" by simp
      hence "Comp1 (\<not>.(F1 \<and>. F2)) \<in> H \<or> Comp2 (\<not>.(F1 \<and>. F2)) \<in> H"
      using hip1 h2 by(auto simp add: hintikkaP_def)
      hence "(\<not>.F1) \<in> H \<or> (\<not>.F2) \<in> H" by(unfold Comp1_def, unfold Comp2_def, auto)
      thus ?thesis
      proof(rule disjE)
        assume "(\<not>.F1) \<in> H"
        moreover
        have "(\<not>.F1, (F1 \<and>. F2)) \<in> measure tamano" using ptamano by simp
        hence "(\<not>.F1) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.F1) = Ttrue"
        using hip2 by simp
        ultimately
        have 1: "t_v_evaluation (IH H) (\<not>.F1) = Ttrue" by simp
        hence "t_v_evaluation (IH H) F1 = Ffalse" using NegationValues2 by auto
        thus "t_v_evaluation (IH H) (\<not>.(F1 \<and>. F2)) = Ttrue"
        by (simp add: v_negation_def, simp add: v_conjunction_def)          next
        assume "(\<not>.F2) \<in> H"
        moreover
        have "(\<not>.F2, (F1 \<and>. F2)) \<in> measure tamano" using ptamano by simp
        hence " (\<not>.F2) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.F2)= Ttrue"
        using hip2 by simp
        ultimately
        have 1: "t_v_evaluation (IH H) (\<not>.F2) = Ttrue" by simp
        hence "t_v_evaluation (IH H) F2 = Ffalse" using NegationValues2 by auto
        thus "t_v_evaluation (IH H) (\<not>.(F1 \<and>. F2)) = Ttrue"
        by (simp add: v_negation_def, simp add: v_conjunction_def)
      qed
    qed
  qed
qed
(*>*)
text\<open> \<close>
lemma casoP5:
assumes hip1: "hintikkaP H" and
hip2: "\<forall>G. (G, F1 \<or>. F2) \<in> measure tamano \<longrightarrow>
(G \<in> H \<longrightarrow> t_v_evaluation (IH H) G = Ttrue) \<and> ((\<not>.G) \<in> H  \<longrightarrow> t_v_evaluation (IH H) (\<not>.G) = Ttrue)"
shows "((F1 \<or>. F2) \<in> H \<longrightarrow> t_v_evaluation (IH H) (F1 \<or>. F2) = Ttrue) \<and>
((\<not>.(F1 \<or>. F2)) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.(F1 \<or>. F2)) = Ttrue)"
(*<*)
proof(rule conjI)
  show "(F1 \<or>. F2) \<in> H \<longrightarrow> t_v_evaluation (IH H) (F1 \<or>. F2) = Ttrue"
  proof(rule conjI impI)
    assume h2: "(F1  \<or>. F2) \<in> H"
    show "t_v_evaluation (IH H) (F1 \<or>. F2) = Ttrue"
    proof -
      have "FormulaBeta (F1 \<or>.F2)" by simp
      hence "Comp1 (F1 \<or>.F2) \<in> H \<or> Comp2 (F1 \<or>.F2) \<in> H"
      using hip1 h2 by(auto simp add: hintikkaP_def)
      hence "F1 \<in> H \<or> F2 \<in> H" by(unfold Comp1_def, unfold Comp2_def, auto)
      thus ?thesis
      proof(rule disjE)
        assume "F1 \<in> H"
        moreover
        have "(F1, F1 \<or>. F2) \<in> measure tamano" by simp
        hence "(F1 \<in> H \<longrightarrow>  t_v_evaluation (IH H) F1 = Ttrue)"
        using hip2 by simp
        ultimately
        have "t_v_evaluation (IH H) F1 = Ttrue" by simp
        thus "t_v_evaluation (IH H) (F1 \<or>. F2) = Ttrue" by (simp add: v_disjunction_def)
        next
        assume "F2 \<in> H"
        moreover
        have "(F2, (F1 \<or>. F2)) \<in> measure tamano" by simp
        hence "F2 \<in> H \<longrightarrow>  t_v_evaluation (IH H) F2 =Ttrue"
        using hip2 by simp
        ultimately
        have "t_v_evaluation (IH H) F2 = Ttrue" by simp
        thus "t_v_evaluation (IH H) (F1 \<or>. F2) = Ttrue" by (simp add: v_disjunction_def)
      qed
    qed
  qed
  next
  show "(\<not>.(F1 \<or>. F2)) \<in> H \<longrightarrow>
  t_v_evaluation (IH H) (\<not>.(F1 \<or>. F2)) = Ttrue"
  proof(rule impI)
    assume h2: "(\<not>.(F1  \<or>. F2)) \<in> H"
    show "t_v_evaluation (IH H) (\<not>.(F1  \<or>. F2)) = Ttrue"
    proof -
      have "FormulaAlfa(\<not>.(F1 \<or>. F2))" by simp
      hence "Comp1 (\<not>.(F1 \<or>. F2)) \<in> H \<and> Comp2 (\<not>.(F1 \<or>. F2)) \<in> H"
      using hip1 h2 by(auto simp add: hintikkaP_def)
      hence "\<not>.F1 \<in> H \<and> \<not>.F2 \<in> H" by(unfold Comp1_def, unfold Comp2_def, auto)
      hence "(\<not>.F1) \<in> H" and "(\<not>.F2) \<in> H" by auto
      moreover
      have "(\<not>.F1, F1 \<or>. F2) \<in> measure tamano" and
     "(\<not>.F2, F1 \<or>. F2) \<in> measure tamano" using ptamano
      by auto
      hence "((\<not>.F1) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.F1) = Ttrue)" and
           "((\<not>.F2) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.F2) = Ttrue)"
      using hip2 by auto
      ultimately
      have 1: "t_v_evaluation (IH H) (\<not>.F1) = Ttrue" and
           2: "t_v_evaluation (IH H) (\<not>.F2) = Ttrue" by auto
      have "t_v_evaluation (IH H) F1 = Ffalse" using 1 NegationValues2 by auto
      moreover
      have "t_v_evaluation (IH H) F2 = Ffalse" using 2 NegationValues2 by auto
      ultimately
      show  "t_v_evaluation (IH H) (\<not>.(F1 \<or>. F2)) = Ttrue"
      by (simp add: v_disjunction_def, simp add: v_negation_def)
    qed
  qed
qed
(*>*)
text\<open> \<close>
lemma casoP6:
assumes hip1: "hintikkaP H" and
hip2: "\<forall>G. (G, F1  \<rightarrow>. F2) \<in> measure tamano \<longrightarrow>
(G \<in> H \<longrightarrow> t_v_evaluation (IH H) G = Ttrue) \<and> ((\<not>.G) \<in> H  \<longrightarrow> t_v_evaluation (IH H) (\<not>.G) = Ttrue)"
shows "((F1  \<rightarrow>. F2) \<in> H \<longrightarrow> t_v_evaluation (IH H) (F1  \<rightarrow>. F2) = Ttrue) \<and>
((\<not>.(F1  \<rightarrow>. F2)) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.(F1  \<rightarrow>. F2)) = Ttrue)"
(*<*)
proof(rule conjI impI)+
  assume h2: "(F1 \<rightarrow>.F2) \<in> H"
  show " t_v_evaluation (IH H) (F1 \<rightarrow>. F2) = Ttrue"
  proof -
    have "FormulaBeta (F1 \<rightarrow>. F2)" by simp
    hence "Comp1(F1 \<rightarrow>. F2) \<in> H \<or> Comp2 (F1 \<rightarrow>. F2)\<in> H"
    using hip1 h2 by(auto simp add: hintikkaP_def)
    hence "(\<not>.F1) \<in> H \<or> F2 \<in> H" by(unfold Comp1_def, unfold Comp2_def, auto)
    thus " t_v_evaluation (IH H) (F1 \<rightarrow>. F2) = Ttrue"
    proof(rule disjE)
      assume "(\<not>.F1) \<in> H"
      moreover
      have "(\<not>.F1, F1  \<rightarrow>. F2) \<in> measure tamano" using ptamano by auto
      hence " (\<not>.F1) \<in> H \<longrightarrow>  t_v_evaluation (IH H) (\<not>.F1) = Ttrue"
      using hip2 by simp
      ultimately
      have 1: "t_v_evaluation (IH H) (\<not>.F1) = Ttrue" by simp
      hence "t_v_evaluation (IH H) F1 = Ffalse" using NegationValues2 by auto
      thus "t_v_evaluation (IH H) (F1 \<rightarrow>. F2) = Ttrue"  by(simp add: v_implication_def)
      next
      assume "F2 \<in> H"
      moreover
      have "(F2, F1  \<rightarrow>. F2) \<in> measure tamano" by simp
      hence "(F2 \<in> H \<longrightarrow>  t_v_evaluation (IH H) F2 = Ttrue)"
      using hip2 by simp
      ultimately
      have "t_v_evaluation (IH H) F2 = Ttrue" by simp
      thus "t_v_evaluation (IH H) (F1 \<rightarrow>. F2) = Ttrue" by(simp add: v_implication_def)
    qed
  qed
  next
  show "(\<not>.(F1 \<rightarrow>. F2)) \<in> H \<longrightarrow>
        t_v_evaluation (IH H) (\<not>.(F1 \<rightarrow>. F2)) = Ttrue"
  proof(rule impI)
    assume h2: "(\<not>.(F1 \<rightarrow>. F2)) \<in> H"
    show "t_v_evaluation (IH H) (\<not>.(F1 \<rightarrow>. F2)) = Ttrue"
    proof -
      have "FormulaAlfa (\<not>.(F1 \<rightarrow>. F2))" by auto
      hence "Comp1(\<not>.(F1 \<rightarrow>. F2)) \<in> H \<and> Comp2(\<not>.(F1 \<rightarrow>. F2))\<in> H"
      using hip1 h2 by (auto simp add: hintikkaP_def)
      hence "F1 \<in> H \<and> (\<not>.F2) \<in> H" by(unfold Comp1_def, unfold Comp2_def, auto)
      moreover
      have "(F1, F1  \<rightarrow>. F2) \<in> measure tamano" and
      "(\<not>.F2, F1  \<rightarrow>. F2) \<in> measure tamano" using ptamano
      by auto
      hence "F1 \<in> H \<longrightarrow> t_v_evaluation (IH H) F1 = Ttrue"
      and "(\<not>.F2) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.F2) = Ttrue"
      using hip2 by auto
      ultimately
      have "t_v_evaluation (IH H) F1 = Ttrue"
      and
     "t_v_evaluation (IH H) (\<not>.F2) = Ttrue"  by auto
      thus
     "t_v_evaluation (IH H) (\<not>.(F1 \<rightarrow>. F2)) = Ttrue" by(simp add: v_implication_def)
    qed
  qed
qed
(*>*)
text\<open> \<close>
lemma casoP7:
assumes hip1: "hintikkaP H" and
hip2: "\<forall>G. (G, (\<not>.form)) \<in> measure tamano \<longrightarrow>
(G \<in> H \<longrightarrow> t_v_evaluation (IH H) G = Ttrue) \<and> ((\<not>.G) \<in> H  \<longrightarrow> t_v_evaluation (IH H) (\<not>.G) = Ttrue)"
shows "((\<not>.form) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.form) = Ttrue) \<and>
((\<not>.(\<not>.form)) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.(\<not>.form)) = Ttrue)"
(*<*)
proof(rule_tac conjI)
  show  "\<not>.form \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.form) = Ttrue"
  proof(rule impI)
    assume h1: "(\<not>.form) \<in> H"
    moreover
    have "(form, (\<not>.form)) \<in> measure tamano" by simp
    hence "((\<not>.form) \<in> H \<longrightarrow>
           t_v_evaluation (IH H) (\<not>.form)= Ttrue)"
    using hip2 by simp
    ultimately
    show "t_v_evaluation (IH H) (\<not>.form) = Ttrue" using h1 by simp
  qed
  next
  show "(\<not>.\<not>.form) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.\<not>.form) = Ttrue"
  proof(rule impI)
    assume h2: "(\<not>.\<not>.form) \<in> H"
    have "\<forall>Z. (\<not>.\<not>.Z) \<in> H \<longrightarrow> Z \<in> H" using hip1
    by(unfold hintikkaP_def) blast
    hence "(\<not>.\<not>.form) \<in> H \<longrightarrow> form \<in> H" by simp
    hence "form \<in> H" using h2 by simp
    moreover
    have "(form, (\<not>.form)) \<in> measure tamano" by simp
    hence "form \<in> H \<longrightarrow> t_v_evaluation (IH H) form = Ttrue"
    using hip2 by simp
    ultimately
    have "t_v_evaluation (IH H) form = Ttrue" by simp
    thus  "t_v_evaluation (IH H) (\<not>.\<not>.form) = Ttrue" using h2 by (simp add: v_negation_def)
  qed
qed
(*>*)
text\<open>
  Usando los lemas anteriores, se tiene la formalización del teorema
  \ref{hintikkaP-model-aux}.
\<close>

theorem hintikkaP_model_aux:
  assumes hip: "hintikkaP H"
  shows "(F \<in> H \<longrightarrow>  t_v_evaluation (IH H) F = Ttrue) \<and>
                    ((\<not>.F) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.F) = Ttrue)"
proof (rule_tac r="measure tamano" and a=F in wf_induct)
  show "wf(measure tamano)" by simp
next
  fix F
  assume hip1: "\<forall>G. (G, F) \<in> measure tamano \<longrightarrow>
                    (G \<in> H \<longrightarrow> t_v_evaluation (IH H) G = Ttrue) \<and>
                    ((\<not>.G) \<in> H  \<longrightarrow> t_v_evaluation (IH H) (\<not>.G) = Ttrue)"
  show "(F \<in> H \<longrightarrow> t_v_evaluation (IH H) F = Ttrue) \<and>
        ((\<not>.F) \<in> H \<longrightarrow> t_v_evaluation (IH H) (\<not>.F) = Ttrue)"
  proof (cases F)
    assume "F=FF"
    thus ?thesis using casoP1 hip hip1 by simp
  next
    assume "F=TT"
    thus ?thesis using casoP2 hip hip1 by auto
  next
    fix P
    assume "F = atom P"
    thus ?thesis using hip hip1 casoP3[of H P] by simp
  next
    fix F1  F2
    assume "F= (F1 \<and>. F2)"
    thus ?thesis using hip hip1 casoP4[of H F1 F2] by simp
  next
    fix F1 F2
    assume "F= (F1 \<or>. F2)"
    thus ?thesis using hip hip1 casoP5[of H F1 F2] by simp
  next
    fix F1 F2
    assume "F= (F1 \<rightarrow>. F2)"
    thus ?thesis using hip hip1 casoP6[of H F1 F2] by simp
  next
    fix F1
    assume "F=(\<not>.F1)"
    thus ?thesis using hip hip1 casoP7[of H F1] by simp
  qed
qed

text \<open>
  Por último, como un corolario del teorema anterior se demuestra que
  $I_H$ es un mo\-delo del conjunto de Hintikka $H$.

  \begin{corolario}\label{ModeloHintikkaPa}
  Sea $H$ un conjunto de Hintikka. Si $F\in H$ entonces $I'_H(F)=\V.$
  \end{corolario}

  \begin{demostracion}
  Es consecuencia inmediata del teorema \ref{hintikkaP-model-aux}
  \end{demostracion}

  \noindent Su formalización es:
\<close>

corollary ModeloHintikkaPa:
  assumes "hintikkaP H" and "F \<in> H"
  shows "t_v_evaluation (IH H) F = Ttrue"
using assms hintikkaP_model_aux by auto

text \<open>
  \begin{corolario}\label{ModeloHintikkaP}
  Sea $H$ es un conjunto de Hintikka. Entonces, $I_H$ es un model de
  $H$.
  \end{corolario}

  \begin{demostracion}
  Es consecuencia inmediata de la definición de model y del corolario anterior.
  \end{demostracion}

  \noindent Su formalización es:
\<close>

corollary ModeloHintikkaP:
  assumes "hintikkaP H"
  shows "(IH H) model H"
proof (unfold model_def)
  show "\<forall>F\<in>H. t_v_evaluation (IH H) F = Ttrue"
  proof (rule ballI)
    fix F
    assume "F \<in> H"
    thus "t_v_evaluation (IH H) F = Ttrue" using assms ModeloHintikkaPa  by auto
  qed
qed

text \<open>
  De esta forma, cualquier conjunto de Hintikka es satisfiable.

  \begin{corolario}\label{Hintikkasatisfiable}
  Cualquier conjunto de Hintikka es satisfiable.
  \end{corolario}

  \begin{demostracion}
  Es consecuencia inmediata de la definición de satisfactibilidad y del
  corolario \ref{ModeloHintikkaP}.
  \end{demostracion}

  \noindent Su formalización es:
\<close>

corollary Hintikkasatisfiable:
  assumes "hintikkaP H"
  shows "satisfiable H"
using assms ModeloHintikkaP
by (unfold satisfiable_def, auto)

(*<*)
end
(*>*)


section \<open>Challenge 2.B\<close>
theory Challenge2B
  imports Challenge2A
begin

text \<open>We did not get very far on this part of the competition. Only Task 2 was finished.\<close>

subsection \<open>Basic Definitions\<close>

datatype tree = Leaf | Node int (lc: tree) (rc: tree)

text \<open>Analogous to @{term left_spec} from 2.A.\<close>
definition
  "right_spec xs j =
  (if (\<exists>i>j. xs ! i < xs ! j) then Some (LEAST i. i > j \<and> xs ! i < xs ! j) else None)"

context
  fixes xs :: "int list"
  assumes "distinct xs"
begin

subsection \<open>Specification of the Parent\<close>
definition
  "parent i = (
    case (left_spec xs i, right_spec xs i) of
      (None, None) \<Rightarrow> None
    | (Some x, None) \<Rightarrow> Some x
    | (None, Some y) \<Rightarrow> Some y
    | (Some x, Some y) \<Rightarrow> Some (max x y)
  )"

subsection \<open>The Heap Property (Task 2)\<close>

lemma parent_heap:
  assumes "parent j = Some p"
  shows "xs ! j > xs ! p"
proof -
  note [simp del] = left_spec_None_iff swap_adhoc
  show ?thesis
  proof (cases "(\<exists>i<j. xs ! i < xs ! j)")
    case True
    then have *: "xs ! the (left_spec xs j) < xs ! j" "left_spec xs j \<noteq> None"
      unfolding left_spec_def by auto (metis (no_types, lifting) GreatestI_nat True less_le)
    show ?thesis
    proof (cases "(\<exists>i>j. xs ! i < xs ! j)")
      case True
      then have "xs ! the (right_spec xs j) < xs ! j" "right_spec xs j \<noteq> None"
        unfolding right_spec_def by auto (metis (no_types, lifting) LeastI)
      then show ?thesis
        using * assms unfolding parent_def by auto
    next
      case False
      then have "right_spec xs j = None"
        unfolding right_spec_def by auto
      then show ?thesis
        using * assms unfolding parent_def by auto
    qed
  next
    case False
    then have [simp]: "left_spec xs j = None"
      unfolding left_spec_def by auto
    show ?thesis
    proof (cases "(\<exists>i>j. xs ! i < xs ! j)")
      case True
      then have "xs ! the (right_spec xs j) < xs ! j" "right_spec xs j \<noteq> None"
        unfolding right_spec_def by auto (metis (no_types, lifting) LeastI)
      then show ?thesis
        using assms unfolding parent_def by auto
    next
      case False
      then have "right_spec xs j = None"
        unfolding right_spec_def by auto
      then show ?thesis
        using assms unfolding parent_def by auto
    qed
  qed
qed

end

end


theory Downset

imports
 Main
"rg-algebra/General/CRA"
"rg-algebra/General/Distributive_Iteration"
"rg-algebra/AbstractTests/Test_Commands"
"rg-algebra/AbstractAtomic/Atomic_Commands"

begin

unbundle lattice_syntax

definition "eta (x :: 'a) = {x}"

notation eta ("\<eta>")

class preorder_bot = preorder + bot +
  assumes bot_least: "\<bottom> \<le> a"

context preorder begin
definition downset_set ("\<Down>") where
  "\<Down>X = {y. \<exists>x \<in> X. y \<le> x}"

definition downset  ("\<down>") where
  "\<down> = \<Down> \<circ> \<eta>"

definition upset_set ("\<Up>") where
  "\<Up>X = {y. \<exists>x \<in> X. y \<ge> x}"

definition upset  ("\<up>") where
  "\<up> = \<Up> \<circ> \<eta>"
end

class preorder_top = preorder + top +
  assumes top_greatest[simp]: "a \<le> \<top>"

typedef (overloaded) ('a) downset = "{S. \<Down>S = (S :: ('a :: preorder_bot set)) \<and> bot \<in> S} "
  apply (rule_tac x=UNIV in exI, clarsimp simp: downset_set_def)
  apply (safe)
   apply blast
  apply (clarsimp)
  apply (rule_tac x=x in exI)
  apply (clarsimp)
  done

setup_lifting type_definition_downset

lift_definition prime :: "('a :: preorder_bot \<Rightarrow> 'a downset)" is
 "\<lambda>x. \<down>x"
  apply (clarsimp simp: preorder_class.downset_set_def preorder_class.downset_def)
    apply (intro set_eqI conjI iffI; clarsimp?)
    using preorder_class.dual_order.trans apply auto[1]
    using preorder_class.dual_order.trans apply auto[1]
    by (simp add: eta_def preorder_bot_class.bot_least)

abbreviation (input) "lift_set (f :: 'a set \<Rightarrow> 'a set \<Rightarrow> 'b) \<equiv>
   \<lambda>(x :: 'a :: preorder_bot downset)  (y :: 'a downset).  (f (Rep_downset x) (Rep_downset y))"

lift_definition Dun     :: "'a :: preorder_bot downset \<Rightarrow> 'a downset \<Rightarrow> 'a downset" is "union"
  apply (clarsimp simp: downset_set_def, intro iffI set_eqI; clarsimp)
  by auto

lift_definition Dinter  :: "'a :: preorder_bot downset \<Rightarrow> 'a downset \<Rightarrow> 'a downset" is "inter"
  apply (clarsimp simp: downset_set_def, intro iffI set_eqI; clarsimp)
  by auto

lift_definition Din :: "'a :: preorder_bot \<Rightarrow> 'a downset \<Rightarrow> bool" is "(\<lambda>a A. a \<in>  A)" done

lift_definition Dsub :: "'a :: preorder_bot downset \<Rightarrow> 'a downset \<Rightarrow> bool" is " (\<subseteq>)" done

lift_definition DInf :: "'a ::preorder_bot downset set \<Rightarrow> 'a downset" is
                        "Inf :: 'a set set \<Rightarrow> 'a set"
  apply (clarsimp simp: downset_set_def downset_def eta_def)
  apply (intro set_eqI iffI; clarsimp)
  by auto

notation Dsub (infixr "(\<down>\<subseteq>)" 50)

notation Din (infixr "(\<down>\<in>)" 50)

lemma bot_in[simp]: "\<bottom> \<down>\<in> S"
  apply (transfer, clarsimp)
  done

lemma Din_intro: "a \<down>\<in>  S \<Longrightarrow>  x \<le> a  \<Longrightarrow> x \<down>\<in> S"
  apply (transfer)
  apply (clarsimp simp: downset_def downset_set_def)
  using order_trans by fastforce

lemma Dsub_iff: "Dsub A B \<longleftrightarrow> (\<forall>x. x \<down>\<in> A \<longrightarrow> x \<down>\<in> B)"
  apply (transfer)
  apply (safe; transfer; clarsimp)
  apply (fastforce)
  done

lemma downclosed_inverseI: "\<Down>y = y \<Longrightarrow> x \<in> y \<Longrightarrow> x \<down>\<in> (Abs_downset y) "
  apply (clarsimp simp: Din_def)
  apply (subst  Abs_downset_inverse)
   apply (clarsimp)
  using Downset.preorder_bot_class.bot_least downset_set_def apply blast
  by (safe)

lemma Dinter_commute:"Dinter A B = Dinter B A"
  apply (transfer)
  by (simp add: inf_commute)

instantiation downset :: (preorder_bot) lattice begin
definition "(less_downset :: ('a :: preorder_bot) downset \<Rightarrow> 'a downset \<Rightarrow> bool) = (inf Dsub (\<noteq>)) "

definition "less_eq_downset = Dsub"
definition "sup_downset = Dun"
definition "inf_downset = Dinter"

instance
  apply (standard; (clarsimp simp: sup_downset_def inf_downset_def less_downset_def less_eq_downset_def ), transfer; clarsimp)
   apply (safe)
   apply force
  apply force
  done
end

class bounded_order = preorder_top + preorder_bot

lemma (in bounded_order) [simp]: "(\<down>\<top>) = (UNIV )"
  by (clarsimp simp: downset_set_def downset_def eta_def )

lemma  [simp]: "(\<Down>UNIV) = (UNIV :: 'a :: preorder set)"
  by (clarsimp simp: downset_set_def downset_def eta_def, fastforce)

lemma  [simp]: "x \<in> \<down> (x :: 'a :: preorder) "
  by (clarsimp simp: downset_set_def downset_def eta_def)

instantiation downset :: (preorder_bot) Inf begin
 lift_definition Inf_downset :: "'a downset set \<Rightarrow> 'a downset" is Inf
  apply (clarsimp simp: downset_set_def downset_def eta_def)
  apply (intro set_eqI iffI; clarsimp)
   by auto
instance ..
end

instantiation downset :: (preorder_bot) complete_lattice begin
lift_definition top_downset :: "'a downset" is " (\<Down>UNIV) " by (clarsimp)
lift_definition bot_downset :: "'a downset" is " (\<down>bot) " by clarsimp

lift_definition Sup_downset :: "'a downset set \<Rightarrow> 'a downset" is "\<lambda>S. \<Union>S \<union> \<down>(\<bottom>)"
  apply (clarsimp simp: downset_set_def downset_def eta_def)
  apply (case_tac "set = {}", clarsimp)

  apply (intro set_eqI iffI; clarsimp)
  using order_trans apply blast
   apply auto[1]
  apply (intro set_eqI iffI; clarsimp)
  apply (metis (mono_tags, lifting) mem_Collect_eq order_trans)
  by fastforce

instance
  apply (standard; (clarsimp simp: less_eq_downset_def)?)
       apply (transfer)
       apply (blast)
  apply (transfer)
      apply (meson Inf_greatest)
  apply (transfer)
     apply (clarsimp simp: Sup_downset_def)
  apply (transfer)
    apply (clarsimp simp: Sup_downset_def)
  apply blast
    apply (transfer)
    apply (simp add: Inf_lower)
  apply (transfer)
    apply (clarsimp simp: downset_def downset_set_def eta_def)
    apply (intro conjI)
     apply blast
  apply blast

  apply (rule antisym)
  apply (clarsimp simp: less_eq_downset_def Dsub_iff; clarsimp?)
  apply (transfer)
    apply (clarsimp simp: downset_def downset_set_def eta_def)
    apply blast
  apply (clarsimp simp: less_eq_downset_def Dsub_iff; clarsimp?)
  apply (transfer)
   apply (clarsimp)
  apply (rule antisym)
  apply (clarsimp simp: less_eq_downset_def Dsub_iff; clarsimp?)
   apply (transfer, clarsimp)

  apply (clarsimp simp: less_eq_downset_def Dsub_iff; clarsimp?)
  apply (transfer, clarsimp)
  done

end

lemma [simp]: "\<Down> {x} = \<down>x"
  by (clarsimp simp: downset_set_def downset_def eta_def)

context order_bot begin

subclass preorder_bot by (standard, rule bot_least)
end

lemma (in order) [simp]: "\<Down>(\<Down>S) = \<Down>S"
  apply (clarsimp simp: downset_set_def downset_def eta_def)
  apply (intro set_eqI iffI; clarsimp)
  using local.dual_order.trans apply blast
  using local.dual_order.trans apply blast
  done

lemma down_insert[simp]:"\<Down>(insert x S) = \<down>x \<union> \<Down>S"
  apply (clarsimp simp: downset_set_def downset_def eta_def)
  apply (intro set_eqI iffI; clarsimp)
  done

lemma bot_least_trans[simp]:"(x :: 'a :: preorder_bot) \<le> \<bottom> \<Longrightarrow> x \<le> y"
  using order_trans preorder_bot_class.bot_least by blast

lemma down_union_distrib: "\<Down>(X \<union> Y) = \<Down>X \<union> \<Down>Y"
  apply (intro set_eqI iffI; clarsimp simp: downset_set_def)
  by blast+

lemma down_sup_distrib: "\<Down>(Sup X) = Sup ((\<Down>) ` X)"
  by (intro set_eqI iffI; clarsimp simp: downset_set_def)

lemma bot_in_downset_iff: "(\<bottom> :: 'a :: preorder_bot) \<in> \<Down> S \<longleftrightarrow> S \<noteq> {}"
  apply (safe)
   apply (clarsimp simp: downset_set_def)
  by (clarsimp simp: downset_set_def)

lemma down_down[simp]: "\<Down>(\<Down>x) = \<Down>x"
  apply (safe; clarsimp simp: downset_set_def)
  using order_trans by blast+

instantiation downset :: (preorder_bot) complete_distrib_lattice

begin
instance
  apply (standard)
  apply (case_tac "A = {}", clarsimp)
  apply (clarsimp simp: less_eq_downset_def, transfer)
  apply (intro iffI conjI set_eqI subsetI)
  apply (clarsimp)
   apply (rule_tac x="(\<lambda>Y. \<Down>(SOME X.  X \<in> Y \<and> x \<in> X ) \<union> \<down>\<bottom>) ` A " in exI)
  apply (intro conjI)
    apply (rule_tac x="(\<lambda>Y. \<Down>(SOME X.  X \<in> Y \<and> x \<in> X ) \<union> \<down>\<bottom>)" in exI, clarsimp simp: down_union_distrib)
    apply (subst Un_commute, subst down_insert[symmetric], subst insert_absorb)
     apply (simp add: someI2_bex)
    apply (metis (mono_tags, lifting) verit_sko_ex')

    apply (clarsimp simp: Un_commute down_insert[symmetric] insert_absorb someI2_bex)
   apply (metis (mono_tags, lifting) verit_sko_ex')
    apply (clarsimp simp: Un_commute down_insert[symmetric] insert_absorb someI2_bex)
   apply (metis (mono_tags, lifting) verit_sko_ex')

  done

end

instantiation downset :: (preorder_bot) bounded_order begin
instance
  by (standard; clarsimp)
end

(* why is this necessary? *)

instantiation downset :: (preorder_bot) refinement_lattice begin
instance ..
end

lemma downset_set_def': "\<Down>X = {y. \<exists>x\<in>X. y \<le> x}" unfolding downset_set_def ..

declare bot_least[simp]
lemma (in preorder_bot) [simp]: "\<bottom> \<in> \<down> S"
  by (clarsimp simp: downset_set_def downset_def eta_def bot_least)

lemma (in preorder_bot) [simp]: "\<Down>{} = ({} )"
  by (clarsimp simp: downset_set_def)

lemma eq_univ_iff:  "S = UNIV \<longleftrightarrow> (\<forall>x. x \<in> S)"
  by (safe; blast)

lemma in_down_iff: "x \<in> \<down> y \<longleftrightarrow> x \<le> y " unfolding preorder_class.downset_def eta_def downset_set_def'
  by (clarsimp)

lemma not_in_down_iff: " x \<notin> \<down> y \<longleftrightarrow> ~(x \<le> y)"
  by (simp add: in_down_iff)

lemma rewrite_sup:  "(\<And>a. a \<le> x \<Longrightarrow> g a \<le> g x) \<Longrightarrow>  (\<Union>a\<in>\<down> x. \<Union>b\<in>c. \<down> (g a b)) = (\<Squnion>b\<in>c. \<down>(g x b))"
  apply (safe; clarsimp simp: in_down_iff)
  apply (meson le_funD preorder_class.dual_order.trans)
  using in_down_iff by blast

lemma rewrite_sup': "mono_on UNIV g \<Longrightarrow> (\<Union>b\<in>\<down> x. \<down> (g b)) = \<down>(g x) "
  apply (safe; clarsimp simp: in_down_iff preorder_class.downset_set_def)
  apply (meson dual_order.trans monotoneD)
  using in_down_iff by blast

lemma sup_down_down: "(\<And>x. x \<le> c \<Longrightarrow> g x \<le> g c) \<Longrightarrow> (\<Union>x\<in>\<down> c. \<down> (g x)) = \<down> (g c)"
  apply (safe; clarsimp simp: in_down_iff)
  using order_trans apply blast
  by (fastforce dest: monoD)

lemma SUP_SUP: "(\<Union>x\<in>a. \<Union>y\<in>b. g x y) = (\<Union>(x, y)\<in>(a \<times> b). g x y)"
  apply (safe; clarsimp)
   apply (blast)
  apply (blast)
  done

lemma in_downsetI: "\<Down>a = a \<Longrightarrow> (\<exists>x'\<in>a. x \<le> x') \<Longrightarrow> x \<in> a "
  apply (clarsimp simp: downset_set_def)
  using preorder_class.downset_set_def by auto

lemma split_set: "(S :: 'a :: complete_lattice) = (\<Squnion>{x. (x \<le> S)})"
  by (metis Sup_eqI dual_order.refl mem_Collect_eq)

lemma (in order_bot) bot_in_downset_iff: "\<bottom> \<in> \<Down> S \<longleftrightarrow> S \<noteq> {}"
  by (clarsimp simp: downset_set_def, blast)

lemma down_nonempty[simp]:"\<down> x \<noteq> {}"
  apply (clarsimp simp: downset_def)
  apply (clarsimp simp: downset_set_def eta_def)
  by (blast)

lemma Ball_down: "(\<forall>x\<in> \<down>y. P x y) \<longleftrightarrow> (\<forall>x\<le>y. P x y)"
  apply (safe)
  apply (clarsimp simp: downset_def)
   apply (clarsimp simp: downset_set_def eta_def)
  apply (clarsimp simp: downset_def)
  apply (clarsimp simp: downset_set_def eta_def)
  done

lemma in_down_bot_trans[simp]: "(x :: 'a :: preorder_bot) \<in> \<down>\<bottom> \<Longrightarrow> x \<in> \<down>y"
  by (clarsimp simp: in_down_iff)

lemma down_image_iff:"x \<in> \<Down> (g ` S) \<longleftrightarrow> (\<exists>y\<in>S. x \<le> g y) "
  apply (safe; clarsimp simp: downset_set_def')
  apply (blast)
  done

lemma in_Down_iff: "(x \<in> \<Down> y) = (\<exists>c\<in>y. x \<le> c)" by (clarsimp simp: downset_def downset_set_def eta_def)

lemma mono_downset_comp: "mono (f) \<Longrightarrow> (\<Union>x\<in>\<down> (c). \<Union>y\<in>x'. \<down> (f x y)) = (\<Union>y\<in>x'. \<down>(f c y))"
  apply (safe; clarsimp simp:in_down_iff Bex_def)
  apply (rule_tac x=y in exI)
  apply (meson dual_order.trans le_funD monoD)
  by blast

lemma mono_downset_comp_alt: "mono (f) \<Longrightarrow> (\<Union>x\<in>\<down> (c). (\<Down>(\<Union>y\<in>x'. f x y))) = \<Down>(\<Union>y\<in>x'. (f c y))"
  apply (safe; clarsimp simp: in_down_iff Bex_def downset_set_def)
   apply (clarsimp simp: mono_def le_fun_def)
   apply (erule_tac x=xa in allE)
   apply (erule_tac x=c in allE)
   apply (clarsimp)
   apply (rule_tac x=xb in exI, blast)
  by blast

lemma mono_downset_comp': "mono (f) \<Longrightarrow> (\<Union>x\<in>\<down> (c). f x) = ((f c))"
  apply (safe; clarsimp simp: in_down_iff Bex_def)
  apply (drule monoD, assumption)
  apply blast
  by blast

lemma mono_on_down: "mono_on UNIV f \<Longrightarrow> \<Union> (f ` (\<down> c)) = (f c)"
  apply (safe; clarsimp simp: in_down_iff Bex_def)
  apply (meson in_mono monotoneD)
  by blast

lemma mono_on_down': "mono_on UNIV f \<Longrightarrow> \<Union> (f ` (\<Down> c)) = Sup(f ` c)"
  apply (safe; clarsimp simp: in_down_iff Bex_def)
  apply (meson in_Down_iff in_mono monotoneD)
  using in_Down_iff by auto

lemma mono_comp[intro!, simp]:"mono_on UNIV f \<Longrightarrow> mono_on UNIV g \<Longrightarrow> mono_on UNIV (f o g)"
  by (simp add: mono_on_def)

lemma mono_comp'[intro!, simp]:"mono_on UNIV f \<Longrightarrow> mono_on UNIV g \<Longrightarrow> mono_on UNIV (\<lambda>x. f (g x))"
  by (simp add: mono_on_def)

lemma mono_on_sup[intro, simp]: "mono_on UNIV f \<Longrightarrow> mono_on UNIV g \<Longrightarrow> mono_on UNIV (\<lambda>x. f x \<union> g x)"
  apply (rule mono_onI; clarsimp?)
  by (metis monotoneD sup.coboundedI1 sup_commute)

lemma mono_on_SUP:  " (\<And>x. mono_on UNIV (\<lambda>y . f y x)) \<Longrightarrow> mono_on UNIV (\<lambda>x. \<Union> (f x `  S))"
  apply (rule mono_onI; clarsimp)
  apply (rule_tac x=xa in bexI)
   apply (meson in_mono monotoneD)
  apply (clarsimp)
  done

lemma mono_on_principle: "mono_on UNIV f \<Longrightarrow> mono_on UNIV (\<lambda>y. \<down> (f y))"
  apply (rule mono_onI; clarsimp simp: in_down_iff)
  by (meson dual_order.trans monotoneD)
end


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

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

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun count :: "Nat => Nat list => Nat" where
  "count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if x y z2 then S (count y ys) else count y ys)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) z = z"
| "t2 (S z2) z = S (t2 z2 z)"

theorem property0 :
  "((t2 (count n xs) (count n (cons2 m (nil2)))) =
      (count n (cons2 m xs)))"
  oops

end


theory sort_NStoogeSortPermutes'
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Nat = Z | S "Nat"

fun third :: "Nat => Nat" where
"third (Z) = Z"
| "third (S (Z)) = Z"
| "third (S (S (Z))) = Z"
| "third (S (S (S n))) = S (third n)"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = Nil2"
| "take (S z) (Nil2) = Nil2"
| "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'t list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) y = y"
| "drop (S z) (Nil2) = Nil2"
| "drop (S z) (Cons2 x2 x3) = drop z x3"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) Pair2" where
"splitAt x y = Pair (take x y) (drop x y)"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun reverse :: "'t list => 't list" where
"reverse (Nil2) = Nil2"
| "reverse (Cons2 y xs) = append (reverse xs) (Cons2 y (Nil2))"

function nstooge1sort2 :: "int list => int list"
         and nstoogesort :: "int list => int list"
         and nstooge1sort1 :: "int list => int list" where
"nstooge1sort2 x =
   case splitAt (third (length x)) (reverse x) of
     | Pair ys zs =>
         case splitAt (third (length x)) (reverse x) of
           | Pair xs zs2 => append (nstoogesort zs) (reverse xs)
         end
   end"
| "nstoogesort (Nil2) = Nil2"
| "nstoogesort (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "nstoogesort (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "nstoogesort (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "nstooge1sort1 x =
     case splitAt (third (length x)) x of
       | Pair ys zs =>
           case splitAt (third (length x)) x of
             | Pair xs zs2 => append ys (nstoogesort zs2)
           end
     end"
by pat_completeness auto

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun isPermutation :: "int list => int list => bool" where
"isPermutation (Nil2) y = null y"
| "isPermutation (Cons2 z xs) y =
     and2 (elem z y) (isPermutation xs (delete z y))"

(*hipster third
          take
          sort2
          or2
          null
          length
          elem
          drop
          splitAt
          delete
          append
          reverse
          nstooge1sort2
          nstoogesort
          nstooge1sort1
          and2
          isPermutation *)

theorem x0 :
  "!! (x :: int list) . isPermutation (nstoogesort x) x"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end