(*
  File:     Mason_Stothers.thy
  Author:   Manuel Eberl, TU München

  A simple proof of the Mason--Stothers theorem, the analogue of the abc conjecture
  for polynomials.
*)
section \<open>The Mason--Stother's Theorem\<close>
theory Mason_Stothers
imports
  "HOL-Computational_Algebra.Computational_Algebra"
  "HOL-Computational_Algebra.Polynomial_Factorial"
begin

subsection \<open>Auxiliary material\<close>

(* TODO Rename this to fps_radical or whatever *)
hide_const (open) Formal_Power_Series.radical

lemma degree_div:
  assumes "a dvd b"
  shows   "degree (b div a) = degree b - degree a"
  using assms by (cases "a = 0"; cases "b = 0") (auto elim!: dvdE simp: degree_mult_eq)

lemma degree_pderiv_le:
  shows   "degree (pderiv p) \<le> degree p - 1"
  by (rule degree_le, cases "degree p = 0") (auto simp: coeff_pderiv coeff_eq_0)

lemma degree_pderiv_less:
  assumes "pderiv p \<noteq> 0"
  shows   "degree (pderiv p) < degree p"
proof -
  have "degree (pderiv p) \<le> degree p - 1"
    by (rule degree_pderiv_le)
  also have "degree p \<noteq> 0"
    using assms by (auto intro!: Nat.gr0I elim!: degree_eq_zeroE)
  hence "degree p - 1 < degree p" by simp
  finally show ?thesis .
qed

lemma pderiv_eq_0:
  assumes "degree p = 0"
  shows   "pderiv p = 0"
  using assms by (auto elim!: degree_eq_zeroE)

subsection \<open>Definition of a radical\<close>

text \<open>
  The following definition of a radical is generic for any factorial semiring.
\<close>

context factorial_semiring
begin

definition radical :: "'a \<Rightarrow> 'a" where
  "radical x = (if x = 0 then 0 else \<Prod>(prime_factors x))"

lemma radical_0 [simp]: "radical 0 = 0"
  by (simp add: radical_def)

lemma radical_nonzero: "x \<noteq> 0 \<Longrightarrow> radical x = \<Prod>(prime_factors x)"
  by (simp add: radical_def)

lemma radical_eq_0_iff [simp]: "radical x = 0 \<longleftrightarrow> x = 0"
  by (auto simp: radical_def)

lemma prime_factorization_radical [simp]:
  assumes "x \<noteq> 0"
  shows   "prime_factorization (radical x) = mset_set (prime_factors x)"
proof -
  have "prime_factorization (radical x) = (\<Sum>p\<in>prime_factors x. prime_factorization p)"
    unfolding radical_def using assms by (auto intro!: prime_factorization_prod)
  also have "\<dots> = (\<Sum>p\<in>prime_factors x. {#p#})"
    by (intro Groups_Big.sum.cong) (auto intro!: prime_factorization_prime)
  also have "\<dots> = mset_set (prime_factors x)" by simp
  finally show ?thesis .
qed

lemma prime_factors_radical [simp]: "x \<noteq> 0 \<Longrightarrow> prime_factors (radical x) = prime_factors x"
  by simp

lemma radical_dvd [simp, intro]: "radical x dvd x"
  by (cases "x = 0") (force intro: prime_factorization_subset_imp_dvd mset_set_set_mset_msubset)+

lemma multiplicity_radical_prime:
  assumes "prime p" "x \<noteq> 0"
  shows   "multiplicity p (radical x) = (if p dvd x then 1 else 0)"
proof -
  have "multiplicity p (radical x) = (\<Sum>q\<in>prime_factors x. multiplicity p q)"
    using assms unfolding radical_def
    by (auto simp: prime_elem_multiplicity_prod_distrib)
  also have "\<dots> = (\<Sum>q\<in>prime_factors x. if p = q then 1 else 0)"
    using assms by (intro Groups_Big.sum.cong) (auto intro!: prime_multiplicity_other)
  also have "\<dots> = (if p \<in> prime_factors x then 1 else 0)" by simp
  also have "\<dots> = (if p dvd x then 1 else 0)"
    using assms by (auto simp: prime_factors_dvd)
  finally show ?thesis .
qed

lemma radical_1 [simp]: "radical 1 = 1"
  by (simp add: radical_def)

lemma radical_unit [simp]: "is_unit x \<Longrightarrow> radical x = 1"
  by (auto simp: radical_def prime_factorization_unit)

lemma prime_factors_power:
  assumes "n > 0"
  shows   "prime_factors (x ^ n) = prime_factors x"
  using assms by (cases "x = 0") (auto simp: prime_factors_dvd zero_power prime_dvd_power_iff)

lemma radical_power [simp]: "n > 0 \<Longrightarrow> radical (x ^ n) = radical x"
  by (auto simp add: radical_def prime_factors_power)

end

context factorial_semiring_gcd
begin

lemma radical_mult_coprime:
  assumes "coprime a b"
  shows   "radical (a * b) = radical a * radical b"
proof (cases "a = 0 \<or> b = 0")
  case False
  with assms have "prime_factors a \<inter> prime_factors b = {}"
    using not_prime_unit coprime_common_divisor by (auto simp: prime_factors_dvd)
  hence "\<Prod>(prime_factors a \<union> prime_factors b) = \<Prod>(prime_factors a) * \<Prod>(prime_factors b)"
    by (intro prod.union_disjoint) auto
  with False show ?thesis by (simp add: radical_def prime_factorization_mult)
qed auto

lemma multiplicity_le_imp_dvd':
  assumes "x \<noteq> 0" "\<And>p. p \<in> prime_factors x \<Longrightarrow> multiplicity p x \<le> multiplicity p y"
  shows   "x dvd y"
proof (rule multiplicity_le_imp_dvd)
  fix p assume "prime p"
  thus "multiplicity p x \<le> multiplicity p y" using assms(1) assms(2)[of p]
    by (cases "p dvd x") (auto simp: prime_factors_dvd not_dvd_imp_multiplicity_0)
qed fact+

end

subsection \<open>Main result\<close>

text \<open>
  The following proofs are basically a one-to-one translation of Franz Lemmermeyer's
  presentation~\cite{lemmermeyer05} of Snyder's proof of the Mason--Stothers theorem.
\<close>
lemma prime_power_dvd_pderiv:
  fixes f p :: "'a :: field_gcd poly"
  assumes "prime_elem p"
  defines "n \<equiv> multiplicity p f - 1"
  shows   "p ^ n dvd pderiv f"
proof (cases "p dvd f \<and> f \<noteq> 0")
  case True
  hence "multiplicity p f > 0" using assms
    by (subst prime_multiplicity_gt_zero_iff) auto
  hence Suc_n: "Suc n = multiplicity p f" by (simp add: n_def)
  define g where "g = f div p ^ Suc n"
  have "p ^ Suc n dvd f" unfolding Suc_n by (rule multiplicity_dvd)
  hence f_eq: "f = p ^ Suc n * g" by (simp add: g_def)
  also have "pderiv \<dots> = p ^ n * (smult (of_nat (Suc n)) (pderiv p * g) + p * pderiv g)"
    by (simp only: pderiv_mult pderiv_power_Suc) (simp add: algebra_simps)
  also have "p ^ n dvd \<dots>" by simp
  finally show ?thesis .
qed (auto simp: n_def not_dvd_imp_multiplicity_0)

lemma poly_div_radical_dvd_pderiv:
  fixes p :: "'a :: field_gcd poly"
  shows "p div radical p dvd pderiv p"
