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

theory Ring_Divisibility
imports Ideal Divisibility QuotRing HOL.Zorn

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 R to mult_of R 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 "irreducible R", we need to suppose we are not in a field (which is plausible,
      but "\<not> field R" is an assumption we want to avoid; for "irreducible (mult_of R)", 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


theory Short_Theory_9_4 imports "HOL-IMP.Star" Complex_Main begin

datatype val = Iv int | Bv bool

type_synonym vname = string
type_synonym state = "vname \<Rightarrow> val"

datatype exp =  Ic int | Bc bool | V vname | Not exp | Plus exp exp | And exp exp | Less exp exp

inductive eval :: "exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"eval (Ic i) _ (Iv i)" |
"eval (Bc v) _ (Bv v)" |
"eval (V x) s (s x)" |
"eval e s (Bv v) \<Longrightarrow> eval (Not e) s (Bv (\<not> v))" |
"\<lbrakk>eval a1 s (Iv i1); eval a2 s (Iv i2)\<rbrakk>
 \<Longrightarrow> eval (Plus a1 a2) s (Iv (i1 + i2))" |
"\<lbrakk>eval b1 s (Bv v1); eval b2 s (Bv v2)\<rbrakk>
 \<Longrightarrow> eval (And b1 b2) s (Bv (v1 \<and> v2))" |
"\<lbrakk>eval a1 s (Iv i1); eval a2 s (Iv i2)\<rbrakk>
 \<Longrightarrow> eval (Less a1 a2) s (Bv (i1 < i2))"

inductive_cases [elim!]:
  "eval (Ic i) s v"
  "eval (Bc bv) s v"
  "eval (V x) s v"
  "eval (Plus a1 a2) s v"
  "eval (And b1 b2) s v"
  "eval (Less a1 a2) s v"

datatype
  com = SKIP
      | Assign vname exp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;; _"  [60, 61] 60)
      | If     exp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  exp com         ("WHILE _ DO _"  [0, 61] 61)

inductive small_step :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<rightarrow>" 55) where
  Assign: "eval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |
  Seq1: "(SKIP;; c, s) \<rightarrow> (c, s)" |
  Seq2: "(c1, s) \<rightarrow> (c1', s') \<Longrightarrow> (c1;; c2,s) \<rightarrow> (c1';; c2,s')" |
  IfTrue: "eval b s (Bv True) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1, s)" |
  IfFalse: "eval b s (Bv False) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2, s)" |
  While: "(WHILE b DO c, s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

datatype ty = Ity | Bty

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive etyping :: "tyenv \<Rightarrow> exp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
where
Ic_ty: "\<Gamma> \<turnstile> Ic i : Ity" |
Bc_ty: "\<Gamma> \<turnstile> Bc r : Bty" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
Plus_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : Ity" |
And_ty: "\<Gamma> \<turnstile> b1 : Bty \<Longrightarrow> \<Gamma> \<turnstile> b2 : Bty \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2 : Bty" |
Less_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2 : Bty"

declare etyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> Ic i : \<tau>" "\<Gamma> \<turnstile> Bc r : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>"
  "\<Gamma> \<turnstile> And b1 b2 : \<tau>" "\<Gamma> \<turnstile> Less a1 a2 : \<tau>"

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma> x \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;; c2" |
If_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c"

declare ctyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"

fun type :: "val \<Rightarrow> ty" where
  "type (Iv i) = Ity" |
  "type (Bv r) = Bty"

lemma type_eq_Ity [simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
  by (cases v) auto

lemma type_eq_Bty [simp]: "type v = Bty \<longleftrightarrow> (\<exists>b. v = Bv b)"
  by (cases v) simp_all

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50) where
  "\<Gamma> \<turnstile> s \<longleftrightarrow> (\<forall>x. type (s x) = \<Gamma> x)"

lemma epreservation: "\<Gamma> \<turnstile> e : \<tau> \<Longrightarrow> eval e s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
  by(induct arbitrary: v rule: etyping.induct) (fastforce simp: styping_def)+

lemma eprogress: "\<Gamma> \<turnstile> e : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. eval e s v"
proof(induct rule: etyping.induct)
  case (Plus_ty \<Gamma> a1 a2)
  then obtain v1 v2 where v: "eval a1 s v1" "eval a2 s v2" by blast
  with Plus_ty show ?case by (fastforce intro: eval.intros(5) dest!: epreservation)
next
  case (And_ty \<Gamma> b1 b2)
  thm eval.intros
  then obtain v1 v2 where v: "eval b1 s v1" "eval b2 s v2" by blast
  with And_ty show ?case by (fastforce intro: eval.intros(6) dest!: epreservation)
next
  case (Less_ty \<Gamma> a1 a2)
  then obtain v1 v2 where v: "eval a1 s v1" "eval a2 s v2" by blast
  with Less_ty show ?case by (fastforce intro: eval.intros(7) dest!: epreservation)
qed (auto intro: eval.intros)

theorem progress: "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c, s) \<rightarrow> cs'"
proof(induct rule: ctyping.induct)
  case Skip_ty thus ?case by simp
next
  case Assign_ty
  thus ?case by (metis Assign eprogress)
next
  case Seq_ty thus ?case by simp (metis Seq1 Seq2)
next
  case (If_ty \<Gamma> b c1 c2)
  then obtain bv where Heval: "eval b s bv" by (metis eprogress)
  with If_ty(1, 6) obtain b where Hb: "bv = Bv b" by (auto dest!: epreservation)
  show ?case
  proof (cases b)
    case True
    with Heval Hb show ?thesis by simp (metis IfTrue)
  next
    case False
    with Heval Hb show ?thesis by simp (metis IfFalse)
  qed
next
  case While_ty show ?case by (metis While)
qed

theorem styping_preservation: "(c, s) \<rightarrow> (c', s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
proof(induct rule: small_step_induct)
  case Assign thus ?case
    by (auto simp: styping_def) (metis Assign(1,3) epreservation)
qed auto

theorem ctyping_preservation: "(c, s) \<rightarrow> (c', s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
by (induct rule: small_step_induct) (auto simp: ctyping.intros)

abbreviation small_steps :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

theorem type_sound: "(c, s) \<rightarrow>* (c', s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c', s') \<rightarrow> cs''"
  by (induction rule: star_induct)
    ((metis progress)?, metis styping_preservation ctyping_preservation)

end


theory Arboles
imports Main
begin

section {* Definición del tipo de datos de árboles *}

text {* ('a arbol) es el tipo de dato de los śrboles con valores en en
los nodos. *}
datatype 'a arbol = Hoja | Nodo "'a arbol" 'a "'a arbol"

text {* El árbol
      9
     / \
   .    4
        /\
       .   .
  se define como sigue
*}
abbreviation ejArbol1 :: "int arbol"
where
  "ejArbol1 \<equiv> Nodo Hoja (9::int) (Nodo Hoja 4 Hoja)"

section {* Demostración de propiedades de árboles *}

text {* Prop.: Las hojas son distintas de los nodos. *}
lemma "Hoja \<noteq> Nodo l x r"
by simp

text {* (espejo t) es la imagen especular del árbol t. Por ejemplo,
     espejo (Nodo Hoja (9::int) (Nodo Hoja 4 Hoja))
             = Nodo (Nodo Hoja 4 Hoja) 9 Hoja
     espejo (Nodo (Nodo Hoja a Hoja) b t)
            = Nodo (espejo t) b (Nodo Hoja a Hoja)
*}
fun espejo :: "'a arbol \<Rightarrow> 'a arbol"
where
  "espejo Hoja         = Hoja"
| "espejo (Nodo i x d) = Nodo (espejo d) x (espejo i)"

value "espejo (Nodo Hoja (9::int) (Nodo Hoja 4 Hoja))"
lemma "espejo (Nodo Hoja (9::int) (Nodo Hoja 4 Hoja))
       = Nodo (Nodo Hoja 4 Hoja) 9 Hoja" by simp
value "espejo (Nodo (Nodo Hoja a Hoja) b t)"
lemma "espejo (Nodo (Nodo Hoja a Hoja) b t)
       = Nodo (espejo t) b (Nodo Hoja a Hoja)" by simp

text {* Prop.: La función espejo es idempotente. *}
lemma espejo_espejo [simp]:
  "espejo (espejo t) = t"
apply (induction t)
apply auto
done

end


(* Author: Tobias Nipkow *)

theory Abs_Int3
imports Abs_Int2_ivl
begin

subsection "Widening and Narrowing"

class widen =
fixes widen :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<nabla>" 65)

class narrow =
fixes narrow :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<triangle>" 65)

class wn = widen + narrow + order +
assumes widen1: "x \<le> x \<nabla> y"
assumes widen2: "y \<le> x \<nabla> y"
assumes narrow1: "y \<le> x \<Longrightarrow> y \<le> x \<triangle> y"
assumes narrow2: "y \<le> x \<Longrightarrow> x \<triangle> y \<le> x"
begin

lemma narrowid[simp]: "x \<triangle> x = x"
by (metis eq_iff narrow1 narrow2)

end

lemma top_widen_top[simp]: "\<top> \<nabla> \<top> = (\<top>::_::{wn,order_top})"
by (metis eq_iff top_greatest widen2)

instantiation ivl :: wn
begin

definition "widen_rep p1 p2 =
  (if is_empty_rep p1 then p2 else if is_empty_rep p2 then p1 else
   let (l1,h1) = p1; (l2,h2) = p2
   in (if l2 < l1 then Minf else l1, if h1 < h2 then Pinf else h1))"

lift_definition widen_ivl :: "ivl \<Rightarrow> ivl \<Rightarrow> ivl" is widen_rep
by(auto simp: widen_rep_def eq_ivl_iff)

definition "narrow_rep p1 p2 =
  (if is_empty_rep p1 \<or> is_empty_rep p2 then empty_rep else
   let (l1,h1) = p1; (l2,h2) = p2
   in (if l1 = Minf then l2 else l1, if h1 = Pinf then h2 else h1))"

lift_definition narrow_ivl :: "ivl \<Rightarrow> ivl \<Rightarrow> ivl" is narrow_rep
by(auto simp: narrow_rep_def eq_ivl_iff)

instance
proof
qed (transfer, auto simp: widen_rep_def narrow_rep_def le_iff_subset \<gamma>_rep_def subset_eq is_empty_rep_def empty_rep_def eq_ivl_def split: if_splits extended.splits)+

end

instantiation st :: ("{order_top,wn}")wn
begin

lift_definition widen_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> 'a st" is "map2_st_rep (op \<nabla>)"
by(auto simp: eq_st_def)

lift_definition narrow_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> 'a st" is "map2_st_rep (op \<triangle>)"
by(auto simp: eq_st_def)

instance
proof (standard, goal_cases)
  case 1 thus ?case by transfer (simp add: less_eq_st_rep_iff widen1)
next
  case 2 thus ?case by transfer (simp add: less_eq_st_rep_iff widen2)
next
  case 3 thus ?case by transfer (simp add: less_eq_st_rep_iff narrow1)
next
  case 4 thus ?case by transfer (simp add: less_eq_st_rep_iff narrow2)
qed

end

instantiation option :: (wn)wn
begin

fun widen_option where
"None \<nabla> x = x" |
"x \<nabla> None = x" |
"(Some x) \<nabla> (Some y) = Some(x \<nabla> y)"

fun narrow_option where
"None \<triangle> x = None" |
"x \<triangle> None = None" |
"(Some x) \<triangle> (Some y) = Some(x \<triangle> y)"

instance
proof (standard, goal_cases)
  case (1 x y) thus ?case
    by(induct x y rule: widen_option.induct)(simp_all add: widen1)
next
  case (2 x y) thus ?case
    by(induct x y rule: widen_option.induct)(simp_all add: widen2)
next
  case (3 x y) thus ?case
    by(induct x y rule: narrow_option.induct) (simp_all add: narrow1)
next
  case (4 y x) thus ?case
    by(induct x y rule: narrow_option.induct) (simp_all add: narrow2)
qed

end

definition map2_acom :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a acom \<Rightarrow> 'a acom \<Rightarrow> 'a acom"
where
"map2_acom f C1 C2 = annotate (\<lambda>p. f (anno C1 p) (anno C2 p)) (strip C1)"

instantiation acom :: (widen)widen
begin
definition "widen_acom = map2_acom (op \<nabla>)"
instance ..
end

instantiation acom :: (narrow)narrow
begin
definition "narrow_acom = map2_acom (op \<triangle>)"
instance ..
end

lemma strip_map2_acom[simp]:
 "strip C1 = strip C2 \<Longrightarrow> strip(map2_acom f C1 C2) = strip C1"
by(simp add: map2_acom_def)
(*by(induct f C1 C2 rule: map2_acom.induct) simp_all*)

lemma strip_widen_acom[simp]:
  "strip C1 = strip C2 \<Longrightarrow> strip(C1 \<nabla> C2) = strip C1"
by(simp add: widen_acom_def)

lemma strip_narrow_acom[simp]:
  "strip C1 = strip C2 \<Longrightarrow> strip(C1 \<triangle> C2) = strip C1"
by(simp add: narrow_acom_def)

lemma narrow1_acom: "C2 \<le> C1 \<Longrightarrow> C2 \<le> C1 \<triangle> (C2::'a::wn acom)"
by(simp add: narrow_acom_def narrow1 map2_acom_def less_eq_acom_def size_annos)

lemma narrow2_acom: "C2 \<le> C1 \<Longrightarrow> C1 \<triangle> (C2::'a::wn acom) \<le> C1"
by(simp add: narrow_acom_def narrow2 map2_acom_def less_eq_acom_def size_annos)

subsubsection "Pre-fixpoint computation"

definition iter_widen :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> ('a::{order,widen})option"
where "iter_widen f = while_option (\<lambda>x. \<not> f x \<le> x) (\<lambda>x. x \<nabla> f x)"

definition iter_narrow :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> ('a::{order,narrow})option"
where "iter_narrow f = while_option (\<lambda>x. x \<triangle> f x < x) (\<lambda>x. x \<triangle> f x)"

definition pfp_wn :: "('a::{order,widen,narrow} \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option"
where "pfp_wn f x =
  (case iter_widen f x of None \<Rightarrow> None | Some p \<Rightarrow> iter_narrow f p)"

lemma iter_widen_pfp: "iter_widen f x = Some p \<Longrightarrow> f p \<le> p"
by(auto simp add: iter_widen_def dest: while_option_stop)

lemma iter_widen_inv:
assumes "!!x. P x \<Longrightarrow> P(f x)" "!!x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P(x1 \<nabla> x2)" and "P x"
and "iter_widen f x = Some y" shows "P y"
using while_option_rule[where P = "P", OF _ assms(4)[unfolded iter_widen_def]]
by (blast intro: assms(1-3))

lemma strip_while: fixes f :: "'a acom \<Rightarrow> 'a acom"
assumes "\<forall>C. strip (f C) = strip C" and "while_option P f C = Some C'"
shows "strip C' = strip C"
using while_option_rule[where P = "\<lambda>C'. strip C' = strip C", OF _ assms(2)]
by (metis assms(1))

lemma strip_iter_widen: fixes f :: "'a::{order,widen} acom \<Rightarrow> 'a acom"
assumes "\<forall>C. strip (f C) = strip C" and "iter_widen f C = Some C'"
shows "strip C' = strip C"
proof-
  have "\<forall>C. strip(C \<nabla> f C) = strip C"
    by (metis assms(1) strip_map2_acom widen_acom_def)
  from strip_while[OF this] assms(2) show ?thesis by(simp add: iter_widen_def)
qed

lemma iter_narrow_pfp:
assumes mono: "!!x1 x2::_::wn acom. P x1 \<Longrightarrow> P x2 \<Longrightarrow> x1 \<le> x2 \<Longrightarrow> f x1 \<le> f x2"
and Pinv: "!!x. P x \<Longrightarrow> P(f x)" "!!x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P(x1 \<triangle> x2)"
and "P p0" and "f p0 \<le> p0" and "iter_narrow f p0 = Some p"
shows "P p \<and> f p \<le> p"
proof-
  let ?Q = "%p. P p \<and> f p \<le> p \<and> p \<le> p0"
  { fix p assume "?Q p"
    note P = conjunct1[OF this] and 12 = conjunct2[OF this]
    note 1 = conjunct1[OF 12] and 2 = conjunct2[OF 12]
    let ?p' = "p \<triangle> f p"
    have "?Q ?p'"
    proof auto
      show "P ?p'" by (blast intro: P Pinv)
      have "f ?p' \<le> f p" by(rule mono[OF `P (p \<triangle> f p)`  P narrow2_acom[OF 1]])
      also have "\<dots> \<le> ?p'" by(rule narrow1_acom[OF 1])
      finally show "f ?p' \<le> ?p'" .
      have "?p' \<le> p" by (rule narrow2_acom[OF 1])
      also have "p \<le> p0" by(rule 2)
      finally show "?p' \<le> p0" .
    qed
  }
  thus ?thesis
    using while_option_rule[where P = ?Q, OF _ assms(6)[simplified iter_narrow_def]]
    by (blast intro: assms(4,5) le_refl)
qed

lemma pfp_wn_pfp:
assumes mono: "!!x1 x2::_::wn acom. P x1 \<Longrightarrow> P x2 \<Longrightarrow> x1 \<le> x2 \<Longrightarrow> f x1 \<le> f x2"
and Pinv: "P x"  "!!x. P x \<Longrightarrow> P(f x)"
  "!!x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P(x1 \<nabla> x2)"
  "!!x1 x2. P x1 \<Longrightarrow> P x2 \<Longrightarrow> P(x1 \<triangle> x2)"
and pfp_wn: "pfp_wn f x = Some p" shows "P p \<and> f p \<le> p"
proof-
  from pfp_wn obtain p0
    where its: "iter_widen f x = Some p0" "iter_narrow f p0 = Some p"
    by(auto simp: pfp_wn_def split: option.splits)
  have "P p0" by (blast intro: iter_widen_inv[where P="P"] its(1) Pinv(1-3))
  thus ?thesis
    by - (assumption |
          rule iter_narrow_pfp[where P=P] mono Pinv(2,4) iter_widen_pfp its)+
qed

lemma strip_pfp_wn:
  "\<lbrakk> \<forall>C. strip(f C) = strip C; pfp_wn f C = Some C' \<rbrakk> \<Longrightarrow> strip C' = strip C"
by(auto simp add: pfp_wn_def iter_narrow_def split: option.splits)
  (metis (mono_tags) strip_iter_widen strip_narrow_acom strip_while)

locale Abs_Int_wn = Abs_Int_inv_mono where \<gamma>=\<gamma>
  for \<gamma> :: "'av::{wn,bounded_lattice} \<Rightarrow> val set"
begin

definition AI_wn :: "com \<Rightarrow> 'av st option acom option" where
"AI_wn c = pfp_wn (step' \<top>) (bot c)"

lemma AI_wn_correct: "AI_wn c = Some C \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c C"
proof(simp add: CS_def AI_wn_def)
  assume 1: "pfp_wn (step' \<top>) (bot c) = Some C"
  have 2: "strip C = c \<and> step' \<top> C \<le> C"
    by(rule pfp_wn_pfp[where x="bot c"]) (simp_all add: 1 mono_step'_top)
  have pfp: "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le> \<gamma>\<^sub>c C"
  proof(rule order_trans)
    show "step (\<gamma>\<^sub>o \<top>) (\<gamma>\<^sub>c C) \<le>  \<gamma>\<^sub>c (step' \<top> C)"
      by(rule step_step')
    show "... \<le> \<gamma>\<^sub>c C"
      by(rule mono_gamma_c[OF conjunct2[OF 2]])
  qed
  have 3: "strip (\<gamma>\<^sub>c C) = c" by(simp add: strip_pfp_wn[OF _ 1])
  have "lfp c (step (\<gamma>\<^sub>o \<top>)) \<le> \<gamma>\<^sub>c C"
    by(rule lfp_lowerbound[simplified,where f="step (\<gamma>\<^sub>o \<top>)", OF 3 pfp])
  thus "lfp c (step UNIV) \<le> \<gamma>\<^sub>c C" by simp
qed

end

global_interpretation Abs_Int_wn
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = "op +"
and test_num' = in_ivl
and inv_plus' = inv_plus_ivl and inv_less' = inv_less_ivl
defines AI_wn_ivl = AI_wn
..

subsubsection "Tests"

definition "step_up_ivl n = ((\<lambda>C. C \<nabla> step_ivl \<top> C)^^n)"
definition "step_down_ivl n = ((\<lambda>C. C \<triangle> step_ivl \<top> C)^^n)"

text{* For @{const test3_ivl}, @{const AI_ivl} needed as many iterations as
the loop took to execute. In contrast, @{const AI_wn_ivl} converges in a
constant number of steps: *}

value "show_acom (step_up_ivl 1 (bot test3_ivl))"
value "show_acom (step_up_ivl 2 (bot test3_ivl))"
value "show_acom (step_up_ivl 3 (bot test3_ivl))"
value "show_acom (step_up_ivl 4 (bot test3_ivl))"
value "show_acom (step_up_ivl 5 (bot test3_ivl))"
value "show_acom (step_up_ivl 6 (bot test3_ivl))"
value "show_acom (step_up_ivl 7 (bot test3_ivl))"
value "show_acom (step_up_ivl 8 (bot test3_ivl))"
value "show_acom (step_down_ivl 1 (step_up_ivl 8 (bot test3_ivl)))"
value "show_acom (step_down_ivl 2 (step_up_ivl 8 (bot test3_ivl)))"
value "show_acom (step_down_ivl 3 (step_up_ivl 8 (bot test3_ivl)))"
value "show_acom (step_down_ivl 4 (step_up_ivl 8 (bot test3_ivl)))"
value "show_acom_opt (AI_wn_ivl test3_ivl)"

text{* Now all the analyses terminate: *}

value "show_acom_opt (AI_wn_ivl test4_ivl)"
value "show_acom_opt (AI_wn_ivl test5_ivl)"
value "show_acom_opt (AI_wn_ivl test6_ivl)"

subsubsection "Generic Termination Proof"

lemma top_on_opt_widen:
  "top_on_opt o1 X \<Longrightarrow> top_on_opt o2 X \<Longrightarrow> top_on_opt (o1 \<nabla> o2 :: _ st option) X"
apply(induct o1 o2 rule: widen_option.induct)
apply (auto)
by transfer simp

lemma top_on_opt_narrow:
  "top_on_opt o1 X \<Longrightarrow> top_on_opt o2 X \<Longrightarrow> top_on_opt (o1 \<triangle> o2 :: _ st option) X"
apply(induct o1 o2 rule: narrow_option.induct)
apply (auto)
by transfer simp

(* FIXME mk anno abbrv *)
lemma annos_map2_acom[simp]: "strip C2 = strip C1 \<Longrightarrow>
  annos(map2_acom f C1 C2) = map (%(x,y).f x y) (zip (annos C1) (annos C2))"
by(simp add: map2_acom_def list_eq_iff_nth_eq size_annos anno_def[symmetric] size_annos_same[of C1 C2])

lemma top_on_acom_widen:
  "\<lbrakk>top_on_acom C1 X; strip C1 = strip C2; top_on_acom C2 X\<rbrakk>
  \<Longrightarrow> top_on_acom (C1 \<nabla> C2 :: _ st option acom) X"
by(auto simp add: widen_acom_def top_on_acom_def)(metis top_on_opt_widen in_set_zipE)

lemma top_on_acom_narrow:
  "\<lbrakk>top_on_acom C1 X; strip C1 = strip C2; top_on_acom C2 X\<rbrakk>
  \<Longrightarrow> top_on_acom (C1 \<triangle> C2 :: _ st option acom) X"
by(auto simp add: narrow_acom_def top_on_acom_def)(metis top_on_opt_narrow in_set_zipE)

text{* The assumptions for widening and narrowing differ because during
narrowing we have the invariant @{prop"y \<le> x"} (where @{text y} is the next
iterate), but during widening there is no such invariant, there we only have
that not yet @{prop"y \<le> x"}. This complicates the termination proof for
widening. *}

locale Measure_wn = Measure1 where m=m
  for m :: "'av::{order_top,wn} \<Rightarrow> nat" +
fixes n :: "'av \<Rightarrow> nat"
assumes m_anti_mono: "x \<le> y \<Longrightarrow> m x \<ge> m y"
assumes m_widen: "~ y \<le> x \<Longrightarrow> m(x \<nabla> y) < m x"
assumes n_narrow: "y \<le> x \<Longrightarrow> x \<triangle> y < x \<Longrightarrow> n(x \<triangle> y) < n x"

begin

lemma m_s_anti_mono_rep: assumes "\<forall>x. S1 x \<le> S2 x"
shows "(\<Sum>x\<in>X. m (S2 x)) \<le> (\<Sum>x\<in>X. m (S1 x))"
proof-
  from assms have "\<forall>x. m(S1 x) \<ge> m(S2 x)" by (metis m_anti_mono)
  thus "(\<Sum>x\<in>X. m (S2 x)) \<le> (\<Sum>x\<in>X. m (S1 x))" by (metis sum_mono)
qed

lemma m_s_anti_mono: "S1 \<le> S2 \<Longrightarrow> m_s S1 X \<ge> m_s S2 X"
unfolding m_s_def
apply (transfer fixing: m)
apply(simp add: less_eq_st_rep_iff eq_st_def m_s_anti_mono_rep)
done

lemma m_s_widen_rep: assumes "finite X" "S1 = S2 on -X" "\<not> S2 x \<le> S1 x"
  shows "(\<Sum>x\<in>X. m (S1 x \<nabla> S2 x)) < (\<Sum>x\<in>X. m (S1 x))"
proof-
  have 1: "\<forall>x\<in>X. m(S1 x) \<ge> m(S1 x \<nabla> S2 x)"
    by (metis m_anti_mono wn_class.widen1)
  have "x \<in> X" using assms(2,3)
    by(auto simp add: Ball_def)
  hence 2: "\<exists>x\<in>X. m(S1 x) > m(S1 x \<nabla> S2 x)"
    using assms(3) m_widen by blast
  from sum_strict_mono_ex1[OF `finite X` 1 2]
  show ?thesis .
qed

lemma m_s_widen: "finite X \<Longrightarrow> fun S1 = fun S2 on -X ==>
  ~ S2 \<le> S1 \<Longrightarrow> m_s (S1 \<nabla> S2) X < m_s S1 X"
apply(auto simp add: less_st_def m_s_def)
apply (transfer fixing: m)
apply(auto simp add: less_eq_st_rep_iff m_s_widen_rep)
done

lemma m_o_anti_mono: "finite X \<Longrightarrow> top_on_opt o1 (-X) \<Longrightarrow> top_on_opt o2 (-X) \<Longrightarrow>
  o1 \<le> o2 \<Longrightarrow> m_o o1 X \<ge> m_o o2 X"
proof(induction o1 o2 rule: less_eq_option.induct)
  case 1 thus ?case by (simp add: m_o_def)(metis m_s_anti_mono)
next
  case 2 thus ?case
    by(simp add: m_o_def le_SucI m_s_h split: option.splits)
next
  case 3 thus ?case by simp
qed

lemma m_o_widen: "\<lbrakk> finite X; top_on_opt S1 (-X); top_on_opt S2 (-X); \<not> S2 \<le> S1 \<rbrakk> \<Longrightarrow>
  m_o (S1 \<nabla> S2) X < m_o S1 X"
by(auto simp: m_o_def m_s_h less_Suc_eq_le m_s_widen split: option.split)

lemma m_c_widen:
  "strip C1 = strip C2  \<Longrightarrow> top_on_acom C1 (-vars C1) \<Longrightarrow> top_on_acom C2 (-vars C2)
   \<Longrightarrow> \<not> C2 \<le> C1 \<Longrightarrow> m_c (C1 \<nabla> C2) < m_c C1"
apply(auto simp: m_c_def widen_acom_def map2_acom_def size_annos[symmetric] anno_def[symmetric]sum_list_sum_nth)
apply(subgoal_tac "length(annos C2) = length(annos C1)")
 prefer 2 apply (simp add: size_annos_same2)
apply (auto)
apply(rule sum_strict_mono_ex1)
 apply(auto simp add: m_o_anti_mono vars_acom_def anno_def top_on_acom_def top_on_opt_widen widen1 less_eq_acom_def listrel_iff_nth)
apply(rule_tac x=p in bexI)
 apply (auto simp: vars_acom_def m_o_widen top_on_acom_def)
done

definition n_s :: "'av st \<Rightarrow> vname set \<Rightarrow> nat" ("n\<^sub>s") where
"n\<^sub>s S X = (\<Sum>x\<in>X. n(fun S x))"

lemma n_s_narrow_rep:
assumes "finite X"  "S1 = S2 on -X"  "\<forall>x. S2 x \<le> S1 x"  "\<forall>x. S1 x \<triangle> S2 x \<le> S1 x"
  "S1 x \<noteq> S1 x \<triangle> S2 x"
shows "(\<Sum>x\<in>X. n (S1 x \<triangle> S2 x)) < (\<Sum>x\<in>X. n (S1 x))"
proof-
  have 1: "\<forall>x. n(S1 x \<triangle> S2 x) \<le> n(S1 x)"
      by (metis assms(3) assms(4) eq_iff less_le_not_le n_narrow)
  have "x \<in> X" by (metis Compl_iff assms(2) assms(5) narrowid)
  hence 2: "\<exists>x\<in>X. n(S1 x \<triangle> S2 x) < n(S1 x)"
    by (metis assms(3-5) eq_iff less_le_not_le n_narrow)
  show ?thesis
    apply(rule sum_strict_mono_ex1[OF `finite X`]) using 1 2 by blast+
qed

lemma n_s_narrow: "finite X \<Longrightarrow> fun S1 = fun S2 on -X \<Longrightarrow> S2 \<le> S1 \<Longrightarrow> S1 \<triangle> S2 < S1
  \<Longrightarrow> n\<^sub>s (S1 \<triangle> S2) X < n\<^sub>s S1 X"
apply(auto simp add: less_st_def n_s_def)
apply (transfer fixing: n)
apply(auto simp add: less_eq_st_rep_iff eq_st_def fun_eq_iff n_s_narrow_rep)
done

definition n_o :: "'av st option \<Rightarrow> vname set \<Rightarrow> nat" ("n\<^sub>o") where
"n\<^sub>o opt X = (case opt of None \<Rightarrow> 0 | Some S \<Rightarrow> n\<^sub>s S X + 1)"

lemma n_o_narrow:
  "top_on_opt S1 (-X) \<Longrightarrow> top_on_opt S2 (-X) \<Longrightarrow> finite X
  \<Longrightarrow> S2 \<le> S1 \<Longrightarrow> S1 \<triangle> S2 < S1 \<Longrightarrow> n\<^sub>o (S1 \<triangle> S2) X < n\<^sub>o S1 X"
apply(induction S1 S2 rule: narrow_option.induct)
apply(auto simp: n_o_def n_s_narrow)
done

definition n_c :: "'av st option acom \<Rightarrow> nat" ("n\<^sub>c") where
"n\<^sub>c C = sum_list (map (\<lambda>a. n\<^sub>o a (vars C)) (annos C))"

lemma less_annos_iff: "(C1 < C2) = (C1 \<le> C2 \<and>
  (\<exists>i<length (annos C1). annos C1 ! i < annos C2 ! i))"
by(metis (hide_lams, no_types) less_le_not_le le_iff_le_annos size_annos_same2)

lemma n_c_narrow: "strip C1 = strip C2
  \<Longrightarrow> top_on_acom C1 (- vars C1) \<Longrightarrow> top_on_acom C2 (- vars C2)
  \<Longrightarrow> C2 \<le> C1 \<Longrightarrow> C1 \<triangle> C2 < C1 \<Longrightarrow> n\<^sub>c (C1 \<triangle> C2) < n\<^sub>c C1"
apply(auto simp: n_c_def narrow_acom_def sum_list_sum_nth)
apply(subgoal_tac "length(annos C2) = length(annos C1)")
prefer 2 apply (simp add: size_annos_same2)
apply (auto)
apply(simp add: less_annos_iff le_iff_le_annos)
apply(rule sum_strict_mono_ex1)
apply (auto simp: vars_acom_def top_on_acom_def)
apply (metis n_o_narrow nth_mem finite_cvars less_imp_le le_less order_refl)
apply(rule_tac x=i in bexI)
prefer 2 apply simp
apply(rule n_o_narrow[where X = "vars(strip C2)"])
apply (simp_all)
done

end

lemma iter_widen_termination:
fixes m :: "'a::wn acom \<Rightarrow> nat"
assumes P_f: "\<And>C. P C \<Longrightarrow> P(f C)"
and P_widen: "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> P(C1 \<nabla> C2)"
and m_widen: "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> ~ C2 \<le> C1 \<Longrightarrow> m(C1 \<nabla> C2) < m C1"
and "P C" shows "EX C'. iter_widen f C = Some C'"
proof(simp add: iter_widen_def,
      rule measure_while_option_Some[where P = P and f=m])
  show "P C" by(rule `P C`)
next
  fix C assume "P C" "\<not> f C \<le> C" thus "P (C \<nabla> f C) \<and> m (C \<nabla> f C) < m C"
    by(simp add: P_f P_widen m_widen)
qed

lemma iter_narrow_termination:
fixes n :: "'a::wn acom \<Rightarrow> nat"
assumes P_f: "\<And>C. P C \<Longrightarrow> P(f C)"
and P_narrow: "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> P(C1 \<triangle> C2)"
and mono: "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> C1 \<le> C2 \<Longrightarrow> f C1 \<le> f C2"
and n_narrow: "\<And>C1 C2. P C1 \<Longrightarrow> P C2 \<Longrightarrow> C2 \<le> C1 \<Longrightarrow> C1 \<triangle> C2 < C1 \<Longrightarrow> n(C1 \<triangle> C2) < n C1"
and init: "P C" "f C \<le> C" shows "EX C'. iter_narrow f C = Some C'"
proof(simp add: iter_narrow_def,
      rule measure_while_option_Some[where f=n and P = "%C. P C \<and> f C \<le> C"])
  show "P C \<and> f C \<le> C" using init by blast
next
  fix C assume 1: "P C \<and> f C \<le> C" and 2: "C \<triangle> f C < C"
  hence "P (C \<triangle> f C)" by(simp add: P_f P_narrow)
  moreover then have "f (C \<triangle> f C) \<le> C \<triangle> f C"
    by (metis narrow1_acom narrow2_acom 1 mono order_trans)
  moreover have "n (C \<triangle> f C) < n C" using 1 2 by(simp add: n_narrow P_f)
  ultimately show "(P (C \<triangle> f C) \<and> f (C \<triangle> f C) \<le> C \<triangle> f C) \<and> n(C \<triangle> f C) < n C"
    by blast
qed

locale Abs_Int_wn_measure = Abs_Int_wn where \<gamma>=\<gamma> + Measure_wn where m=m
  for \<gamma> :: "'av::{wn,bounded_lattice} \<Rightarrow> val set" and m :: "'av \<Rightarrow> nat"

subsubsection "Termination: Intervals"

definition m_rep :: "eint2 \<Rightarrow> nat" where
"m_rep p = (if is_empty_rep p then 3 else
  let (l,h) = p in (case l of Minf \<Rightarrow> 0 | _ \<Rightarrow> 1) + (case h of Pinf \<Rightarrow> 0 | _ \<Rightarrow> 1))"

lift_definition m_ivl :: "ivl \<Rightarrow> nat" is m_rep
by(auto simp: m_rep_def eq_ivl_iff)

lemma m_ivl_nice: "m_ivl[l,h] = (if [l,h] = \<bottom> then 3 else
   (if l = Minf then 0 else 1) + (if h = Pinf then 0 else 1))"
unfolding bot_ivl_def
by transfer (auto simp: m_rep_def eq_ivl_empty split: extended.split)

lemma m_ivl_height: "m_ivl iv \<le> 3"
by transfer (simp add: m_rep_def split: prod.split extended.split)

lemma m_ivl_anti_mono: "y \<le> x \<Longrightarrow> m_ivl x \<le> m_ivl y"
by transfer
   (auto simp: m_rep_def is_empty_rep_def \<gamma>_rep_cases le_iff_subset
         split: prod.split extended.splits if_splits)

lemma m_ivl_widen:
  "~ y \<le> x \<Longrightarrow> m_ivl(x \<nabla> y) < m_ivl x"
by transfer
   (auto simp: m_rep_def widen_rep_def is_empty_rep_def \<gamma>_rep_cases le_iff_subset
         split: prod.split extended.splits if_splits)

definition n_ivl :: "ivl \<Rightarrow> nat" where
"n_ivl iv = 3 - m_ivl iv"

lemma n_ivl_narrow:
  "x \<triangle> y < x \<Longrightarrow> n_ivl(x \<triangle> y) < n_ivl x"
unfolding n_ivl_def
apply(subst (asm) less_le_not_le)
apply transfer
by(auto simp add: m_rep_def narrow_rep_def is_empty_rep_def empty_rep_def \<gamma>_rep_cases le_iff_subset
         split: prod.splits if_splits extended.split)

global_interpretation Abs_Int_wn_measure
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = "op +"
and test_num' = in_ivl
and inv_plus' = inv_plus_ivl and inv_less' = inv_less_ivl
and m = m_ivl and n = n_ivl and h = 3
proof (standard, goal_cases)
  case 2 thus ?case by(rule m_ivl_anti_mono)
next
  case 1 thus ?case by(rule m_ivl_height)
next
  case 3 thus ?case by(rule m_ivl_widen)
next
  case 4 from 4(2) show ?case by(rule n_ivl_narrow)
  -- "note that the first assms is unnecessary for intervals"
qed

lemma iter_winden_step_ivl_termination:
  "\<exists>C. iter_widen (step_ivl \<top>) (bot c) = Some C"
apply(rule iter_widen_termination[where m = "m_c" and P = "%C. strip C = c \<and> top_on_acom C (- vars C)"])
apply (auto simp add: m_c_widen top_on_bot top_on_step'[simplified comp_def vars_acom_def]
  vars_acom_def top_on_acom_widen)
done

lemma iter_narrow_step_ivl_termination:
  "top_on_acom C (- vars C) \<Longrightarrow> step_ivl \<top> C \<le> C \<Longrightarrow>
  \<exists>C'. iter_narrow (step_ivl \<top>) C = Some C'"
apply(rule iter_narrow_termination[where n = "n_c" and P = "%C'. strip C = strip C' \<and> top_on_acom C' (-vars C')"])
apply(auto simp: top_on_step'[simplified comp_def vars_acom_def]
        mono_step'_top n_c_narrow vars_acom_def top_on_acom_narrow)
done

theorem AI_wn_ivl_termination:
  "\<exists>C. AI_wn_ivl c = Some C"
apply(auto simp: AI_wn_def pfp_wn_def iter_winden_step_ivl_termination
           split: option.split)
apply(rule iter_narrow_step_ivl_termination)
apply(rule conjunct2)
apply(rule iter_widen_inv[where f = "step' \<top>" and P = "%C. c = strip C & top_on_acom C (- vars C)"])
apply(auto simp: top_on_acom_widen top_on_step'[simplified comp_def vars_acom_def]
  iter_widen_pfp top_on_bot vars_acom_def)
done

(*unused_thms Abs_Int_init - *)

subsubsection "Counterexamples"

text{* Widening is increasing by assumption, but @{prop"x \<le> f x"} is not an invariant of widening.
It can already be lost after the first step: *}

lemma assumes "!!x y::'a::wn. x \<le> y \<Longrightarrow> f x \<le> f y"
and "x \<le> f x" and "\<not> f x \<le> x" shows "x \<nabla> f x \<le> f(x \<nabla> f x)"
nitpick[card = 3, expect = genuine, show_consts, timeout = 120]
(*
1 < 2 < 3,
f x = 2,
x widen y = 3 -- guarantees termination with top=3
x = 1
Now f is mono, x <= f x, not f x <= x
but x widen f x = 3, f 3 = 2, but not 3 <= 2
*)
oops

text{* Widening terminates but may converge more slowly than Kleene iteration.
In the following model, Kleene iteration goes from 0 to the least pfp
in one step but widening takes 2 steps to reach a strictly larger pfp: *}
lemma assumes "!!x y::'a::wn. x \<le> y \<Longrightarrow> f x \<le> f y"
and "x \<le> f x" and "\<not> f x \<le> x" and "f(f x) \<le> f x"
shows "f(x \<nabla> f x) \<le> x \<nabla> f x"
nitpick[card = 4, expect = genuine, show_consts, timeout = 120]
(*

   0 < 1 < 2 < 3
f: 1   1   3   3

0 widen 1 = 2
2 widen 3 = 3
and x widen y arbitrary, eg 3, which guarantees termination

Kleene: f(f 0) = f 1 = 1 <= 1 = f 1

but

because not f 0 <= 0, we obtain 0 widen f 0 = 0 wide 1 = 2,
which is again not a pfp: not f 2 = 3 <= 2
Another widening step yields 2 widen f 2 = 2 widen 3 = 3
*)
oops

end


theory setTheoreticalApproach imports Main
begin

(* An Embedding of Free Higher-Order Modal Logic (FHOML) in HOL *)

text \<open> Free Higher Order Modal  Logic \<close>

  typedecl w (* — Type of possible worlds *)
  type_synonym wSet = "w \<Rightarrow> bool"  (* — Type of the set containing worlds *)
  type_synonym wSetSet = "(w \<Rightarrow> bool) \<Rightarrow> bool"  (* — Type of the set containing sets of worlds *)

  text \<open> Set relevant Definitions \<close>

  definition wSetMember :: "w \<Rightarrow> wSet \<Rightarrow> bool" (infixr "\<^bold>\<in>\<^sub>{\<^sub>}" 53)
    where "x \<^bold>\<in>\<^sub>{\<^sub>} S \<equiv> S x"
  definition wSetSetMember :: "wSet \<Rightarrow> wSetSet \<Rightarrow> bool" (infixr "\<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>}" 53)
    where "x \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} S \<equiv> S x"

  definition wSetUnion :: "wSet \<Rightarrow> wSet \<Rightarrow> wSet" (infixr "\<^bold>\<union>" 50)
    where "A \<^bold>\<union> B \<equiv> \<lambda>x. A x \<or> B x"
  definition wSetOther :: "wSet \<Rightarrow> wSet \<Rightarrow> wSet" (infixr "\<^bold>-" 50)
    where "A \<^bold>- B \<equiv> \<lambda>x. A x \<and> \<not>(B x)"
  definition wSetSubsetEq :: "wSet \<Rightarrow> wSet \<Rightarrow> bool" (infixr "\<^bold>\<subseteq>" 50)
    where "A \<^bold>\<subseteq> B \<equiv> \<forall>x. A x \<longrightarrow> B x"

  consts W :: "wSet"
  axiomatization where defW: "\<forall>x. x \<^bold>\<in>\<^sub>{\<^sub>} W"

  consts emptySet :: "wSet" ("\<^bold>{\<^bold>}")
  axiomatization where defEmptySet: "\<forall>x. \<not>(x \<^bold>\<in>\<^sub>{\<^sub>} \<^bold>{\<^bold>})"

  consts emptySetSet :: "wSetSet" ("\<^bold>{\<^bold>{\<^bold>}\<^bold>}")
  axiomatization where defEmptySetSet: "\<forall>x. \<not>(x \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} \<^bold>{\<^bold>{\<^bold>}\<^bold>})"

  text \<open> Free Modal Logic relevant Definitions \<close>

  consts r :: "w \<Rightarrow> w \<Rightarrow> bool" (infixr "r" 53) (* — Accessibility relation between worlds *)

  (* Conditions on the accessibility relation *)
  abbreviation reflexive :: "bool"
    where "reflexive \<equiv> \<forall>x. x r x"
  abbreviation symmetric :: "bool"
    where "symmetric \<equiv> \<forall>x y. x r y \<longrightarrow> y r x"
  abbreviation transitive :: "bool"
    where "transitive \<equiv> \<forall>x y z. (x r y) \<and> (y r z) \<longrightarrow> (x r z)"
  abbreviation universal :: "bool"
    where "universal \<equiv> \<forall>x y. x r y"

  axiomatization where S5:
    "reflexive \<and> symmetric \<and> transitive \<and> universal"

  abbreviation R :: "w \<Rightarrow> wSet" ("\<^bold>R_"[52]53)
    where "\<^bold>R w \<equiv> \<lambda>x. w r x"

  consts fmExistenceDomains :: "w \<Rightarrow> wSetSet" ("D") (* — Existence domains *)

  definition fmTop :: "wSet" ("\<^bold>\<top>")
    where "\<^bold>\<top> \<equiv> W"
  definition fmBot :: "wSet" ("\<^bold>\<bottom>")
    where "\<^bold>\<bottom> \<equiv> \<^bold>{\<^bold>}"

  definition fmIdentity :: "wSet \<Rightarrow> wSet \<Rightarrow> wSet" (infixr "\<^bold>=" 56) (* — Free modal identity *)
    where "\<phi> \<^bold>= \<psi> \<equiv> if (\<phi> = \<psi>) then W else \<^bold>{\<^bold>}"

  definition fmNot :: "wSet \<Rightarrow> wSet" ("\<^bold>\<not>_" [52]53) (* — Free modal negation *)
    where "\<^bold>\<not>\<phi> \<equiv> W \<^bold>- \<phi>"
  definition fmOr :: "wSet \<Rightarrow> wSet \<Rightarrow> wSet" (infixr "\<^bold>\<or>" 51) (* — Free modal disjunction *)
    where "\<phi> \<^bold>\<or> \<psi> \<equiv> \<phi> \<^bold>\<union> \<psi>"

  definition fmBox :: "wSet \<Rightarrow> wSet" ("\<^bold>\<box>_" [52]53) (* — Free modal necessity *)
    where "\<^bold>\<box>\<phi> \<equiv> \<lambda>w. (\<^bold>R w) \<^bold>\<subseteq> \<phi>"

  consts Qex :: "w \<Rightarrow> wSetSet" ("\<^bold>|\<^bold>Q\<^bold>|")
  definition Qin :: "wSet \<Rightarrow> wSet" ("\<^bold>Q")
    where "\<^bold>Q\<phi> \<equiv> \<lambda>w. \<phi> \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} \<^bold>|\<^bold>Q\<^bold>|(w)"

  definition fmForall :: "(wSet \<Rightarrow> wSet) \<Rightarrow> wSet" ("\<^bold>\<forall>") (* — Free modal universal quantification *)
    where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w. \<forall>x. x \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} (D w) \<longrightarrow> w \<^bold>\<in>\<^sub>{\<^sub>} (\<Phi> x)"
  definition fmForallB:: "(wSet \<Rightarrow> wSet) \<Rightarrow> wSet" (binder "\<^bold>\<forall>" [8]9) (* — Binder notation *)
    where "\<^bold>\<forall>x. \<phi> x \<equiv> \<^bold>\<forall>\<phi>"

  definition fmValid :: "wSet \<Rightarrow> bool" ("\<lfloor>_\<rfloor>" [7]8) (* — Validity of free modal formulas *)
    where "\<lfloor>\<phi>\<rfloor> \<equiv> \<phi> = W"

  text \<open> Further logical constants can be defined as usual \<close>

  definition fmAnd :: "wSet \<Rightarrow> wSet \<Rightarrow> wSet" (infixr "\<^bold>\<and>" 52) (* — Free modal conjunction *)
    where "\<phi> \<^bold>\<and> \<psi> \<equiv> \<^bold>\<not>(\<^bold>\<not>\<phi> \<^bold>\<or> \<^bold>\<not>\<psi>)"
  definition fmImp :: "wSet \<Rightarrow> wSet \<Rightarrow> wSet" (infixr "\<^bold>\<rightarrow>" 49) (* — Free modal implication *)
    where "\<phi> \<^bold>\<rightarrow> \<psi> \<equiv> \<^bold>\<not>\<phi> \<^bold>\<or> \<psi>"
  definition fmEquiv :: "wSet \<Rightarrow> wSet \<Rightarrow> wSet" (infixr "\<^bold>\<leftrightarrow>" 50) (* — Free modal equivalence *)
    where "\<phi> \<^bold>\<leftrightarrow> \<psi> \<equiv> (\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<and> (\<psi> \<^bold>\<rightarrow> \<phi>)"

  definition fmDia :: "wSet \<Rightarrow> wSet" ("\<^bold>\<diamond>_" [52]53) (* — Free modal possibility *)
    where "\<^bold>\<diamond>\<phi> \<equiv> \<^bold>\<not>(\<^bold>\<box>\<^bold>\<not>\<phi>)"

  definition fmExists :: "(wSet \<Rightarrow> wSet) \<Rightarrow> wSet" ("\<^bold>\<exists>") (* — Free modal existential quantification *)
    where "\<^bold>\<exists>\<Phi> \<equiv> \<^bold>\<not>(\<^bold>\<forall>(\<lambda>y. \<^bold>\<not>(\<Phi> y)))"
  definition fmExistsB:: "(wSet \<Rightarrow> wSet) \<Rightarrow> wSet" (binder "\<^bold>\<exists>" [8]9) (* — Binder notation *)
    where "\<^bold>\<exists>x. \<phi> x \<equiv> \<^bold>\<exists>\<phi>"

  (* Introducing "Defs" as the set of the above definitions; useful for convenient unfolding *)
  named_theorems Defs declare defW[Defs] defEmptySet[Defs] defEmptySetSet[Defs]
    wSetMember_def[Defs] wSetMember_def[Defs] wSetOther_def[Defs] wSetUnion_def[Defs]
    wSetSubsetEq_def[Defs] fmTop_def[Defs] fmBot_def[Defs] fmIdentity_def[Defs] fmNot_def[Defs]
    fmOr_def[Defs] fmBox_def[Defs] Qin_def[Defs] fmForall_def[Defs] fmForallB_def[Defs]
    fmAnd_def[Defs] fmImp_def[Defs] fmEquiv_def[Defs] fmExists_def[Defs] fmExistsB_def[Defs]
    fmDia_def[Defs] fmValid_def[Defs]

text \<open> Some Tests \<close>

  lemma "\<lfloor>(\<^bold>\<forall>x. P) \<^bold>\<rightarrow> A\<rfloor>" unfolding Defs nitpick [user_axioms=true, show_all, format=2] oops
  lemma "\<lfloor>(\<^bold>\<forall>x. A x) \<^bold>\<rightarrow> A x\<rfloor>" unfolding Defs nitpick [user_axioms=true, show_all, format=2] oops

  lemma "\<lfloor>A \<^bold>\<rightarrow> (\<^bold>\<exists>x. P)\<rfloor>" unfolding Defs nitpick [user_axioms=true, show_all, format=2] oops
  lemma "\<lfloor>A x \<^bold>\<rightarrow> (\<^bold>\<exists>x. A x)\<rfloor>" unfolding Defs nitpick [user_axioms=true, show_all, format=2] oops

text \<open> Prior's Theorem \<close>

  text \<open> Proposition 4.1.: Finite countermodel with constant, possibly empty existence domains \<close>

  (*
  axiomatization where Ax1: "\<forall>x. (D x) = \<^bold>{\<^bold>{\<^bold>}\<^bold>}"
  axiomatization where Ax2: "\<exists>x. W \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} \<^bold>|\<^bold>Q\<^bold>|(x) \<and> \<^bold>{\<^bold>} \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} \<^bold>|\<^bold>Q\<^bold>|(x)"
  *)

  lemma "\<lfloor>(\<^bold>Q (\<^bold>\<forall>p. (\<^bold>Q p \<^bold>\<rightarrow> \<^bold>\<not>p))) \<^bold>\<rightarrow> ((\<^bold>\<exists>p. \<^bold>Q p \<^bold>\<and> p) \<^bold>\<and> (\<^bold>\<exists>p. \<^bold>Q p \<^bold>\<and> \<^bold>\<not>p))\<rfloor>"
    unfolding Defs
    nitpick [user_axioms=true, format=2, show_all]
    oops

  text \<open> Proposition 4.2.: Finite countermodel with constant, nonempty existence domains \<close>

  axiomatization where fmNonemptyExistenceDomains: "\<forall>w. (D w) \<noteq> \<^bold>{\<^bold>{\<^bold>}\<^bold>}"

  axiomatization where Ax1: "\<forall>x y. (D x) = (D y)"
  axiomatization where Ax2: "\<forall>x. W \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} (D x) \<and> \<^bold>{\<^bold>} \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} (D x)"
  axiomatization where Ax3: "\<forall>x y. (y \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} (D x)) \<longrightarrow> ((y = \<^bold>{\<^bold>}) \<or> (y = W))"
  axiomatization where Ax4: "\<exists>x. W \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} \<^bold>|\<^bold>Q\<^bold>|(x) \<and> (\<forall>y. y \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} \<^bold>|\<^bold>Q\<^bold>|(x) \<longrightarrow> y = W)"
  axiomatization where Ax5: "\<exists>x. \<^bold>{\<^bold>} \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} \<^bold>|\<^bold>Q\<^bold>|(x) \<and> (\<forall>y. y \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} \<^bold>|\<^bold>Q\<^bold>|(x) \<longrightarrow> y = \<^bold>{\<^bold>})"
  axiomatization where Ax6: "\<exists>x. \<forall>y. ((y \<noteq> \<^bold>{\<^bold>}) \<and> (y \<noteq> W)) \<longrightarrow> (y \<^bold>\<in>\<^sub>{\<^sub>{\<^sub>}\<^sub>} \<^bold>|\<^bold>Q\<^bold>|(x))"

  lemma "\<lfloor>(\<^bold>Q (\<^bold>\<forall>p. (\<^bold>Q p \<^bold>\<rightarrow> \<^bold>\<not>p))) \<^bold>\<rightarrow> ((\<^bold>\<exists>p. \<^bold>Q p \<^bold>\<and> p) \<^bold>\<and> (\<^bold>\<exists>p. \<^bold>Q p \<^bold>\<and> \<^bold>\<not>p))\<rfloor>"
    unfolding Defs
    nitpick [user_axioms=true, format=2, show_all, card=3]
    oops


(* 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_bin_s
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun toNat :: "Bin => int" where
"toNat (One) = 1"
| "toNat (ZeroAnd xs) = (toNat xs) + (toNat xs)"
| "toNat (OneAnd ys) = (1 + (toNat ys)) + (toNat ys)"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

theorem property0 :
  "((toNat (s n)) = (1 + (toNat n)))"
  oops

end


section \<open>Using Hoare Logic\<close>

theory Hoare_Ex
imports Hoare
begin

subsection \<open>State spaces\<close>

text \<open>First of all we provide a store of program variables that
  occur in any of the programs considered later.  Slightly unexpected
  things may happen when attempting to work with undeclared variables.\<close>

record vars =
  I :: nat
  M :: nat
  N :: nat
  S :: nat

text \<open>While all of our variables happen to have the same type,
  nothing would prevent us from working with many-sorted programs as
  well, or even polymorphic ones.  Also note that Isabelle/HOL's
  extensible record types even provides simple means to extend the
  state space later.\<close>

subsection \<open>Basic examples\<close>

text \<open>We look at few trivialities involving assignment and
  sequential composition, in order to get an idea of how to work with
  our formulation of Hoare Logic.\<close>

text \<open>Using the basic @{text assign} rule directly is a bit
  cumbersome.\<close>

lemma "\<turnstile> \<lbrace>\<acute>(N_update (\<lambda>_. (2 * \<acute>N))) \<in> \<lbrace>\<acute>N = 10\<rbrace>\<rbrace> \<acute>N := 2 * \<acute>N \<lbrace>\<acute>N = 10\<rbrace>"
  by (rule assign)

text \<open>Certainly we want the state modification already done, e.g.\
  by simplification.  The \name{hoare} method performs the basic state
  update for us; we may apply the Simplifier afterwards to achieve
  ``obvious'' consequences as well.\<close>

lemma "\<turnstile> \<lbrace>True\<rbrace> \<acute>N := 10 \<lbrace>\<acute>N = 10\<rbrace>"
  by hoare

lemma "\<turnstile> \<lbrace>2 * \<acute>N = 10\<rbrace> \<acute>N := 2 * \<acute>N \<lbrace>\<acute>N = 10\<rbrace>"
  by hoare

lemma "\<turnstile> \<lbrace>\<acute>N = 5\<rbrace> \<acute>N := 2 * \<acute>N \<lbrace>\<acute>N = 10\<rbrace>"
  by hoare simp

lemma "\<turnstile> \<lbrace>\<acute>N + 1 = a + 1\<rbrace> \<acute>N := \<acute>N + 1 \<lbrace>\<acute>N = a + 1\<rbrace>"
  by hoare

lemma "\<turnstile> \<lbrace>\<acute>N = a\<rbrace> \<acute>N := \<acute>N + 1 \<lbrace>\<acute>N = a + 1\<rbrace>"
  by hoare simp

lemma "\<turnstile> \<lbrace>a = a \<and> b = b\<rbrace> \<acute>M := a; \<acute>N := b \<lbrace>\<acute>M = a \<and> \<acute>N = b\<rbrace>"
  by hoare

lemma "\<turnstile> \<lbrace>True\<rbrace> \<acute>M := a; \<acute>N := b \<lbrace>\<acute>M = a \<and> \<acute>N = b\<rbrace>"
  by hoare

lemma
  "\<turnstile> \<lbrace>\<acute>M = a \<and> \<acute>N = b\<rbrace>
      \<acute>I := \<acute>M; \<acute>M := \<acute>N; \<acute>N := \<acute>I
      \<lbrace>\<acute>M = b \<and> \<acute>N = a\<rbrace>"
  by hoare simp

text \<open>It is important to note that statements like the following one
  can only be proven for each individual program variable.  Due to the
  extra-logical nature of record fields, we cannot formulate a theorem
  relating record selectors and updates schematically.\<close>

lemma "\<turnstile> \<lbrace>\<acute>N = a\<rbrace> \<acute>N := \<acute>N \<lbrace>\<acute>N = a\<rbrace>"
  by hoare

lemma "\<turnstile> \<lbrace>\<acute>x = a\<rbrace> \<acute>x := \<acute>x \<lbrace>\<acute>x = a\<rbrace>"
  oops

lemma
  "Valid {s. x s = a} (Basic (\<lambda>s. x_update (x s) s)) {s. x s = n}"
  -- \<open>same statement without concrete syntax\<close>
  oops

text \<open>In the following assignments we make use of the consequence
  rule in order to achieve the intended precondition.  Certainly, the
  \name{hoare} method is able to handle this case, too.\<close>

lemma "\<turnstile> \<lbrace>\<acute>M = \<acute>N\<rbrace> \<acute>M := \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
proof -
  have "\<lbrace>\<acute>M = \<acute>N\<rbrace> \<subseteq> \<lbrace>\<acute>M + 1 \<noteq> \<acute>N\<rbrace>"
    by auto
  also have "\<turnstile> \<dots> \<acute>M := \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
    by hoare
  finally show ?thesis .
qed

lemma "\<turnstile> \<lbrace>\<acute>M = \<acute>N\<rbrace> \<acute>M := \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
proof -
  have "\<And>m n::nat. m = n \<longrightarrow> m + 1 \<noteq> n"
      -- \<open>inclusion of assertions expressed in ``pure'' logic,\<close>
      -- \<open>without mentioning the state space\<close>
    by simp
  also have "\<turnstile> \<lbrace>\<acute>M + 1 \<noteq> \<acute>N\<rbrace> \<acute>M := \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
    by hoare
  finally show ?thesis .
qed

lemma "\<turnstile> \<lbrace>\<acute>M = \<acute>N\<rbrace> \<acute>M := \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
  by hoare simp

subsection \<open>Multiplication by addition\<close>

text \<open>We now do some basic examples of actual \texttt{WHILE}
  programs.  This one is a loop for calculating the product of two
  natural numbers, by iterated addition.  We first give detailed
  structured proof based on single-step Hoare rules.\<close>

lemma
  "\<turnstile> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
      WHILE \<acute>M \<noteq> a
      DO \<acute>S := \<acute>S + b; \<acute>M := \<acute>M + 1 OD
      \<lbrace>\<acute>S = a * b\<rbrace>"
proof -
  let "\<turnstile> _ ?while _" = ?thesis
  let "\<lbrace>\<acute>?inv\<rbrace>" = "\<lbrace>\<acute>S = \<acute>M * b\<rbrace>"

  have "\<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace> \<subseteq> \<lbrace>\<acute>?inv\<rbrace>" by auto
  also have "\<turnstile> \<dots> ?while \<lbrace>\<acute>?inv \<and> \<not> (\<acute>M \<noteq> a)\<rbrace>"
  proof
    let ?c = "\<acute>S := \<acute>S + b; \<acute>M := \<acute>M + 1"
    have "\<lbrace>\<acute>?inv \<and> \<acute>M \<noteq> a\<rbrace> \<subseteq> \<lbrace>\<acute>S + b = (\<acute>M + 1) * b\<rbrace>"
      by auto
    also have "\<turnstile> \<dots> ?c \<lbrace>\<acute>?inv\<rbrace>" by hoare
    finally show "\<turnstile> \<lbrace>\<acute>?inv \<and> \<acute>M \<noteq> a\<rbrace> ?c \<lbrace>\<acute>?inv\<rbrace>" .
  qed
  also have "\<dots> \<subseteq> \<lbrace>\<acute>S = a * b\<rbrace>" by auto
  finally show ?thesis .
qed

text \<open>The subsequent version of the proof applies the @{text hoare}
  method to reduce the Hoare statement to a purely logical problem
  that can be solved fully automatically.  Note that we have to
  specify the \texttt{WHILE} loop invariant in the original statement.\<close>

lemma
  "\<turnstile> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
      WHILE \<acute>M \<noteq> a
      INV \<lbrace>\<acute>S = \<acute>M * b\<rbrace>
      DO \<acute>S := \<acute>S + b; \<acute>M := \<acute>M + 1 OD
      \<lbrace>\<acute>S = a * b\<rbrace>"
  by hoare auto

subsection \<open>Summing natural numbers\<close>

text \<open>We verify an imperative program to sum natural numbers up to a
  given limit.  First some functional definition for proper
  specification of the problem.\<close>

text \<open>The following proof is quite explicit in the individual steps
  taken, with the \name{hoare} method only applied locally to take
  care of assignment and sequential composition.  Note that we express
  intermediate proof obligation in pure logic, without referring to
  the state space.\<close>

theorem
  "\<turnstile> \<lbrace>True\<rbrace>
      \<acute>S := 0; \<acute>I := 1;
      WHILE \<acute>I \<noteq> n
      DO
        \<acute>S := \<acute>S + \<acute>I;
        \<acute>I := \<acute>I + 1
      OD
      \<lbrace>\<acute>S = (\<Sum>j<n. j)\<rbrace>"
  (is "\<turnstile> _ (_; ?while) _")
proof -
  let ?sum = "\<lambda>k::nat. \<Sum>j<k. j"
  let ?inv = "\<lambda>s i::nat. s = ?sum i"

  have "\<turnstile> \<lbrace>True\<rbrace> \<acute>S := 0; \<acute>I := 1 \<lbrace>?inv \<acute>S \<acute>I\<rbrace>"
  proof -
    have "True \<longrightarrow> 0 = ?sum 1"
      by simp
    also have "\<turnstile> \<lbrace>\<dots>\<rbrace> \<acute>S := 0; \<acute>I := 1 \<lbrace>?inv \<acute>S \<acute>I\<rbrace>"
      by hoare
    finally show ?thesis .
  qed
  also have "\<turnstile> \<dots> ?while \<lbrace>?inv \<acute>S \<acute>I \<and> \<not> \<acute>I \<noteq> n\<rbrace>"
  proof
    let ?body = "\<acute>S := \<acute>S + \<acute>I; \<acute>I := \<acute>I + 1"
    have "\<And>s i. ?inv s i \<and> i \<noteq> n \<longrightarrow> ?inv (s + i) (i + 1)"
      by simp
    also have "\<turnstile> \<lbrace>\<acute>S + \<acute>I = ?sum (\<acute>I + 1)\<rbrace> ?body \<lbrace>?inv \<acute>S \<acute>I\<rbrace>"
      by hoare
    finally show "\<turnstile> \<lbrace>?inv \<acute>S \<acute>I \<and> \<acute>I \<noteq> n\<rbrace> ?body \<lbrace>?inv \<acute>S \<acute>I\<rbrace>" .
  qed
  also have "\<And>s i. s = ?sum i \<and> \<not> i \<noteq> n \<longrightarrow> s = ?sum n"
    by simp
  finally show ?thesis .
qed

text \<open>The next version uses the @{text hoare} method, while still
  explaining the resulting proof obligations in an abstract,
  structured manner.\<close>

theorem
  "\<turnstile> \<lbrace>True\<rbrace>
      \<acute>S := 0; \<acute>I := 1;
      WHILE \<acute>I \<noteq> n
      INV \<lbrace>\<acute>S = (\<Sum>j<\<acute>I. j)\<rbrace>
      DO
        \<acute>S := \<acute>S + \<acute>I;
        \<acute>I := \<acute>I + 1
      OD
      \<lbrace>\<acute>S = (\<Sum>j<n. j)\<rbrace>"
proof -
  let ?sum = "\<lambda>k::nat. \<Sum>j<k. j"
  let ?inv = "\<lambda>s i::nat. s = ?sum i"

  show ?thesis
  proof hoare
    show "?inv 0 1" by simp
  next
    fix s i
    assume "?inv s i \<and> i \<noteq> n"
    then show "?inv (s + i) (i + 1)" by simp
  next
    fix s i
    assume "?inv s i \<and> \<not> i \<noteq> n"
    then show "s = ?sum n" by simp
  qed
qed

text \<open>Certainly, this proof may be done fully automatic as well,
  provided that the invariant is given beforehand.\<close>

theorem
  "\<turnstile> \<lbrace>True\<rbrace>
      \<acute>S := 0; \<acute>I := 1;
      WHILE \<acute>I \<noteq> n
      INV \<lbrace>\<acute>S = (\<Sum>j<\<acute>I. j)\<rbrace>
      DO
        \<acute>S := \<acute>S + \<acute>I;
        \<acute>I := \<acute>I + 1
      OD
      \<lbrace>\<acute>S = (\<Sum>j<n. j)\<rbrace>"
  by hoare auto

subsection \<open>Time\<close>

text \<open>A simple embedding of time in Hoare logic: function @{text
  timeit} inserts an extra variable to keep track of the elapsed time.\<close>

record tstate = time :: nat

type_synonym 'a time = "\<lparr>time :: nat, \<dots> :: 'a\<rparr>"

primrec timeit :: "'a time com \<Rightarrow> 'a time com"
where
  "timeit (Basic f) = (Basic f; Basic(\<lambda>s. s\<lparr>time := Suc (time s)\<rparr>))"
| "timeit (c1; c2) = (timeit c1; timeit c2)"
| "timeit (Cond b c1 c2) = Cond b (timeit c1) (timeit c2)"
| "timeit (While b iv c) = While b iv (timeit c)"

record tvars = tstate +
  I :: nat
  J :: nat

lemma lem: "(0::nat) < n \<Longrightarrow> n + n \<le> Suc (n * n)"
  by (induct n) simp_all

lemma
  "\<turnstile> \<lbrace>i = \<acute>I \<and> \<acute>time = 0\<rbrace>
    (timeit
      (WHILE \<acute>I \<noteq> 0
        INV \<lbrace>2 *\<acute> time + \<acute>I * \<acute>I + 5 * \<acute>I = i * i + 5 * i\<rbrace>
        DO
          \<acute>J := \<acute>I;
          WHILE \<acute>J \<noteq> 0
          INV \<lbrace>0 < \<acute>I \<and> 2 * \<acute>time + \<acute>I * \<acute>I + 3 * \<acute>I + 2 * \<acute>J - 2 = i * i + 5 * i\<rbrace>
          DO \<acute>J := \<acute>J - 1 OD;
          \<acute>I := \<acute>I - 1
        OD))
    \<lbrace>2 * \<acute>time = i * i + 5 * i\<rbrace>"
  apply simp
  apply hoare
      apply simp
     apply clarsimp
    apply clarsimp
   apply arith
   prefer 2
   apply clarsimp
  apply (clarsimp simp: nat_distrib)
  apply (frule lem)
  apply arith
  done

end