proof (cases "pderiv p = 0")
  case False
  hence "p \<noteq> 0" by auto
  show ?thesis
  proof (rule multiplicity_le_imp_dvd')
    fix q :: "'a poly" assume q: "q \<in> prime_factors (p div radical p)"
    hence "q dvd p div radical p" by auto
    also from \<open>p \<noteq> 0\<close> have "\<dots> dvd p" by (subst div_dvd_iff_mult) auto
    finally have "q dvd p" .

    have "p = p div radical p * radical p" by simp
    also from q and \<open>p \<noteq> 0\<close> have "multiplicity q \<dots> = Suc (multiplicity q (p div radical p))"
      by (subst prime_elem_multiplicity_mult_distrib)
         (auto simp: dvd_div_eq_0_iff multiplicity_radical_prime \<open>q dvd p\<close> prime_factors_dvd)
    finally have "multiplicity q (p div radical p) \<le> multiplicity q p - 1" by simp
    also have "\<dots> \<le> multiplicity q (pderiv p)" using \<open>pderiv p \<noteq> 0\<close> and q and \<open>p \<noteq> 0\<close>
      by (intro multiplicity_geI prime_power_dvd_pderiv)
         (auto simp: prime_factors_dvd dvd_div_eq_0_iff)
    finally show "multiplicity q (p div radical p) \<le> multiplicity q (pderiv p)" .
  qed (insert \<open>p \<noteq> 0\<close>, auto simp: dvd_div_eq_0_iff)
qed auto

lemma degree_pderiv_mult_less:
  assumes "pderiv C \<noteq> 0"
  shows   "degree (pderiv C * B) < degree B + degree C"
proof -
  have "degree (pderiv C * B) \<le> degree (pderiv C) + degree B"
    by (rule degree_mult_le)
  also from assms have "degree (pderiv C) < degree C" by (rule degree_pderiv_less)
  finally show ?thesis by simp
qed

lemma Mason_Stothers_aux:
  fixes A B C :: "'a :: field_gcd poly"
  assumes nz: "A \<noteq> 0" "B \<noteq> 0" "C \<noteq> 0" and sum: "A + B + C = 0" and coprime: "Gcd {A, B, C} = 1"
     and deg_ge: "degree A \<ge> degree (radical (A * B * C))"
   shows "pderiv A = 0" "pderiv B = 0" "pderiv C = 0"
proof -
  have C_eq: "C = -A - B" "-C = A + B" using sum by algebra+
  from coprime have "gcd A (gcd B (-C)) = 1" by simp
  also note C_eq(2)
  finally have "coprime A B" by (simp add: gcd.commute add.commute[of A B] coprime_iff_gcd_eq_1)
  hence "coprime A (-C)" "coprime B (-C)"
    unfolding C_eq by (simp_all add: gcd.commute[of B A] gcd.commute[of B "A + B"]
                                     add.commute coprime_iff_gcd_eq_1)
  hence "coprime A C" "coprime B C" by simp_all
  note coprime = coprime \<open>coprime A B\<close> this
  have coprime1: "coprime (A div radical A) (B div radical B)"
    by (rule coprime_divisors[OF _ _ \<open>coprime A B\<close>]) (insert nz, auto simp: div_dvd_iff_mult)
  have coprime2: "coprime (A div radical A) (C div radical C)"
    by (rule coprime_divisors[OF _ _ \<open>coprime A C\<close>]) (insert nz, auto simp: div_dvd_iff_mult)
  have coprime3: "coprime (B div radical B) (C div radical C)"
    by (rule coprime_divisors[OF _ _ \<open>coprime B C\<close>]) (insert nz, auto simp: div_dvd_iff_mult)
  have coprime4: "coprime (A div radical A * (B div radical B)) (C div radical C)"
    using coprime2 coprime3 by (subst coprime_mult_left_iff) auto

  have eq: "A * pderiv B - pderiv A * B = pderiv C * B - C * pderiv B"
    by (simp add: C_eq pderiv_add pderiv_diff pderiv_minus algebra_simps)

  have "A div radical A dvd (A * pderiv B - pderiv A * B)"
    using nz by (intro dvd_diff dvd_mult2 poly_div_radical_dvd_pderiv) (auto simp: div_dvd_iff_mult)
  with eq have "A div radical A dvd (pderiv C * B - C * pderiv B)" by simp
  moreover have "C div radical C dvd (pderiv C * B - C * pderiv B)"
    using nz by (intro dvd_diff dvd_mult2 poly_div_radical_dvd_pderiv) (auto simp: div_dvd_iff_mult)
  moreover have "B div radical B dvd (pderiv C * B - C * pderiv B)"
    using nz by (intro dvd_diff dvd_mult poly_div_radical_dvd_pderiv) (auto simp: div_dvd_iff_mult)
  ultimately have "(A div radical A) * (B div radical B) * (C div radical C) dvd
                     (pderiv C * B - C * pderiv B)" using coprime coprime1 coprime4
    by (intro divides_mult) auto
  also have "(A div radical A) * (B div radical B) * (C div radical C) =
               (A * B * C) div (radical A * radical B * radical C)"
    by (simp add: div_mult_div_if_dvd mult_dvd_mono)
  also have "radical A * radical B * radical C = radical (A * B) * radical C"
    using coprime by (subst radical_mult_coprime) auto
  also have "\<dots> = radical (A * B * C)"
    using coprime by (subst radical_mult_coprime [symmetric]) auto
  finally have dvd: "((A * B * C) div radical (A * B * C)) dvd (pderiv C * B - C * pderiv B)" .

  have "pderiv B = 0 \<and> pderiv C = 0"
  proof (rule ccontr)
    assume "\<not>(pderiv B = 0 \<and> pderiv C = 0)"
    hence *: "pderiv B \<noteq> 0 \<or> pderiv C \<noteq> 0" by blast

    have "degree (pderiv C * B - C * pderiv B) \<le>
            max (degree (pderiv C * B)) (degree (C * pderiv B))" by (rule degree_diff_le_max)
    also have "\<dots> < degree B + degree C"
      using degree_pderiv_mult_less[of B C] degree_pderiv_mult_less[of C B] *
      by (cases "pderiv B = 0"; cases "pderiv C = 0") (auto simp add: algebra_simps)
    also have "degree B + degree C = degree (B * C)"
      using nz by (subst degree_mult_eq) auto
    also have "\<dots> = degree (A * (B * C)) - degree A"
      using nz by (subst (2) degree_mult_eq) auto
    also have "\<dots> \<le> degree (A * B * C) - degree (radical (A * B * C))" unfolding mult.assoc
      using assms by (intro diff_le_mono2) (auto simp: mult_ac)
    also have "\<dots> = degree ((A * B * C) div radical (A * B * C))"
      by (intro degree_div [symmetric]) auto
    finally have less: "degree (pderiv C * B - C * pderiv B) <
                          degree (A * B * C div radical (A * B * C))" by simp

    have eq': "pderiv C * B - C * pderiv B = 0"
    proof (rule ccontr)
      assume "pderiv C * B - C * pderiv B \<noteq> 0"
      hence "degree (A * B * C div radical (A * B * C)) \<le> degree (pderiv C * B - C * pderiv B)"
        using dvd by (intro dvd_imp_degree_le) auto
      with less show False by linarith
    qed
    from * show False
    proof (elim disjE)
      assume [simp]: "pderiv C \<noteq> 0"
      have "C dvd C * pderiv B" by simp
      also from eq' have "\<dots> = pderiv C * B" by simp
      finally have "C dvd pderiv C" using coprime
        by (subst (asm) coprime_dvd_mult_left_iff) (auto simp: coprime_commute)
      hence "degree C \<le> degree (pderiv C)" by (intro dvd_imp_degree_le) auto
      moreover have "degree (pderiv C) < degree C" by (intro degree_pderiv_less) auto
      ultimately show False by simp
    next
      assume [simp]: "pderiv B \<noteq> 0"
      have "B dvd B * pderiv C" by simp
      also from eq' have "\<dots> = pderiv B * C" by (simp add: mult_ac)
      finally have "B dvd pderiv B" using coprime
        by (subst (asm) coprime_dvd_mult_left_iff) auto
      hence "degree B \<le> degree (pderiv B)" by (intro dvd_imp_degree_le) auto
      moreover have "degree (pderiv B) < degree B" by (intro degree_pderiv_less) auto
      ultimately show False by simp
    qed
  qed
  with eq and nz show "pderiv A = 0" "pderiv B = 0" "pderiv C = 0" by auto
qed

theorem Mason_Stothers:
  fixes A B C :: "'a :: field_gcd poly"
  assumes nz: "A \<noteq> 0" "B \<noteq> 0" "C \<noteq> 0" "\<exists>p\<in>{A,B,C}. pderiv p \<noteq> 0"
      and sum: "A + B + C = 0" and coprime: "Gcd {A, B, C} = 1"
    shows "Max {degree A, degree B, degree C} < degree (radical (A * B * C))"
proof -
  have "degree A < degree (radical (A * B * C))"
    if "\<forall>p\<in>{A,B,C}. p \<noteq> 0" "\<exists>p\<in>{A,B,C}. pderiv p \<noteq> 0" "sum_mset {#A,B,C#} = 0" "Gcd {A, B, C} = 1"
    for A B C :: "'a poly"
  proof (rule ccontr)
    assume "\<not>(degree A < degree (radical (A * B * C)))"
    hence "degree A \<ge> degree (radical (A * B * C))" by simp
    with Mason_Stothers_aux[of A B C] that show False by (auto simp: add_ac)
  qed
  from this[of A B C] this[of B C A] this[of C A B] assms show ?thesis
    by (simp only: insert_commute mult_ac add_ac) (auto simp: add_ac mult_ac)
qed

text \<open>
  The result can be simplified a bit more in fields of characteristic 0:
\<close>
corollary Mason_Stothers_char_0:
  fixes A B C :: "'a :: {field_gcd, field_char_0} poly"
  assumes nz: "A \<noteq> 0" "B \<noteq> 0" "C \<noteq> 0" and deg: "\<exists>p\<in>{A,B,C}. degree p \<noteq> 0"
      and sum: "A + B + C = 0" and coprime: "Gcd {A, B, C} = 1"
    shows "Max {degree A, degree B, degree C} < degree (radical (A * B * C))"
proof -
  from deg have "\<exists>p\<in>{A,B,C}. pderiv p \<noteq> 0"
    by (auto simp: pderiv_eq_0_iff)
  from Mason_Stothers[OF assms(1-3) this assms(5-)] show ?thesis .
qed

text \<open>
  As a nice corollary, we get a kind of analogue of Fermat's last theorem for polynomials:
  Given non-zero polynomials $A$, $B$, $C$ with $A ^ n + B ^ n + C ^ n = 0$ on lowest terms,
  we must either have $n \leq 2$ or $(A ^ n)' = (B ^ n)' = (C ^ n)' = 0$.

  In the case of a field with characteristic 0, this last possibility is equivalent to
  $A$, $B$, and $C$ all being constant.
\<close>
corollary fermat_poly:
  fixes A B C :: "'a :: field_gcd poly"
  assumes sum: "A ^ n + B ^ n + C ^ n = 0" and cop: "Gcd {A, B, C} = 1"
  assumes nz:  "A \<noteq> 0" "B \<noteq> 0" "C \<noteq> 0"    and deg: "\<exists>p\<in>{A,B,C}. pderiv (p ^ n) \<noteq> 0"
  shows "n \<le> 2"
proof (rule ccontr)
  assume "\<not>(n \<le> 2)"
  hence "n > 2" by simp
  have "Max {degree (A ^ n), degree (B ^ n), degree (C ^ n)} <
          degree (radical (A ^ n * B ^ n * C ^ n))" (is "_ < ?d")
    using assms by (intro Mason_Stothers) (auto simp: degree_power_eq gcd_exp)
  hence "Max {degree (A ^ n), degree (B ^ n), degree (C ^ n)} + 1 \<le> ?d" by linarith
  hence "n * degree A + 1 \<le> ?d" "n * degree B + 1 \<le> ?d" "n * degree C + 1 \<le> ?d"
    using assms by (simp_all add: degree_power_eq)
  hence "n * (degree A + degree B + degree C) + 3 \<le> 3 * ?d"
    unfolding ring_distribs by linarith
  also have "A ^ n * B ^ n * C ^ n = (A * B * C) ^ n" by (simp add: mult_ac power_mult_distrib)
  also have "radical \<dots> = radical (A * B * C)"
    using \<open>n > 2\<close> by simp
  also have "degree (radical (A * B * C)) \<le> degree (A * B * C)"
    using nz by (intro dvd_imp_degree_le) auto
  also have "\<dots> = degree A + degree B + degree C"
    using nz by (simp add: degree_mult_eq)
  finally have "(3 - n) * (degree A + degree B + degree C) \<ge> 3"
    by (simp add: algebra_simps)
  hence "3 - n \<noteq> 0" by (intro notI) auto
  hence "n < 3" by simp
  with \<open>n > 2\<close> show False by simp
qed

corollary fermat_poly_char_0:
  fixes A B C :: "'a :: {field_gcd,field_char_0} poly"
  assumes sum: "A ^ n + B ^ n + C ^ n = 0" and cop: "Gcd {A, B, C} = 1"
  assumes nz:  "A \<noteq> 0" "B \<noteq> 0" "C \<noteq> 0"    and deg: "\<exists>p\<in>{A,B,C}. degree p > 0"
  shows "n \<le> 2"
proof (rule ccontr)
  assume *: "\<not>(n \<le> 2)"
  with nz and deg have "\<exists>p\<in>{A,B,C}. pderiv (p ^ n) \<noteq> 0"
    by (auto simp: pderiv_eq_0_iff degree_power_eq)
  from fermat_poly[OF assms(1-5) this] and * show False by simp
qed

end


theory Chap1_DataStructure_BooleanAlgebra
  imports
    Main
    "Deriving/Comparator_Generator/Compare_Order_Instances"
begin

section "4 element term algebra"

datatype s =
    S1 | S2
    | Meet s s (infixr "\<^bold>\<inter>" 55)
    | Join s s (infixr "\<^bold>\<union>" 55)
    | Nega s ("\<^bold>\<not> _" 55)
    | Zero ("\<^bold>0")
    | One ("\<^bold>1")

thm "s.induct"
thm "s.rec"
(* derive lexicographic ordering for datatype definition by given package *)
derive compare_order s
thm add_ac

section "suggestion:
powerset representation as boolean algebra interpretation
(sometime also called 'the shallow embedding method'),
maybe  as a Functor formalizable ..."

datatype c = C1 | C2

fun translate :: "s \<Rightarrow> (c \<Rightarrow> bool)" where
"translate S1 = (\<lambda> c. c = C1)" |
"translate S2 = (\<lambda> c. c = C2)" |
"translate (Meet s1 s2) = (\<lambda> c. (translate s1) c \<and> (translate s2) c)" |
"translate (Join s1 s2) = (\<lambda> c. (translate s1) c \<or> (translate s2) c)" |
"translate (Nega x) = (\<lambda> c. \<not> (translate x) c)" |
"translate Zero = (\<lambda> _. False)" |
"translate One = (\<lambda> _. True)"

section "Boolsche Algebra Conditions"
(*
definition "comm Op \<equiv> \<forall> a b. Op a b = Op b a"
definition "asso Op \<equiv> \<forall> a b c. Op (Op a b) c = Op a (Op b c)"
definition "idem Op \<equiv> \<forall> a. Op a a = a"
definition "dist Op1 Op2 \<equiv> \<forall> a b c. Op1 a (Op2 b c) = Op2 (Op1 a b) (Op1 a c)"
definition "neutr Op Unit \<equiv> \<forall> a. Op a Unit = a"
definition "extr Op Unit \<equiv> \<forall> a. Op a Unit = a"
definition "invol Op \<equiv> \<forall> a. Op (Op a) = a"
definition "deMorg Neg Op1 Op2 \<equiv> \<forall> a b. Neg (Op1 a b) = Op2 (Neg a) (Neg b)"
definition "compl Op Neg Unit \<equiv> \<forall> a. Op a (Neg a) = Unit"
definition "duali Neg Unit1 Unit2 \<equiv> (Neg Unit1) = Unit2"
definition "absorb Op1 Op2 \<equiv> \<forall> a b. Op1 a (Op2 a b) = a"
*)

definition "comm Op a b \<equiv> Op a b = Op b a"
definition "asso Op a b c \<equiv> Op (Op a b) c = Op a (Op b c)"
definition "idem Op a \<equiv> Op a a = a"
definition "dist Op1 Op2 a b c \<equiv> Op1 a (Op2 b c) = Op2 (Op1 a b) (Op1 a c)"
definition "neutr Op Unit a \<equiv> Op a Unit = a"
definition "extr Op Unit a \<equiv> Op a Unit = a"
definition "invol Op a \<equiv> Op (Op a) = a"
definition "deMorg Neg Op1 Op2 a b \<equiv> Neg (Op1 a b) = Op2 (Neg a) (Neg b)"
definition "compl Op Neg Unit a \<equiv> Op a (Neg a) = Unit"
definition "duali Neg Unit1 Unit2 \<equiv> (Neg Unit1) = Unit2"
definition "absorb Op1 Op2 a b \<equiv> Op1 a (Op2 a b) = a"

(* dualizable rules also explicit ? *)

definition isBoolAlg ::
"('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
"isBoolAlg M_Op J_Op N_Op Z_Op O_Op a b c\<equiv>
comm M_Op a b \<and> asso M_Op a b c \<and> idem M_Op a \<and> dist M_Op J_Op a b c \<and>
neutr M_Op O_Op a \<and> extr J_Op Z_Op a \<and> invol N_Op a \<and>
deMorg N_Op M_Op J_Op a b \<and> compl M_Op N_Op Z_Op a \<and>
duali N_Op O_Op Z_Op \<and> absorb M_Op J_Op a b"

subsection "encoding with a definition and the refl/sym/trans-closuse"

type_synonym 's rel = "'s \<Rightarrow> 's \<Rightarrow> bool"

inductive boolALG :: "s rel" where
commu: "\<And> a b. boolALG (Meet a b) (Meet b a)" |
assoc: "\<And> a b c. boolALG (Meet (Meet a b) c) (Meet a (Meet b c))" |
idem: "\<And> a. boolALG (Meet a a) a" |
distr: "\<And> a b c. boolALG (Meet a (Join b c)) (Join (Meet a b) (Meet a c))" |
neutr: "\<And> a. boolALG (Meet a One) a" |
extr: "\<And> a. boolALG (Join a Zero) a" |
invol: "\<And> a. boolALG (Nega (Nega a)) a" |
deMorg: "\<And> a. boolALG (Nega (Meet a b)) (Join (Nega a) (Nega b))" |
compl: "\<And> a. boolALG (Meet a (Nega a)) Zero" |
duali: "boolALG (Nega One) Zero" |
absorb: "\<And> a b. boolALG (Meet a (Join a b)) b" |
congJ: "\<And> s1 s2 s3 s4. boolALG s1 s2 \<and> boolALG s3 s4
      \<Longrightarrow> boolALG (Join s1 s3) (Join s2 s4)"  |
congM: "\<And> s1 s2 s3 s4. boolALG s1 s2 \<and> boolALG s3 s4
      \<Longrightarrow> boolALG (Meet s1 s3) (Meet s2 s4)"

(* possibly miss the dual rules *)

inductive equivRel :: "'s rel \<Rightarrow> 's rel"
  for R :: "'s rel" where
intro: "\<And> s1 s2. R s1 s2 \<Longrightarrow> equivRel R s1 s2" |
refl: "\<And> s1. equivRel R s1 s1" |
symm: "\<And> s1 s2. equivRel R s1 s2 \<Longrightarrow> equivRel R s2 s1" |
trans: "\<And> s1 s2 s3. \<lbrakk> equivRel R s1 s2
                    ; equivRel R s2 s3 \<rbrakk>
                    \<Longrightarrow> equivRel R s1 s3"

subsection "referencing one equivalence class"

definition classRef :: "'s rel \<Rightarrow> 's \<Rightarrow> ('s \<Rightarrow> bool)" where
"classRef laws Representative \<equiv>
 \<lambda>x. equivRel laws Representative x"

(* gives me the canonical element *)
definition canonElem :: "'s rel \<Rightarrow> 's \<Rightarrow> 's" where
"canonElem R x \<equiv> SOME y. equivRel R x y "
definition isCanonElem :: "'s rel \<Rightarrow> 's \<Rightarrow> bool" where
"isCanonElem R x \<equiv> canonElem R x = x"

(* collection of the canonical elements represents equivalent-classes*)
definition "equiClasses \<equiv> canonElem"

subsection "referencing minimal element of equivalence class"

definition minimalClassElem :: "s rel \<Rightarrow> s rel" where
"minimalClassElem R x min_elem \<equiv>
classRef R x min_elem \<and> ( \<forall> e. classRef R x e \<longrightarrow> min_elem \<le> e )"

subsection "proofing BoolAlg laws"

lemma isBoolAlgLemma:
  shows "\<forall> a b c .
(isCanonElem boolALG a \<and> isCanonElem boolALG b \<and> isCanonElem boolALG c)
\<longrightarrow> isBoolAlg Meet Join Nega Zero One a b c"
  oops

(* ...tbc... *)

section "Filter, Ultrafilter"

(* how to state this in term algebra *)

section "OPTION 4: (maybe) encode as inductive predicate without 'datatype' command"

(* is this immitating the "datatype" construction from above ? *)
(* or is it even "purer" or preferrable as seen in the other options ? *)

typedecl a
type_synonym point_set = "nat \<Rightarrow> bool"
type_synonym var_set = "nat \<Rightarrow> bool"

consts a_point :: "nat \<Rightarrow> a" ("\<llangle>_\<rrangle>\<^sub>a" 55)
consts a_var :: "nat \<Rightarrow> a" ("\<guillemotleft>_\<guillemotright>\<^sub>a" 55)
consts a_meet :: "a \<Rightarrow> a \<Rightarrow> a" (infixr" \<^bold>\<inter>\<^sub>a " 55)
consts a_join :: "a \<Rightarrow> a \<Rightarrow> a" (infixr "\<^bold>\<union>\<^sub>a" 55)
consts a_prod :: "a \<Rightarrow> a \<Rightarrow> a" (infixr "\<^bold>\<cdot>\<^sub>a" 55)
consts a_impl :: "a \<Rightarrow> a \<Rightarrow> a" (infixr "\<^bold>\<rightarrow>\<^sub>a" 55)
consts a_zero :: a ("\<^bold>0\<^sub>a")
consts a_one :: "a" ("\<^bold>1\<^sub>a")
consts a_bot :: a ("\<^bold>\<bottom>\<^sub>a")
consts a_top :: a ("\<^bold>\<top>\<^sub>a")

inductive carrierALG :: "point_set \<Rightarrow> var_set \<Rightarrow> (a \<Rightarrow> bool)"
  for p_set :: point_set
  and v_set :: var_set
where
points: "\<And> p. p_set p \<Longrightarrow> carrierALG p_set v_set (\<llangle>p\<rrangle>\<^sub>a)" |
vars: "\<And> p. v_set p \<Longrightarrow> carrierALG p_set v_set (\<guillemotleft>p\<guillemotright>\<^sub>a)" |
meet: "\<And> s1 s2. carrierALG p_set v_set s1 \<and> carrierALG p_set v_set s2
            \<Longrightarrow> carrierALG p_set v_set (s1 \<^bold>\<inter>\<^sub>a s2)" |
join: "\<And> s1 s2. carrierALG p_set v_set s1 \<and> carrierALG p_set v_set s2
            \<Longrightarrow> carrierALG p_set v_set (s1 \<^bold>\<union>\<^sub>a s2)" |
prod: "\<And> s1 s2. carrierALG p_set v_set s1 \<and> carrierALG p_set v_set s2
            \<Longrightarrow> carrierALG p_set v_set (s1 \<^bold>\<cdot>\<^sub>a s2)" |
impl: "\<And> s1 s2. carrierALG p_set v_set s1 \<and> carrierALG p_set v_set s2
            \<Longrightarrow> carrierALG p_set v_set (s1 \<^bold>\<rightarrow>\<^sub>a s2)" |
zero: "carrierALG p_set v_set \<^bold>0\<^sub>a" |
one: "carrierALG p_set v_set \<^bold>1\<^sub>a" |
bot: "carrierALG p_set v_set \<^bold>\<bottom>\<^sub>a" |
top: "carrierALG p_set v_set \<^bold>\<top>\<^sub>a"

(* precising the differences of these induct rules *)
thm "carrierALG.induct"
thm "carrierALG.cases"
thm "s.induct"

type_synonym alg = "a \<Rightarrow> bool"

inductive carrierEQUIV :: "alg \<Rightarrow> a \<Rightarrow> a \<Rightarrow> bool"
   for ALG :: alg
   where
intro: "\<And> a. ALG a \<Longrightarrow> carrierEQUIV ALG a a" |
symm: "\<And> a1 a2. carrierEQUIV ALG a1 a2 \<Longrightarrow> carrierEQUIV ALG a2 a1" |
trans: "\<And> a1 a2 a3. \<lbrakk> carrierEQUIV ALG a1 a2; carrierEQUIV ALG a2 a3 \<rbrakk> \<Longrightarrow> carrierEQUIV ALG a1 a3" |
assoc: "\<And> a1 a2 a3. carrierEQUIV ALG (a1 \<^bold>\<cdot>\<^sub>a (a2 \<^bold>\<cdot>\<^sub>a a3)) ((a1 \<^bold>\<cdot>\<^sub>a a2) \<^bold>\<cdot>\<^sub>a a3)" |
unitl: "\<And> a. carrierEQUIV ALG (a \<^bold>\<cdot>\<^sub>a \<^bold>1\<^sub>a) a"
 (* ... tbc continued with other rules *)

(* referencing elements/classes would be the same as in OPTION 2*)

section "quotient exercise for Ints from Nats"

definition intRel :: "(nat * nat) => (nat * nat) => bool" where
  "intRel  \<equiv> \<lambda> (x, y) (u, v). (x + v = u + y)"

lemma intRel_iff [simp]: "intRel (x,y) (u,v) \<longleftrightarrow> x + v = u + y"
proof
  show "intRel (x, y) (u, v) \<Longrightarrow> x + v = u + y"
    by (auto simp: intRel_def)
  show "x + v = u + y \<Longrightarrow> intRel (x, y) (u, v)"
    by (auto simp: intRel_def)
qed

quotient_type int = "nat * nat" / "intRel"
  morphisms Rep_Integ Abs_Integ
proof (rule equivpI)
  show "reflp intRel" by (auto simp: reflp_def)
  show "symp intRel" by (auto simp: symp_def)
  show "transp intRel" by (auto simp: transp_def)
qed

find_theorems "Abs_Integ"
find_theorems name: "Int.plus_int*"

lift_definition int_plus:: "int \<Rightarrow> int \<Rightarrow> int"
  is "\<lambda>(a,b)(c,d). (a+c, b+d)"
  apply  clarify
  by simp

lemma plus_comm: "int_plus x y = int_plus y x"
  apply transfer
  apply clarify
  by (simp add: intrel_def)

end


theory ex04self
  imports Main  "~~/src/HOL/Library/Tree"
begin

fun in_range :: "'a::linorder tree \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "in_range Leaf x y = []"
| "in_range (Node l x r) u v =
  (if x > u then in_range l u v else [])
@ (if u \<le> x \<and> x \<le> v then [x] else [])
@ (if v > x then in_range r u v else [])"

lemma "bst t \<Longrightarrow> set (in_range t u v) = {x\<in>set_tree t. u\<le>x \<and> x\<le>v}"
  apply (induction t)
  apply auto
  done

text \<open>Show that your list is actually in-order\<close>
lemma "bst t \<Longrightarrow> in_range t u v = filter (\<lambda>x. u\<le>x \<and> x\<le>v) (inorder t)"
  apply (induction t)
  apply simp
  apply (clarsimp)
  apply safe

end


theory Simulation_Traces imports Main begin

typedecl state
typedecl event
datatype xevent = Tau | Vis event
consts Mi :: "(state * xevent * state)set"

axiomatization
  Ms :: "(state * event * state)set"
where
  detMs: "ALL p e p1 p2. (p, e, p1) : Ms & (p, e, p2) : Ms --> p1=p2"

definition sim :: "(state * state)set => bool"
where
  "sim R =
    (ALL p q. (p, q) : R -->
      (ALL e p'. (p, Vis e, p') : Mi -->
          (EX q'. (q, e, q'): Ms & (p', q') : R))
    & (ALL p'. (p, Tau, p') : Mi --> (p', q) : R))"

inductive_set
  paths :: "('s * 'e * 's)set => 's => ('s * 'e * 's)list set"
  for M :: "('s * 'e * 's)set" and p :: 's
where
  base0 [intro]: "[] : paths M p" |
  base1: "(p, u, q) : M
            ==> [(p, u, q)] : paths M p" |
  step: "[| (q, u, q') : M; cs : paths M p; cs ~= [];
            snd (snd (hd cs)) = q |]
            ==> (q, u, q')#cs : paths M p"

fun path_to_trace_s :: "('s * event * 's)list => event list"
where
  "path_to_trace_s [] = []" |
  "path_to_trace_s ((p, e, q)#cs) = e#(path_to_trace_s cs)"

fun path_to_trace_i :: "('s * xevent * 's)list => event list"
where
  "path_to_trace_i [] = []" |
  "path_to_trace_i ((p, Tau, q)#cs) = path_to_trace_i cs" |
  "path_to_trace_i ((p, Vis e, q)#cs) = e#(path_to_trace_i cs)"

definition traces_s :: "state => event list set"
where
  "traces_s p = path_to_trace_s ` (paths Ms p)"

definition traces_i :: "state => event list set"
where
  "traces_i p = path_to_trace_i` (paths Mi p)"

lemma sim_D:
  "sim R ==>
    (ALL p q. (p, q) : R -->
              (ALL e p'. (p, Vis e, p') : Mi -->
                 (EX q'. (q, e, q'): Ms & (p', q') : R))
            & (ALL p'. (p, Tau, p') : Mi --> (p', q) : R))"
apply(unfold sim_def)
apply(auto)
done

lemma conjD1: "p & q ==> p"
by auto
lemma conjD2: "p & q ==> q"
by auto

lemma sim0:
  "[| (p, Vis e, p') : Mi; sim R; (p, q) : R |]
  ==> EX q'. (q, e, q') : Ms & (p', q') : R"
by (metis sim_D)

lemma sim1 [intro]:
  "[| (p, Vis e, p') : Mi; (q, e, q') : Ms; sim R; (p, q) : R |]
  ==> (p', q') : R"
by (metis detMs sim_D)

lemma sim2 [intro]:
  "[| (p, Tau, p') : Mi; sim R; (p, q) : R |]
  ==> (p', q) : R"
by (metis sim_D)

lemma path_prefix [rule_format]:
  "ps : paths m p ==>
  (ALL us vs. ps = us @ vs --> vs : paths m p)"
apply(erule paths.induct)
apply(auto)
apply(case_tac vs)
apply(clarsimp)
apply (metis paths.base0)
apply(case_tac vs)
apply(clarsimp)
apply (metis (erased, hide_lams) Cons_eq_append_conv Nil_is_append_conv paths.simps)
apply(case_tac cs)
apply(clarsimp)
apply(clarsimp)
apply(case_tac us)
apply(clarsimp)
apply(drule_tac x="[]" in spec)
apply(drule_tac x="(a, aa, b) # list" in spec)
apply(drule mp)
apply(clarsimp)
apply(erule step)
apply(auto)
done

lemma path_prefix1:
  "(p1,u,p2)#ps : paths m p ==> ps : paths m p"
by (metis append.simps(1) append.simps(2) path_prefix)

lemma path1_event [simp]: "[(a, u, b)] : paths m p ==> a=p"
apply(erule paths.cases)
apply(auto)
done

lemma path1_step [simp]: "[(p, u, p')] : paths m p0 ==> (p, u, p') : m"
apply(erule paths.cases)
apply(auto)
done

lemma path2_event:
  "(b', u, c) # (a, w, b) # ps : paths m p ==> b'=b"
apply(erule paths.cases)
apply(auto)
done

lemma path2_step:
  "(p1, u, p2) # ps : paths m p ==> (p1, u, p2) : m"
apply(erule paths.cases)
apply(auto)
done

lemma path_spec_emp [simp, rule_format]:
"qs : paths Ms q ==>
  path_to_trace_s qs = [] --> qs = []"
apply(erule paths.induct)
apply(auto)
done

lemma path_tau [rule_format]: "path_to_trace_i ps = [] -->
  ps : paths Mi p -->
  sim R -->
  (p, q) : R -->
  ps ~= [] -->
  (snd (snd (hd ps)), q) : R"
apply(induct_tac ps)
apply(auto)
apply(case_tac aa)
apply(auto)
apply(case_tac aa)
apply(auto)
apply(drule path_prefix1)
apply(simp)
apply(subgoal_tac "a=p")
apply(drule path2_step)
apply (metis list.distinct(1) path_to_trace_i.simps(3) sim_D xevent.exhaust)
apply (metis path1_event)
apply(case_tac aa)
apply(auto)
apply(case_tac list)
apply(auto)
apply(subgoal_tac "a=p")
apply(clarsimp)
apply (metis path2_step sim_D)
apply (metis path1_event)
by (metis path2_event path2_step sim_D)

lemma sim_path [rule_format]:
  "ps : paths Mi p -->
  (ALL qs. qs : paths Ms q -->
  sim R -->
  (p, q) : R -->
  path_to_trace_s qs = path_to_trace_i ps -->
  ps ~= [] -->
  qs ~= [] -->
  (snd (snd (hd ps)), snd (snd (hd qs))) : R)"
apply(induct_tac ps)
apply(auto)
apply(drule_tac us="[(a, aa, b)]" and vs="list" in path_prefix)
apply(auto)
apply(case_tac list)
apply(auto)
apply(case_tac aa)
apply(auto)
apply(case_tac qs)
apply(auto)
apply(rule sim1)
apply(auto)
apply(frule path1_event)
apply(drule path1_step)
apply(simp)
apply (metis (full_types) list.distinct(1) path1_event path1_step path_to_trace_i.simps(1) path_to_trace_s.elims)
(**)
apply(case_tac aa)
apply(auto)
apply(drule_tac x="qs" in spec)
apply(auto)
apply (metis path2_event path2_step sim_D)
apply(case_tac qs)
apply(auto)
apply(drule_tac x="list" in spec)
apply(auto)
apply(drule_tac vs="list" in path_prefix)
apply(simp)
apply(clarsimp)
apply(case_tac ac)
apply(auto)
apply(frule path1_event)
apply(drule path1_step)
apply(clarsimp)
apply(case_tac lista)
apply(auto)
apply (metis path1_event path2_event path2_step path_prefix1 sim1 sim_D)
apply(case_tac ac)
apply(auto)
apply(subgoal_tac "path_to_trace_i ((ab, Tau, ba) # (aa, Tau, bc) # list) = []")
apply(drule path_tau)
apply(drule path_prefix1)
apply(assumption)
apply(assumption)
apply(assumption)
apply(simp)
apply(clarsimp)
apply(erule contrapos_np)
apply (metis path2_event path2_step sim1)
apply(simp)
apply(case_tac list)
apply(auto)
apply (metis list.distinct(1) list.sel(1) path1_event path2_event path2_step path_prefix1 path_tau sim1 snd_conv)
apply(frule path2_step)
apply(drule path2_event)
apply(clarsimp)
apply(frule path2_step)
apply(drule path2_event)
apply(clarsimp)
by (metis detMs sim_D)

lemma sim_tr0 [rule_format]:
  "ps : paths Mi p ==>
  sim R -->
  (p, q) : R -->
  (EX qs. qs : paths Ms q & path_to_trace_s qs = path_to_trace_i ps)"
apply(erule paths.induct)
apply(auto)
apply(case_tac u)
apply(auto)
apply(drule sim0)
apply(assumption)
apply(assumption)
apply(clarsimp)
apply(rule_tac x="[(q, event, q')]" in exI)
apply(clarsimp)
apply (metis paths.base1)
(**)
apply(case_tac cs)
apply(auto)
apply(case_tac u)
apply(auto)
apply(case_tac qs)              (* to apply sim_path *)
apply(auto)
apply(subgoal_tac "(b, q) : R")
apply(drule sim0)
apply(auto)
apply(rule_tac x="[(q, event, q'a)]" in exI)
apply(clarsimp)
apply (metis paths.base1)
apply (metis list.distinct(1) list.sel(1) path_tau snd_conv)
apply(drule_tac ps="(a, aa, b) # list" and qs="(ab, ac, ba) # lista" in sim_path)
apply(auto)
apply(drule sim0)
apply(auto)
apply(rule_tac x="(ba, event, q'a)#(ab, ac, ba) # lista" in exI)
apply(auto)
by (metis list.distinct(1) list.sel(1) paths.step snd_conv)

lemma sim_tr:
  "[| ps : paths Mi p; sim R; (p, q) : R |]
  ==> EX qs. qs : paths Ms q & path_to_trace_s qs = path_to_trace_i ps"
apply(erule sim_tr0)
apply(auto)
done

theorem "EX R. sim R & (p, q) : R ==> traces_i p <= traces_s q"
apply(unfold traces_s_def traces_i_def)
apply(clarsimp)
apply(drule sim_tr)
apply(auto)
apply(rule_tac x="qs" in rev_image_eqI)
apply(auto)
done

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun count :: "'a => 'a list => int" where
"count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

fun bubble :: "int list => (bool, (int list)) pair" where
"bubble (nil2) = pair2 False (nil2)"
| "bubble (cons2 y (nil2)) = pair2 False (cons2 y (nil2))"
| "bubble (cons2 y (cons2 y2 xs)) =
     (if y <= y2 then
        (case bubble (cons2 y2 xs) of
           pair2 b22 ys22 => pair2 b22 (cons2 y ys22))
        else
        (case bubble (cons2 y xs) of
           pair2 b2 ys2 => pair2 True (cons2 y2 ys2)))"

(*fun did not finish the proof*)
function bubsort :: "int list => int list" where
"bubsort x =
   (case bubble x of pair2 b1 ys => (if b1 then bubsort ys else x))"
  by pat_completeness auto

theorem property0 :
  "((count x (bubsort xs)) = (count x xs))"
  oops

end


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

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

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => Nat list" where
  "toList (Node q y r) = cons2 y (toList (hmerge q r))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "Nat => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "Nat list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "Nat list => Nat list" where
  "hsort2 x = toList (toHeap2 x)"

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

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

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

theorem property0 :
  "isPermutation (hsort2 xs) xs"
  oops

end


section "Solution to Day 5 of AoC 2020"

theory day5
  imports Main "HOL.Code_Numeral" string_utils list_natural_utils list_utils
begin

text "This is a solution to the puzzle for day 5"

subsection "Input parsing"

text "the inputs are numbers, but encoded strangely. Just binary numbers where the 1s are either
R or B and the 0s are either F or L"

definition convert_digit :: "char \<Rightarrow> char"
  where "convert_digit c = (case c of
    CHR ''R'' \<Rightarrow> CHR ''1''
    |CHR ''B'' \<Rightarrow> CHR ''1''
    |c\<Rightarrow> CHR ''0''
  )"

definition parse_line :: "string \<Rightarrow> natural"
  where "parse_line = str_to_nat_base 2 \<circ> (map convert_digit)"

definition parse_input :: "string \<Rightarrow> natural list"
  where "parse_input = map parse_line \<circ> split CHR ''\<newline>'' \<circ> trim"

subsection "Solution Algorithm"

text "The first part of this one's trivial, just find the max number"

definition list_max :: "natural list \<Rightarrow> natural"
  where "list_max = (reduce max 0)"

definition part1 :: "string \<Rightarrow> natural"
  where "part1 = list_max \<circ> parse_input"

text "the second part is a little more interesting, find a number N in the range 0 to 1023 which is
not in the list, but where N+1 and N-1 are in the list"

definition is_hole :: "natural \<Rightarrow> natural list \<Rightarrow> bool"
  where "is_hole n l = (
    (contains (n-1) l)
    \<and> (contains (n+1) l)
    \<and> (\<not>contains n l)
  )"

definition part2 :: "string \<Rightarrow> natural"
  where "part2 a = hd (let l = (parse_input a) in filter (\<lambda>b. is_hole b l) [0...<1024])"

subsection "Testing"

text "We expect our test case to return 820"

definition example_input::string where "example_input = ''
BFFFBBFRRR
FFFBBBFRRR
BBFFBBFRLL
''"

lemma "part1 example_input = 820"
  by eval

text "For part 2 there was no example provided, so I wrote an example input, we expect 820 again."

definition possible_input_2 :: string where "possible_input_2 = ''
BFFFBBFLLL
BBFFBBFLLR
BBFFBBFLRL
BBFFBBFLRR
BBFFBBFRLR
BBFFBBFRRL
BBFFBBFRRR
''"

(* 1100110100 *)

lemma "part2 possible_input_2 = 820"
  by eval

export_code "part1" "part2" in Haskell module_name Solution

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

chapter "Distinct Proposition"

theory Distinct_Prop
imports
  "Word_Lib/HOL_Lemmas"
  "~~/src/HOL/Library/Prefix_Order"
begin

primrec
  distinct_prop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool)"
where
  "distinct_prop P [] = True"
| "distinct_prop P (x # xs) = ((\<forall>y\<in>set xs. P x y) \<and> distinct_prop P xs)"

primrec
  distinct_sets :: "'a set list \<Rightarrow> bool"
where
  "distinct_sets [] = True"
| "distinct_sets (x#xs) = (x \<inter> \<Union>set xs = {} \<and> distinct_sets xs)"

lemma distinct_prop_map:
  "distinct_prop P (map f xs) = distinct_prop (\<lambda>x y. P (f x) (f y)) xs"
  by (induct xs) auto

lemma distinct_prop_append:
  "distinct_prop P (xs @ ys) =
    (distinct_prop P xs \<and> distinct_prop P ys \<and> (\<forall>x \<in> set xs. \<forall>y \<in> set ys. P x y))"
  by (induct xs arbitrary: ys) (auto simp: conj_comms ball_Un)

lemma distinct_prop_distinct:
  "\<lbrakk> distinct xs; \<And>x y. \<lbrakk> x \<in> set xs; y \<in> set xs; x \<noteq> y \<rbrakk> \<Longrightarrow> P x y \<rbrakk> \<Longrightarrow> distinct_prop P xs"
  by (induct xs) auto

lemma distinct_prop_True [simp]:
  "distinct_prop (\<lambda>x y. True) xs"
  by (induct xs, auto)

lemma distinct_prefix:
  "\<lbrakk> distinct xs; ys \<le> xs \<rbrakk> \<Longrightarrow> distinct ys"
  apply (induct xs arbitrary: ys; clarsimp)
  apply (case_tac ys; clarsimp)
  by (fastforce simp: less_eq_list_def dest: set_mono_prefix)

lemma distinct_sets_prop:
  "distinct_sets xs = distinct_prop (\<lambda>x y. x \<inter> y = {}) xs"
  by (induct xs) auto

lemma distinct_take_strg:
  "distinct xs \<longrightarrow> distinct (take n xs)"
  by simp

lemma distinct_prop_prefixE:
  "\<lbrakk> distinct_prop P ys; prefix xs ys \<rbrakk> \<Longrightarrow> distinct_prop P xs"
  apply (induct xs arbitrary: ys; clarsimp)
  apply (case_tac ys; clarsimp)
  by (fastforce dest: set_mono_prefix)

lemma distinct_sets_union_sub:
  "\<lbrakk>x \<in> A; distinct_sets [A,B]\<rbrakk> \<Longrightarrow> A \<union> B - {x} = A - {x} \<union> B"
  by (auto simp: distinct_sets_def)

lemma distinct_sets_append:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets xs \<and> distinct_sets ys"
  apply (subst distinct_sets_prop)+
  apply (subst (asm) distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_append1:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets xs"
  by (drule distinct_sets_append, simp)

lemma distinct_sets_append2:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets ys"
  by (drule distinct_sets_append, simp)

lemma distinct_sets_append_Cons:
  "distinct_sets (xs @ a # ys) \<Longrightarrow> distinct_sets (xs @ ys)"
  apply (subst distinct_sets_prop)+
  apply (subst (asm) distinct_sets_prop)
  apply (subst distinct_prop_append)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_append_Cons_disjoint:
  "distinct_sets (xs @ a # ys) \<Longrightarrow>  a \<inter> \<Union>set xs = {} "
  apply (subst (asm) distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply (subst Int_commute)
  apply (subst Union_disjoint)
  apply clarsimp
  done

lemma distinct_prop_take:
  "\<lbrakk>distinct_prop P xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_prop P (take i xs)"
  by (metis take_is_prefix distinct_prop_prefixE)

lemma distinct_sets_take:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (take i xs)"
  by (simp add: distinct_sets_prop distinct_prop_take)

lemma distinct_prop_take_Suc:
  "\<lbrakk>distinct_prop P xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_prop P (take (Suc i) xs)"
  by (metis distinct_prop_take not_less take_all)

lemma distinct_sets_take_Suc:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (take (Suc i) xs)"
  by (simp add: distinct_sets_prop distinct_prop_take_Suc)

lemma distinct_prop_rev:
  "distinct_prop P (rev xs) = distinct_prop (\<lambda>y x. P x y) xs"
  by (induct xs) (auto simp: distinct_prop_append)

lemma distinct_sets_rev [simp]:
  "distinct_sets (rev xs) = distinct_sets xs"
  apply (unfold distinct_sets_prop)
  apply (subst distinct_prop_rev)
  apply (subst Int_commute)
  apply clarsimp
  done

lemma distinct_sets_drop:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (drop i xs)"
  apply (cases "i=0", simp)
  apply (subst distinct_sets_rev [symmetric])
  apply (subst rev_drop)
  apply (subst distinct_sets_take, simp_all)
  done

lemma distinct_sets_drop_Suc:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (drop (Suc i) xs)"
  apply (subst distinct_sets_rev [symmetric])
  apply (subst rev_drop)
  apply (subst distinct_sets_take, simp_all)
  done

lemma distinct_sets_take_nth:
  "\<lbrakk>distinct_sets xs; i < length xs; x \<in> set (take i xs)\<rbrakk> \<Longrightarrow> x \<inter> xs ! i = {}"
  apply (drule (1) distinct_sets_take_Suc)
  apply (subst (asm) take_Suc_conv_app_nth, assumption)
  apply (unfold distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_drop_nth:
  "\<lbrakk>distinct_sets xs; i < length xs; x \<in> set (drop (Suc i) xs)\<rbrakk> \<Longrightarrow> x \<inter> xs ! i = {}"
  apply (drule (1) distinct_sets_drop)
  apply (subst (asm) drop_Suc_nth, assumption)
  apply fastforce
  done

lemma distinct_sets_append_distinct:
  "\<lbrakk>x \<in> set xs; y \<in> set ys; distinct_sets (xs @ ys)\<rbrakk> \<Longrightarrow> x \<inter> y = {}"
  unfolding distinct_sets_prop by (clarsimp simp: distinct_prop_append)

lemma distinct_sets_update:
 "\<lbrakk>a \<subseteq> xs ! i; distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (xs[i := a])"
  apply (subst distinct_sets_prop)
  apply (subst (asm) distinct_sets_prop)
  apply (subst upd_conv_take_nth_drop, simp)
  apply (subst distinct_prop_append)
  apply (intro conjI)
    apply (erule (1) distinct_prop_take)
   apply (rule conjI|clarsimp)+
    apply (fold distinct_sets_prop)
    apply (drule (1) distinct_sets_drop)
    apply (subst (asm) drop_Suc_nth, assumption)
    apply fastforce
   apply (drule (1) distinct_sets_drop)
   apply (subst (asm) drop_Suc_nth, assumption)
   apply clarsimp
  apply clarsimp
  apply (rule conjI)
   apply (drule (2) distinct_sets_take_nth)
   apply blast
  apply clarsimp
  apply (thin_tac "P \<subseteq> Q" for P Q)
  apply (subst (asm) id_take_nth_drop, assumption)
  apply (drule distinct_sets_append_Cons)
  apply (erule (2) distinct_sets_append_distinct)
  done

lemma distinct_sets_map_update:
  "\<lbrakk>distinct_sets (map f xs); i < length xs; f a \<subseteq> f(xs ! i)\<rbrakk>
  \<Longrightarrow> distinct_sets (map f (xs[i := a]))"
  by (metis distinct_sets_update length_map map_update nth_map)

lemma Union_list_update:
  "\<lbrakk>i < length xs; distinct_sets (map f xs)\<rbrakk>
  \<Longrightarrow> (\<Union>x\<in>set (xs [i := a]). f x) = (\<Union>x\<in>set xs. f x) - f (xs ! i) \<union> f a"
  apply (induct xs arbitrary: i; clarsimp)
  apply (case_tac i; (clarsimp, fastforce))
  done

lemma fst_enumerate:
  "i < length xs \<Longrightarrow> fst (enumerate n xs ! i) = i + n"
  by (metis add.commute fst_conv nth_enumerate_eq)

lemma snd_enumerate:
  "i < length xs \<Longrightarrow> snd (enumerate n xs ! i) = xs ! i"
  by (metis nth_enumerate_eq snd_conv)

lemma enumerate_member:
  assumes "i < length xs"
  shows "(n + i, xs ! i) \<in> set (enumerate n xs)"
proof -
  have pair_unpack: "\<And>a b x. ((a, b) = x) = (a = fst x \<and> b = snd x)" by fastforce
  from assms have "(n + i, xs ! i) = enumerate n xs ! i"
    by (auto simp: fst_enumerate snd_enumerate pair_unpack)
  with assms show ?thesis by simp
qed

lemma distinct_prop_nth:
  "\<lbrakk> distinct_prop P ls; n < n'; n' < length ls \<rbrakk> \<Longrightarrow> P (ls ! n) (ls ! n')"
  apply (induct ls arbitrary: n n'; simp)
  apply (case_tac n'; simp)
  apply (case_tac n; simp)
  done

end


(*  Title:      HOL/Isar_Examples/Hoare.thy
    Author:     Makarius

A formulation of Hoare logic suitable for Isar.
*)

section \<open>Hoare Logic\<close>

theory Hoare
  imports Main
begin

subsection \<open>Abstract syntax and semantics\<close>

text \<open>
  The following abstract syntax and semantics of Hoare Logic over \<^verbatim>\<open>WHILE\<close>
  programs closely follows the existing tradition in Isabelle/HOL of
  formalizing the presentation given in @{cite \<open>\S6\<close> "Winskel:1993"}. See also
  \<^dir>\<open>~~/src/HOL/Hoare\<close> and @{cite "Nipkow:1998:Winskel"}.
\<close>

type_synonym 'a bexp = "'a set"
type_synonym 'a assn = "'a set"

datatype 'a com =
    Basic "'a \<Rightarrow> 'a"
  | Seq "'a com" "'a com"    ("(_;/ _)" [60, 61] 60)
  | Cond "'a bexp" "'a com" "'a com"
  | While "'a bexp" "'a assn" "'a com"

abbreviation Skip  ("SKIP")
  where "SKIP \<equiv> Basic id"

type_synonym 'a sem = "'a \<Rightarrow> 'a \<Rightarrow> bool"

primrec iter :: "nat \<Rightarrow> 'a bexp \<Rightarrow> 'a sem \<Rightarrow> 'a sem"
  where
    "iter 0 b S s s' \<longleftrightarrow> s \<notin> b \<and> s = s'"
  | "iter (Suc n) b S s s' \<longleftrightarrow> s \<in> b \<and> (\<exists>s''. S s s'' \<and> iter n b S s'' s')"

primrec Sem :: "'a com \<Rightarrow> 'a sem"
  where
    "Sem (Basic f) s s' \<longleftrightarrow> s' = f s"
  | "Sem (c1; c2) s s' \<longleftrightarrow> (\<exists>s''. Sem c1 s s'' \<and> Sem c2 s'' s')"
  | "Sem (Cond b c1 c2) s s' \<longleftrightarrow> (if s \<in> b then Sem c1 s s' else Sem c2 s s')"
  | "Sem (While b x c) s s' \<longleftrightarrow> (\<exists>n. iter n b (Sem c) s s')"

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"
  ("(3\<turnstile> _/ (2_)/ _)" [100, 55, 100] 50)
  where "\<turnstile> P c Q \<longleftrightarrow> (\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> P \<longrightarrow> s' \<in> Q)"

lemma ValidI [intro?]: "(\<And>s s'. Sem c s s' \<Longrightarrow> s \<in> P \<Longrightarrow> s' \<in> Q) \<Longrightarrow> \<turnstile> P c Q"
  by (simp add: Valid_def)

lemma ValidD [dest?]: "\<turnstile> P c Q \<Longrightarrow> Sem c s s' \<Longrightarrow> s \<in> P \<Longrightarrow> s' \<in> Q"
  by (simp add: Valid_def)

subsection \<open>Primitive Hoare rules\<close>

text \<open>
  From the semantics defined above, we derive the standard set of primitive
  Hoare rules; e.g.\ see @{cite \<open>\S6\<close> "Winskel:1993"}. Usually, variant forms
  of these rules are applied in actual proof, see also \S\ref{sec:hoare-isar}
  and \S\ref{sec:hoare-vcg}.

  \<^medskip>
  The \<open>basic\<close> rule represents any kind of atomic access to the state space.
  This subsumes the common rules of \<open>skip\<close> and \<open>assign\<close>, as formulated in
  \S\ref{sec:hoare-isar}.
\<close>

theorem basic: "\<turnstile> {s. f s \<in> P} (Basic f) P"
proof
  fix s s'
  assume a: \<open>s \<in> {s. f s \<in> P}\<close>
  assume \<open>Sem (Basic f) s s'\<close>
  hence \<open>s' = f s\<close> by simp
  thus \<open>s' \<in> P\<close> using a by simp
qed

text \<open>
  The rules for sequential commands and semantic consequences are established
  in a straight forward manner as follows.
\<close>

theorem seq: "\<turnstile> P c1 Q \<Longrightarrow> \<turnstile> Q c2 R \<Longrightarrow> \<turnstile> P (c1; c2) R"
proof
  fix s s'
  assume a1: "\<turnstile> P c1 Q"
  assume a2: "\<turnstile> Q c2 R"
  assume a4: "Sem (c1; c2) s s'"
  assume a3: "s \<in> P"
  from a4 obtain s'' where o1: "Sem c1 s s'' \<and> Sem c2 s'' s'" by auto
  from o1 have "Sem c1 s s''" by (rule conjunct1)
  hence s: "s'' \<in> Q" using a1 a3 by (simp add: ValidD)
  from o1 have "Sem c2 s'' s'" by (rule conjunct2)
  thus "s' \<in> R" using a2 s by (simp add: ValidD)
qed

theorem conseq: "P' \<subseteq> P \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P' c Q'"
proof
  fix s s'
  assume a1: "P' \<subseteq> P"
  assume a2: "\<turnstile> P c Q"
  assume a3: "Q \<subseteq> Q'"
  assume a4: "Sem c s s'"
  assume a5: "s \<in> P'"
  from a1 a5 have b1: "s \<in> P" by auto
  from a2 a4 b1 have b2: "s' \<in> Q" by (simp add: ValidD)
  from b2 a3 show b3: "s' \<in> Q'" by auto
qed

text \<open>
  The rule for conditional commands is directly reflected by the corresponding
  semantics; in the proof we just have to look closely which cases apply.
\<close>

theorem cond:
  assumes case_b: "\<turnstile> (P \<inter> b) c1 Q"
    and case_nb: "\<turnstile> (P \<inter> -b) c2 Q"
  shows "\<turnstile> P (Cond b c1 c2) Q"
proof
  fix s s'
  assume a1: "Sem (Cond b c1 c2) s s'"
  assume a2: "s \<in> P"
  show "s' \<in> Q"
  proof (cases "s \<in> b")
    case True
    from a1 have "Sem c1 s s'" by (simp add: True)
    then show ?thesis
      using True ValidD a2 case_b by fastforce
  next
    case False
    from a1 have "Sem c2 s s'" by (simp add: False)
    then show ?thesis
      using False ValidD a2 case_nb by fastforce
  qed
qed

text \<open>
  The \<open>while\<close> rule is slightly less trivial --- it is the only one based on
  recursion, which is expressed in the semantics by a Kleene-style least
  fixed-point construction. The auxiliary statement below, which is by
  induction on the number of iterations is the main point to be proven; the
  rest is by routine application of the semantics of \<^verbatim>\<open>WHILE\<close>.
\<close>

theorem while:
  assumes body: "\<turnstile> (P \<inter> b) c P"
  shows "\<turnstile> P (While b X c) (P \<inter> -b)"
proof
  fix s s'
  assume a1: "Sem (While b X c) s s'"
  assume a2: "s \<in> P"
  from a1 obtain n where o1: "iter n b (Sem c) s s'" by auto
  thus "s' \<in> P \<inter> -b" using a2
  proof (induct n arbitrary: s)
    case 0
    then show ?case by auto
  next
    case (Suc n)
    then obtain s'' where o2: "s \<in> b"
      and o3: "(Sem c) s s''" and o4: "iter n b (Sem c) s'' s'" by auto
    from Suc and o2 have "s \<in> P \<inter> b" by simp
    from this body o3 have "s'' \<in> P" by (simp add:ValidD)
    with o4 show ?case by (rule Suc)
  qed
qed

subsection \<open>Concrete syntax for assertions\<close>

text \<open>
  We now introduce concrete syntax for describing commands (with embedded
  expressions) and assertions. The basic technique is that of semantic
  ``quote-antiquote''. A \<^emph>\<open>quotation\<close> is a syntactic entity delimited by an
  implicit abstraction, say over the state space. An \<^emph>\<open>antiquotation\<close> is a
  marked expression within a quotation that refers the implicit argument; a
  typical antiquotation would select (or even update) components from the
  state.

  We will see some examples later in the concrete rules and applications.

  \<^medskip>
  The following specification of syntax and translations is for Isabelle
  experts only; feel free to ignore it.

  While the first part is still a somewhat intelligible specification of the
  concrete syntactic representation of our Hoare language, the actual ``ML
  drivers'' is quite involved. Just note that the we re-use the basic
  quote/antiquote translations as already defined in Isabelle/Pure (see @{ML
  Syntax_Trans.quote_tr}, and @{ML Syntax_Trans.quote_tr'},).
\<close>

syntax
  "_quote" :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)"
  "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b"  ("\<acute>_" [1000] 1000)
  "_Subst" :: "'a bexp \<Rightarrow> 'b \<Rightarrow> idt \<Rightarrow> 'a bexp"  ("_[_'/\<acute>_]" [1000] 999)
  "_Assert" :: "'a \<Rightarrow> 'a set"  ("(\<lbrace>_\<rbrace>)" [0] 1000)
  "_Assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a com"  ("(\<acute>_ :=/ _)" [70, 65] 61)
  "_Cond" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com \<Rightarrow> 'a com"
    ("(0IF _/ THEN _/ ELSE _/ FI)" [0, 0, 0] 61)
  "_While_inv" :: "'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a com \<Rightarrow> 'a com"
    ("(0WHILE _/ INV _ //DO _ /OD)"  [0, 0, 0] 61)
  "_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com"  ("(0WHILE _ //DO _ /OD)"  [0, 0] 61)

translations
  "\<lbrace>b\<rbrace>" \<rightharpoonup> "CONST Collect (_quote b)"
  "B [a/\<acute>x]" \<rightharpoonup> "\<lbrace>\<acute>(_update_name x (\<lambda>_. a)) \<in> B\<rbrace>"
  "\<acute>x := a" \<rightharpoonup> "CONST Basic (_quote (\<acute>(_update_name x (\<lambda>_. a))))"
  "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "CONST Cond \<lbrace>b\<rbrace> c1 c2"
  "WHILE b INV i DO c OD" \<rightharpoonup> "CONST While \<lbrace>b\<rbrace> i c"
  "WHILE b DO c OD" \<rightleftharpoons> "WHILE b INV CONST undefined DO c OD"

parse_translation \<open>
  let
    fun quote_tr [t] = Syntax_Trans.quote_tr @{syntax_const "_antiquote"} t
      | quote_tr ts = raise TERM ("quote_tr", ts);
  in [(@{syntax_const "_quote"}, K quote_tr)] end
\<close>

text \<open>
  As usual in Isabelle syntax translations, the part for printing is more
  complicated --- we cannot express parts as macro rules as above. Don't look
  here, unless you have to do similar things for yourself.
\<close>

print_translation \<open>
  let
    fun quote_tr' f (t :: ts) =
          Term.list_comb (f $ Syntax_Trans.quote_tr' @{syntax_const "_antiquote"} t, ts)
      | quote_tr' _ _ = raise Match;

    val assert_tr' = quote_tr' (Syntax.const @{syntax_const "_Assert"});

    fun bexp_tr' name ((Const (@{const_syntax Collect}, _) $ t) :: ts) =
          quote_tr' (Syntax.const name) (t :: ts)
      | bexp_tr' _ _ = raise Match;

    fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
          quote_tr' (Syntax.const @{syntax_const "_Assign"} $ Syntax_Trans.update_name_tr' f)
            (Abs (x, dummyT, Syntax_Trans.const_abs_tr' k) :: ts)
      | assign_tr' _ = raise Match;
  in
   [(@{const_syntax Collect}, K assert_tr'),
    (@{const_syntax Basic}, K assign_tr'),
    (@{const_syntax Cond}, K (bexp_tr' @{syntax_const "_Cond"})),
    (@{const_syntax While}, K (bexp_tr' @{syntax_const "_While_inv"}))]
  end
\<close>

subsection \<open>Rules for single-step proof \label{sec:hoare-isar}\<close>

text \<open>
  We are now ready to introduce a set of Hoare rules to be used in single-step
  structured proofs in Isabelle/Isar. We refer to the concrete syntax
  introduce above.

  \<^medskip>
  Assertions of Hoare Logic may be manipulated in calculational proofs, with
  the inclusion expressed in terms of sets or predicates. Reversed order is
  supported as well.
\<close>

lemma [trans]: "\<turnstile> P c Q \<Longrightarrow> P' \<subseteq> P \<Longrightarrow> \<turnstile> P' c Q"
proof
  fix s s'
  assume a1: "\<turnstile> P c Q"
  assume a2: "P' \<subseteq> P"
  assume a3: "Sem c s s'"
  assume a4: "s \<in> P'"
  from a2 a4 have "s \<in> P" by auto
  with a1 a3 show "s' \<in> Q" by (simp add: ValidD)
qed

lemma [trans] : "P' \<subseteq> P \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> \<turnstile> P' c Q"
  by (unfold Valid_def) blast

lemma [trans]: "Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> \<turnstile> P c Q'"
  by (unfold Valid_def) blast

lemma [trans]: "\<turnstile> P c Q \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P c Q'"
  by (unfold Valid_def) blast

lemma [trans]:
    "\<turnstile> \<lbrace>\<acute>P\<rbrace> c Q \<Longrightarrow> (\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P'\<rbrace> c Q"
  by (unfold Valid_def) blast

lemma [trans]:
    "(\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> c Q \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P'\<rbrace> c Q"
  by (unfold Valid_def) blast

lemma [trans]:
    "\<turnstile> P c \<lbrace>\<acute>Q\<rbrace> \<Longrightarrow> (\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q'\<rbrace>"
  by (unfold Valid_def) blast

lemma [trans]:
    "(\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q\<rbrace> \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q'\<rbrace>"
  by (unfold Valid_def) blast

text \<open>
  Identity and basic assignments.\<^footnote>\<open>The \<open>hoare\<close> method introduced in
  \S\ref{sec:hoare-vcg} is able to provide proper instances for any number of
  basic assignments, without producing additional verification conditions.\<close>
\<close>

lemma skip [intro?]: "\<turnstile> P SKIP P"
proof -
  have "\<turnstile> {s. id s \<in> P} SKIP P" by (rule basic)
  thus ?thesis by simp
qed

lemma assign: "\<turnstile> P [\<acute>a/\<acute>x::'a] \<acute>x := \<acute>a P"
  by (rule basic)

text \<open>
  Note that above formulation of assignment corresponds to our preferred way
  to model state spaces, using (extensible) record types in HOL @{cite
  "Naraschewski-Wenzel:1998:HOOL"}. For any record field \<open>x\<close>, Isabelle/HOL
  provides a functions \<open>x\<close> (selector) and \<open>x_update\<close> (update). Above, there is
  only a place-holder appearing for the latter kind of function: due to
  concrete syntax \<open>\<acute>x := \<acute>a\<close> also contains \<open>x_update\<close>.\<^footnote>\<open>Note that due to the
  external nature of HOL record fields, we could not even state a general
  theorem relating selector and update functions (if this were required here);
  this would only work for any particular instance of record fields introduced
  so far.\<close>

  \<^medskip>
  Sequential composition --- normalizing with associativity achieves proper of
  chunks of code verified separately.
\<close>

lemmas [trans, intro?] = seq

lemma seq_assoc [simp]: "\<turnstile> P c1;(c2;c3) Q \<longleftrightarrow> \<turnstile> P (c1;c2);c3 Q"
  by (auto simp add: Valid_def)

text \<open>Conditional statements.\<close>

lemmas [trans, intro?] = cond

lemma [trans, intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c1 Q
      \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace> c2 Q
      \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> IF \<acute>b THEN c1 ELSE c2 FI Q"
    by (rule cond) (simp_all add: Valid_def)

text \<open>While statements --- with optional invariant.\<close>

lemma [intro?]: "\<turnstile> (P \<inter> b) c P \<Longrightarrow> \<turnstile> P (While b P c) (P \<inter> -b)"
  by (rule while)

lemma [intro?]: "\<turnstile> (P \<inter> b) c P \<Longrightarrow> \<turnstile> P (While b undefined c) (P \<inter> -b)"
  by (rule while)

lemma [intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c \<lbrace>\<acute>P\<rbrace>
    \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> WHILE \<acute>b INV \<lbrace>\<acute>P\<rbrace> DO c OD \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace>"
  by (simp add: while Collect_conj_eq Collect_neg_eq)

lemma [intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c \<lbrace>\<acute>P\<rbrace>
    \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> WHILE \<acute>b DO c OD \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace>"
  by (simp add: while Collect_conj_eq Collect_neg_eq)

subsection \<open>Verification conditions \label{sec:hoare-vcg}\<close>

text \<open>
  We now load the \<^emph>\<open>original\<close> ML file for proof scripts and tactic definition
  for the Hoare Verification Condition Generator (see \<^dir>\<open>~~/src/HOL/Hoare\<close>).
  As far as we are concerned here, the result is a proof method \<open>hoare\<close>, which
  may be applied to a Hoare Logic assertion to extract purely logical
  verification conditions. It is important to note that the method requires
  \<^verbatim>\<open>WHILE\<close> loops to be fully annotated with invariants beforehand.
  Furthermore, only \<^emph>\<open>concrete\<close> pieces of code are handled --- the underlying
  tactic fails ungracefully if supplied with meta-variables or parameters, for
  example.
\<close>

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) q"
  by (auto simp add: Valid_def)

lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) q"
  by (auto simp add: Valid_def)

lemma SeqRule: "Valid P c1 Q \<Longrightarrow> Valid Q c2 R \<Longrightarrow> Valid P (c1;c2) R"
  by (auto simp add: Valid_def)

lemma CondRule:
  "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
    \<Longrightarrow> Valid w c1 q \<Longrightarrow> Valid w' c2 q \<Longrightarrow> Valid p (Cond b c1 c2) q"
  by (auto simp add: Valid_def)

lemma iter_aux:
  "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> I \<and> s \<in> b \<longrightarrow> s' \<in> I \<Longrightarrow>
       (\<And>s s'. s \<in> I \<Longrightarrow> iter n b (Sem c) s s' \<Longrightarrow> s' \<in> I \<and> s' \<notin> b)"
proof (induct n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  then show ?case by auto
qed

lemma WhileRule:
    "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b i c) q"
proof
  fix s s'
  assume a1: "p \<subseteq> i"
  assume a2: "\<turnstile> (i \<inter> b) c i"
  assume a3: "i \<inter> - b \<subseteq> q"
  assume a4: "Sem (While b i c) s s'"
  assume a5: "s \<in> p"
  with a1 have h1: "s \<in> i" by auto
  from a4 obtain n where o1: "iter n b (Sem c) s s'" using Sem_def by auto
  from a2 have "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> i \<and> s \<in> b \<longrightarrow> s' \<in> i"
    by (simp add: ValidD)
  with h1 o1 have "s' \<in> i \<and> s' \<notin> b" by (meson iter_aux)
  thus "s' \<in> q" using a3 by auto
qed

lemma Compl_Collect: "- Collect b = {x. \<not> b x}"
  by auto

lemmas AbortRule = SkipRule  \<comment> "dummy version"

ML_file "~~/src/HOL/Hoare/hoare_tac.ML"

method_setup hoare =
  \<open>Scan.succeed (fn ctxt =>
    (SIMPLE_METHOD'
      (Hoare.hoare_tac ctxt
        (simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm "Record.K_record_comp"}] )))))\<close>
  "verification condition generator for Hoare logic"

end