(*  Title:      HOL/Old_Number_Theory/Primes.thy
    Author:     Amine Chaieb, Christophe Tabacznyj and Lawrence C Paulson
    Copyright   1996  University of Cambridge
*)

section {* Primality on nat *}

theory Primes
imports Complex_Main Legacy_GCD
begin

definition coprime :: "nat => nat => bool"
  where "coprime m n \<longleftrightarrow> gcd m n = 1"

definition prime :: "nat \<Rightarrow> bool"
  where "prime p \<longleftrightarrow> (1 < p \<and> (\<forall>m. m dvd p --> m = 1 \<or> m = p))"

lemma two_is_prime: "prime 2"
  apply (auto simp add: prime_def)
  apply (case_tac m)
   apply (auto dest!: dvd_imp_le)
  done

lemma prime_imp_relprime: "prime p ==> \<not> p dvd n ==> gcd p n = 1"
  apply (auto simp add: prime_def)
  apply (metis gcd_dvd1 gcd_dvd2)
  done

text {*
  This theorem leads immediately to a proof of the uniqueness of
  factorization.  If @{term p} divides a product of primes then it is
  one of those primes.
*}

lemma prime_dvd_mult: "prime p ==> p dvd m * n ==> p dvd m \<or> p dvd n"
  by (blast intro: relprime_dvd_mult prime_imp_relprime)

lemma prime_dvd_square: "prime p ==> p dvd m^Suc (Suc 0) ==> p dvd m"
  by (auto dest: prime_dvd_mult)

lemma prime_dvd_power_two: "prime p ==> p dvd m\<^sup>2 ==> p dvd m"
  by (rule prime_dvd_square) (simp_all add: power2_eq_square)

lemma exp_eq_1:"(x::nat)^n = 1 \<longleftrightarrow> x = 1 \<or> n = 0"
by (induct n, auto)

lemma exp_mono_lt: "(x::nat) ^ (Suc n) < y ^ (Suc n) \<longleftrightarrow> x < y"
by(metis linorder_not_less not_less0 power_le_imp_le_base power_less_imp_less_base)

lemma exp_mono_le: "(x::nat) ^ (Suc n) \<le> y ^ (Suc n) \<longleftrightarrow> x \<le> y"
by (simp only: linorder_not_less[symmetric] exp_mono_lt)

lemma exp_mono_eq: "(x::nat) ^ Suc n = y ^ Suc n \<longleftrightarrow> x = y"
using power_inject_base[of x n y] by auto

lemma even_square: assumes e: "even (n::nat)" shows "\<exists>x. n\<^sup>2 = 4*x"
proof-
  from e have "2 dvd n" by presburger
  then obtain k where k: "n = 2*k" using dvd_def by auto
  hence "n\<^sup>2 = 4 * k\<^sup>2" by (simp add: power2_eq_square)
  thus ?thesis by blast
qed

lemma odd_square: assumes e: "odd (n::nat)" shows "\<exists>x. n\<^sup>2 = 4*x + 1"
proof-
  from e have np: "n > 0" by presburger
  from e have "2 dvd (n - 1)" by presburger
  then obtain k where "n - 1 = 2 * k" ..
  hence k: "n = 2*k + 1"  using e by presburger
  hence "n\<^sup>2 = 4* (k\<^sup>2 + k) + 1" by algebra
  thus ?thesis by blast
qed

lemma diff_square: "(x::nat)\<^sup>2 - y\<^sup>2 = (x+y)*(x - y)"
proof-
  have "x \<le> y \<or> y \<le> x" by (rule nat_le_linear)
  moreover
  {assume le: "x \<le> y"
    hence "x\<^sup>2 \<le> y\<^sup>2" by (simp only: numeral_2_eq_2 exp_mono_le Let_def)
    with le have ?thesis by simp }
  moreover
  {assume le: "y \<le> x"
    hence le2: "y\<^sup>2 \<le> x\<^sup>2" by (simp only: numeral_2_eq_2 exp_mono_le Let_def)
    from le have "\<exists>z. y + z = x" by presburger
    then obtain z where z: "x = y + z" by blast
    from le2 have "\<exists>z. x\<^sup>2 = y\<^sup>2 + z" by presburger
    then obtain z2 where z2: "x\<^sup>2 = y\<^sup>2 + z2" by blast
    from z z2 have ?thesis by simp algebra }
  ultimately show ?thesis by blast
qed

text {* Elementary theory of divisibility *}
lemma divides_ge: "(a::nat) dvd b \<Longrightarrow> b = 0 \<or> a \<le> b" unfolding dvd_def by auto
lemma divides_antisym: "(x::nat) dvd y \<and> y dvd x \<longleftrightarrow> x = y"
  using dvd_antisym[of x y] by auto

lemma divides_add_revr: assumes da: "(d::nat) dvd a" and dab:"d dvd (a + b)"
  shows "d dvd b"
proof-
  from da obtain k where k:"a = d*k" by (auto simp add: dvd_def)
  from dab obtain k' where k': "a + b = d*k'" by (auto simp add: dvd_def)
  from k k' have "b = d *(k' - k)" by (simp add : diff_mult_distrib2)
  thus ?thesis unfolding dvd_def by blast
qed

declare nat_mult_dvd_cancel_disj[presburger]
lemma nat_mult_dvd_cancel_disj'[presburger]:
  "(m\<Colon>nat)*k dvd n*k \<longleftrightarrow> k = 0 \<or> m dvd n" unfolding mult.commute[of m k] mult.commute[of n k] by presburger

lemma divides_mul_l: "(a::nat) dvd b ==> (c * a) dvd (c * b)"
  by presburger

lemma divides_mul_r: "(a::nat) dvd b ==> (a * c) dvd (b * c)" by presburger
lemma divides_cases: "(n::nat) dvd m ==> m = 0 \<or> m = n \<or> 2 * n <= m"
  by (auto simp add: dvd_def)

lemma divides_div_not: "(x::nat) = (q * n) + r \<Longrightarrow> 0 < r \<Longrightarrow> r < n ==> ~(n dvd x)"
proof(auto simp add: dvd_def)
  fix k assume H: "0 < r" "r < n" "q * n + r = n * k"
  from H(3) have r: "r = n* (k -q)" by(simp add: diff_mult_distrib2 mult.commute)
  {assume "k - q = 0" with r H(1) have False by simp}
  moreover
  {assume "k - q \<noteq> 0" with r have "r \<ge> n" by auto
    with H(2) have False by simp}
  ultimately show False by blast
qed
lemma divides_exp: "(x::nat) dvd y ==> x ^ n dvd y ^ n"
  by (auto simp add: power_mult_distrib dvd_def)

lemma divides_exp2: "n \<noteq> 0 \<Longrightarrow> (x::nat) ^ n dvd y \<Longrightarrow> x dvd y"
  by (induct n ,auto simp add: dvd_def)

fun fact :: "nat \<Rightarrow> nat" where
  "fact 0 = 1"
| "fact (Suc n) = Suc n * fact n"

lemma fact_lt: "0 < fact n" by(induct n, simp_all)
lemma fact_le: "fact n \<ge> 1" using fact_lt[of n] by simp
lemma fact_mono: assumes le: "m \<le> n" shows "fact m \<le> fact n"
proof-
  from le have "\<exists>i. n = m+i" by presburger
  then obtain i where i: "n = m+i" by blast
  have "fact m \<le> fact (m + i)"
  proof(induct m)
    case 0 thus ?case using fact_le[of i] by simp
  next
    case (Suc m)
    have "fact (Suc m) = Suc m * fact m" by simp
    have th1: "Suc m \<le> Suc (m + i)" by simp
    from mult_le_mono[of "Suc m" "Suc (m+i)" "fact m" "fact (m+i)", OF th1 Suc.hyps]
    show ?case by simp
  qed
  thus ?thesis using i by simp
qed

lemma divides_fact: "1 <= p \<Longrightarrow> p <= n ==> p dvd fact n"
proof(induct n arbitrary: p)
  case 0 thus ?case by simp
next
  case (Suc n p)
  from Suc.prems have "p = Suc n \<or> p \<le> n" by presburger
  moreover
  {assume "p = Suc n" hence ?case  by (simp only: fact.simps dvd_triv_left)}
  moreover
  {assume "p \<le> n"
    with Suc.prems(1) Suc.hyps have th: "p dvd fact n" by simp
    from dvd_mult[OF th] have ?case by (simp only: fact.simps) }
  ultimately show ?case by blast
qed

declare dvd_triv_left[presburger]
declare dvd_triv_right[presburger]
lemma divides_rexp:
  "x dvd y \<Longrightarrow> (x::nat) dvd (y^(Suc n))" by (simp add: dvd_mult2[of x y])

text {* Coprimality *}

lemma coprime: "coprime a b \<longleftrightarrow> (\<forall>d. d dvd a \<and> d dvd b \<longleftrightarrow> d = 1)"
using gcd_unique[of 1 a b, simplified] by (auto simp add: coprime_def)
lemma coprime_commute: "coprime a b \<longleftrightarrow> coprime b a" by (simp add: coprime_def gcd_commute)

lemma coprime_bezout: "coprime a b \<longleftrightarrow> (\<exists>x y. a * x - b * y = 1 \<or> b * x - a * y = 1)"
using coprime_def gcd_bezout by auto

lemma coprime_divprod: "d dvd a * b  \<Longrightarrow> coprime d a \<Longrightarrow> d dvd b"
  using relprime_dvd_mult_iff[of d a b] by (auto simp add: coprime_def mult.commute)

lemma coprime_1[simp]: "coprime a 1" by (simp add: coprime_def)
lemma coprime_1'[simp]: "coprime 1 a" by (simp add: coprime_def)
lemma coprime_Suc0[simp]: "coprime a (Suc 0)" by (simp add: coprime_def)
lemma coprime_Suc0'[simp]: "coprime (Suc 0) a" by (simp add: coprime_def)

lemma gcd_coprime:
  assumes z: "gcd a b \<noteq> 0" and a: "a = a' * gcd a b" and b: "b = b' * gcd a b"
  shows    "coprime a' b'"
proof-
  let ?g = "gcd a b"
  {assume bz: "a = 0" from b bz z a have ?thesis by (simp add: gcd_zero coprime_def)}
  moreover
  {assume az: "a\<noteq> 0"
    from z have z': "?g > 0" by simp
    from bezout_gcd_strong[OF az, of b]
    obtain x y where xy: "a*x = b*y + ?g" by blast
    from xy a b have "?g * a'*x = ?g * (b'*y + 1)" by (simp add: algebra_simps)
    hence "?g * (a'*x) = ?g * (b'*y + 1)" by (simp add: mult.assoc)
    hence "a'*x = (b'*y + 1)"
      by (simp only: nat_mult_eq_cancel1[OF z'])
    hence "a'*x - b'*y = 1" by simp
    with coprime_bezout[of a' b'] have ?thesis by auto}
  ultimately show ?thesis by blast
qed
lemma coprime_0: "coprime d 0 \<longleftrightarrow> d = 1" by (simp add: coprime_def)
lemma coprime_mul: assumes da: "coprime d a" and db: "coprime d b"
  shows "coprime d (a * b)"
proof-
  from da have th: "gcd a d = 1" by (simp add: coprime_def gcd_commute)
  from gcd_mult_cancel[of a d b, OF th] db[unfolded coprime_def] have "gcd d (a*b) = 1"
    by (simp add: gcd_commute)
  thus ?thesis unfolding coprime_def .
qed
lemma coprime_lmul2: assumes dab: "coprime d (a * b)" shows "coprime d b"
using dab unfolding coprime_bezout
apply clarsimp
apply (case_tac "d * x - a * b * y = Suc 0 ", simp_all)
apply (rule_tac x="x" in exI)
apply (rule_tac x="a*y" in exI)
apply (simp add: ac_simps)
apply (rule_tac x="a*x" in exI)
apply (rule_tac x="y" in exI)
apply (simp add: ac_simps)
done

lemma coprime_rmul2: "coprime d (a * b) \<Longrightarrow> coprime d a"
unfolding coprime_bezout
apply clarsimp
apply (case_tac "d * x - a * b * y = Suc 0 ", simp_all)
apply (rule_tac x="x" in exI)
apply (rule_tac x="b*y" in exI)
apply (simp add: ac_simps)
apply (rule_tac x="b*x" in exI)
apply (rule_tac x="y" in exI)
apply (simp add: ac_simps)
done
lemma coprime_mul_eq: "coprime d (a * b) \<longleftrightarrow> coprime d a \<and>  coprime d b"
  using coprime_rmul2[of d a b] coprime_lmul2[of d a b] coprime_mul[of d a b]
  by blast

lemma gcd_coprime_exists:
  assumes nz: "gcd a b \<noteq> 0"
  shows "\<exists>a' b'. a = a' * gcd a b \<and> b = b' * gcd a b \<and> coprime a' b'"
proof-
  let ?g = "gcd a b"
  from gcd_dvd1[of a b] gcd_dvd2[of a b]
  obtain a' b' where "a = ?g*a'"  "b = ?g*b'" unfolding dvd_def by blast
  hence ab': "a = a'*?g" "b = b'*?g" by algebra+
  from ab' gcd_coprime[OF nz ab'] show ?thesis by blast
qed

lemma coprime_exp: "coprime d a ==> coprime d (a^n)"
  by(induct n, simp_all add: coprime_mul)

lemma coprime_exp_imp: "coprime a b ==> coprime (a ^n) (b ^n)"
  by (induct n, simp_all add: coprime_mul_eq coprime_commute coprime_exp)
lemma coprime_refl[simp]: "coprime n n \<longleftrightarrow> n = 1" by (simp add: coprime_def)
lemma coprime_plus1[simp]: "coprime (n + 1) n"
  apply (simp add: coprime_bezout)
  apply (rule exI[where x=1])
  apply (rule exI[where x=1])
  apply simp
  done
lemma coprime_minus1: "n \<noteq> 0 ==> coprime (n - 1) n"
  using coprime_plus1[of "n - 1"] coprime_commute[of "n - 1" n] by auto

lemma bezout_gcd_pow: "\<exists>x y. a ^n * x - b ^ n * y = gcd a b ^ n \<or> b ^ n * x - a ^ n * y = gcd a b ^ n"
proof-
  let ?g = "gcd a b"
  {assume z: "?g = 0" hence ?thesis
      apply (cases n, simp)
      apply arith
      apply (simp only: z power_0_Suc)
      apply (rule exI[where x=0])
      apply (rule exI[where x=0])
      apply simp
      done }
  moreover
  {assume z: "?g \<noteq> 0"
    from gcd_dvd1[of a b] gcd_dvd2[of a b] obtain a' b' where
      ab': "a = a'*?g" "b = b'*?g" unfolding dvd_def by (auto simp add: ac_simps)
    hence ab'': "?g*a' = a" "?g * b' = b" by algebra+
    from coprime_exp_imp[OF gcd_coprime[OF z ab'], unfolded coprime_bezout, of n]
    obtain x y where "a'^n * x - b'^n * y = 1 \<or> b'^n * x - a'^n * y = 1"  by blast
    hence "?g^n * (a'^n * x - b'^n * y) = ?g^n \<or> ?g^n*(b'^n * x - a'^n * y) = ?g^n"
      using z by auto
    then have "a^n * x - b^n * y = ?g^n \<or> b^n * x - a^n * y = ?g^n"
      using z ab'' by (simp only: power_mult_distrib[symmetric]
        diff_mult_distrib2 mult.assoc[symmetric])
    hence  ?thesis by blast }
  ultimately show ?thesis by blast
qed

lemma gcd_exp: "gcd (a^n) (b^n) = gcd a b^n"
proof-
  let ?g = "gcd (a^n) (b^n)"
  let ?gn = "gcd a b^n"
  {fix e assume H: "e dvd a^n" "e dvd b^n"
    from bezout_gcd_pow[of a n b] obtain x y
      where xy: "a ^ n * x - b ^ n * y = ?gn \<or> b ^ n * x - a ^ n * y = ?gn" by blast
    from dvd_diff_nat [OF dvd_mult2[OF H(1), of x] dvd_mult2[OF H(2), of y]]
      dvd_diff_nat [OF dvd_mult2[OF H(2), of x] dvd_mult2[OF H(1), of y]] xy
    have "e dvd ?gn" by (cases "a ^ n * x - b ^ n * y = gcd a b ^ n", simp_all)}
  hence th:  "\<forall>e. e dvd a^n \<and> e dvd b^n \<longrightarrow> e dvd ?gn" by blast
  from divides_exp[OF gcd_dvd1[of a b], of n] divides_exp[OF gcd_dvd2[of a b], of n] th
    gcd_unique have "?gn = ?g" by blast thus ?thesis by simp
qed

lemma coprime_exp2:  "coprime (a ^ Suc n) (b^ Suc n) \<longleftrightarrow> coprime a b"
by (simp only: coprime_def gcd_exp exp_eq_1) simp

lemma division_decomp: assumes dc: "(a::nat) dvd b * c"
  shows "\<exists>b' c'. a = b' * c' \<and> b' dvd b \<and> c' dvd c"
proof-
  let ?g = "gcd a b"
  {assume "?g = 0" with dc have ?thesis apply (simp add: gcd_zero)
      apply (rule exI[where x="0"])
      by (rule exI[where x="c"], simp)}
  moreover
  {assume z: "?g \<noteq> 0"
    from gcd_coprime_exists[OF z]
    obtain a' b' where ab': "a = a' * ?g" "b = b' * ?g" "coprime a' b'" by blast
    from gcd_dvd2[of a b] have thb: "?g dvd b" .
    from ab'(1) have "a' dvd a"  unfolding dvd_def by blast
    with dc have th0: "a' dvd b*c" using dvd_trans[of a' a "b*c"] by simp
    from dc ab'(1,2) have "a'*?g dvd (b'*?g) *c" by auto
    hence "?g*a' dvd ?g * (b' * c)" by (simp add: mult.assoc)
    with z have th_1: "a' dvd b'*c" by simp
    from coprime_divprod[OF th_1 ab'(3)] have thc: "a' dvd c" .
    from ab' have "a = ?g*a'" by algebra
    with thb thc have ?thesis by blast }
  ultimately show ?thesis by blast
qed

lemma nat_power_eq_0_iff: "(m::nat) ^ n = 0 \<longleftrightarrow> n \<noteq> 0 \<and> m = 0" by (induct n, auto)

lemma divides_rev: assumes ab: "(a::nat) ^ n dvd b ^n" and n:"n \<noteq> 0" shows "a dvd b"
proof-
  let ?g = "gcd a b"
  from n obtain m where m: "n = Suc m" by (cases n, simp_all)
  {assume "?g = 0" with ab n have ?thesis by (simp add: gcd_zero)}
  moreover
  {assume z: "?g \<noteq> 0"
    hence zn: "?g ^ n \<noteq> 0" using n by simp
    from gcd_coprime_exists[OF z]
    obtain a' b' where ab': "a = a' * ?g" "b = b' * ?g" "coprime a' b'" by blast
    from ab have "(a' * ?g) ^ n dvd (b' * ?g)^n" by (simp add: ab'(1,2)[symmetric])
    hence "?g^n*a'^n dvd ?g^n *b'^n" by (simp only: power_mult_distrib mult.commute)
    with zn z n have th0:"a'^n dvd b'^n" by (auto simp add: nat_power_eq_0_iff)
    have "a' dvd a'^n" by (simp add: m)
    with th0 have "a' dvd b'^n" using dvd_trans[of a' "a'^n" "b'^n"] by simp
    hence th1: "a' dvd b'^m * b'" by (simp add: m mult.commute)
    from coprime_divprod[OF th1 coprime_exp[OF ab'(3), of m]]
    have "a' dvd b'" .
    hence "a'*?g dvd b'*?g" by simp
    with ab'(1,2)  have ?thesis by simp }
  ultimately show ?thesis by blast
qed

lemma divides_mul: assumes mr: "m dvd r" and nr: "n dvd r" and mn:"coprime m n"
  shows "m * n dvd r"
proof-
  from mr nr obtain m' n' where m': "r = m*m'" and n': "r = n*n'"
    unfolding dvd_def by blast
  from mr n' have "m dvd n'*n" by (simp add: mult.commute)
  hence "m dvd n'" using relprime_dvd_mult_iff[OF mn[unfolded coprime_def]] by simp
  then obtain k where k: "n' = m*k" unfolding dvd_def by blast
  from n' k show ?thesis unfolding dvd_def by auto
qed

text {* A binary form of the Chinese Remainder Theorem. *}

lemma chinese_remainder: assumes ab: "coprime a b" and a:"a \<noteq> 0" and b:"b \<noteq> 0"
  shows "\<exists>x q1 q2. x = u + q1 * a \<and> x = v + q2 * b"
proof-
  from bezout_add_strong[OF a, of b] bezout_add_strong[OF b, of a]
  obtain d1 x1 y1 d2 x2 y2 where dxy1: "d1 dvd a" "d1 dvd b" "a * x1 = b * y1 + d1"
    and dxy2: "d2 dvd b" "d2 dvd a" "b * x2 = a * y2 + d2" by blast
  from gcd_unique[of 1 a b, simplified ab[unfolded coprime_def], simplified]
    dxy1(1,2) dxy2(1,2) have d12: "d1 = 1" "d2 =1" by auto
  let ?x = "v * a * x1 + u * b * x2"
  let ?q1 = "v * x1 + u * y2"
  let ?q2 = "v * y1 + u * x2"
  from dxy2(3)[simplified d12] dxy1(3)[simplified d12]
  have "?x = u + ?q1 * a" "?x = v + ?q2 * b" by algebra+
  thus ?thesis by blast
qed

text {* Primality *}

text {* A few useful theorems about primes *}

lemma prime_0[simp]: "~prime 0" by (simp add: prime_def)
lemma prime_1[simp]: "~ prime 1"  by (simp add: prime_def)
lemma prime_Suc0[simp]: "~ prime (Suc 0)"  by (simp add: prime_def)

lemma prime_ge_2: "prime p ==> p \<ge> 2" by (simp add: prime_def)
lemma prime_factor: assumes n: "n \<noteq> 1" shows "\<exists> p. prime p \<and> p dvd n"
using n
proof(induct n rule: nat_less_induct)
  fix n
  assume H: "\<forall>m<n. m \<noteq> 1 \<longrightarrow> (\<exists>p. prime p \<and> p dvd m)" "n \<noteq> 1"
  let ?ths = "\<exists>p. prime p \<and> p dvd n"
  {assume "n=0" hence ?ths using two_is_prime by auto}
  moreover
  {assume nz: "n\<noteq>0"
    {assume "prime n" hence ?ths by - (rule exI[where x="n"], simp)}
    moreover
    {assume n: "\<not> prime n"
      with nz H(2)
      obtain k where k:"k dvd n" "k \<noteq> 1" "k \<noteq> n" by (auto simp add: prime_def)
      from dvd_imp_le[OF k(1)] nz k(3) have kn: "k < n" by simp
      from H(1)[rule_format, OF kn k(2)] obtain p where p: "prime p" "p dvd k" by blast
      from dvd_trans[OF p(2) k(1)] p(1) have ?ths by blast}
    ultimately have ?ths by blast}
  ultimately show ?ths by blast
qed

lemma prime_factor_lt: assumes p: "prime p" and n: "n \<noteq> 0" and npm:"n = p * m"
  shows "m < n"
proof-
  {assume "m=0" with n have ?thesis by simp}
  moreover
  {assume m: "m \<noteq> 0"
    from npm have mn: "m dvd n" unfolding dvd_def by auto
    from npm m have "n \<noteq> m" using p by auto
    with dvd_imp_le[OF mn] n have ?thesis by simp}
  ultimately show ?thesis by blast
qed

lemma euclid_bound: "\<exists>p. prime p \<and> n < p \<and>  p <= Suc (fact n)"
proof-
  have f1: "fact n + 1 \<noteq> 1" using fact_le[of n] by arith
  from prime_factor[OF f1] obtain p where p: "prime p" "p dvd fact n + 1" by blast
  from dvd_imp_le[OF p(2)] have pfn: "p \<le> fact n + 1" by simp
  {assume np: "p \<le> n"
    from p(1) have p1: "p \<ge> 1" by (cases p, simp_all)
    from divides_fact[OF p1 np] have pfn': "p dvd fact n" .
    from divides_add_revr[OF pfn' p(2)] p(1) have False by simp}
  hence "n < p" by arith
  with p(1) pfn show ?thesis by auto
qed

lemma euclid: "\<exists>p. prime p \<and> p > n" using euclid_bound by auto

lemma primes_infinite: "\<not> (finite {p. prime p})"
apply(simp add: finite_nat_set_iff_bounded_le)
apply (metis euclid linorder_not_le)
done

lemma coprime_prime: assumes ab: "coprime a b"
  shows "~(prime p \<and> p dvd a \<and> p dvd b)"
proof
  assume "prime p \<and> p dvd a \<and> p dvd b"
  thus False using ab gcd_greatest[of p a b] by (simp add: coprime_def)
qed
lemma coprime_prime_eq: "coprime a b \<longleftrightarrow> (\<forall>p. ~(prime p \<and> p dvd a \<and> p dvd b))"
  (is "?lhs = ?rhs")
proof-
  {assume "?lhs" with coprime_prime  have ?rhs by blast}
  moreover
  {assume r: "?rhs" and c: "\<not> ?lhs"
    then obtain g where g: "g\<noteq>1" "g dvd a" "g dvd b" unfolding coprime_def by blast
    from prime_factor[OF g(1)] obtain p where p: "prime p" "p dvd g" by blast
    from dvd_trans [OF p(2) g(2)] dvd_trans [OF p(2) g(3)]
    have "p dvd a" "p dvd b" . with p(1) r have False by blast}
  ultimately show ?thesis by blast
qed

lemma prime_coprime: assumes p: "prime p"
  shows "n = 1 \<or> p dvd n \<or> coprime p n"
using p prime_imp_relprime[of p n] by (auto simp add: coprime_def)

lemma prime_coprime_strong: "prime p \<Longrightarrow> p dvd n \<or> coprime p n"
  using prime_coprime[of p n] by auto

declare  coprime_0[simp]

lemma coprime_0'[simp]: "coprime 0 d \<longleftrightarrow> d = 1" by (simp add: coprime_commute[of 0 d])
lemma coprime_bezout_strong: assumes ab: "coprime a b" and b: "b \<noteq> 1"
  shows "\<exists>x y. a * x = b * y + 1"
proof-
  from ab b have az: "a \<noteq> 0" by - (rule ccontr, auto)
  from bezout_gcd_strong[OF az, of b] ab[unfolded coprime_def]
  show ?thesis by auto
qed

lemma bezout_prime: assumes p: "prime p"  and pa: "\<not> p dvd a"
  shows "\<exists>x y. a*x = p*y + 1"
proof-
  from p have p1: "p \<noteq> 1" using prime_1 by blast
  from prime_coprime[OF p, of a] p1 pa have ap: "coprime a p"
    by (auto simp add: coprime_commute)
  from coprime_bezout_strong[OF ap p1] show ?thesis .
qed
lemma prime_divprod: assumes p: "prime p" and pab: "p dvd a*b"
  shows "p dvd a \<or> p dvd b"
proof-
  {assume "a=1" hence ?thesis using pab by simp }
  moreover
  {assume "p dvd a" hence ?thesis by blast}
  moreover
  {assume pa: "coprime p a" from coprime_divprod[OF pab pa]  have ?thesis .. }
  ultimately show ?thesis using prime_coprime[OF p, of a] by blast
qed

lemma prime_divprod_eq: assumes p: "prime p"
  shows "p dvd a*b \<longleftrightarrow> p dvd a \<or> p dvd b"
using p prime_divprod dvd_mult dvd_mult2 by auto

lemma prime_divexp: assumes p:"prime p" and px: "p dvd x^n"
  shows "p dvd x"
using px
proof(induct n)
  case 0 thus ?case by simp
next
  case (Suc n)
  hence th: "p dvd x*x^n" by simp
  {assume H: "p dvd x^n"
    from Suc.hyps[OF H] have ?case .}
  with prime_divprod[OF p th] show ?case by blast
qed

lemma prime_divexp_n: "prime p \<Longrightarrow> p dvd x^n \<Longrightarrow> p^n dvd x^n"
  using prime_divexp[of p x n] divides_exp[of p x n] by blast

lemma coprime_prime_dvd_ex: assumes xy: "\<not>coprime x y"
  shows "\<exists>p. prime p \<and> p dvd x \<and> p dvd y"
proof-
  from xy[unfolded coprime_def] obtain g where g: "g \<noteq> 1" "g dvd x" "g dvd y"
    by blast
  from prime_factor[OF g(1)] obtain p where p: "prime p" "p dvd g" by blast
  from g(2,3) dvd_trans[OF p(2)] p(1) show ?thesis by auto
qed
lemma coprime_sos: assumes xy: "coprime x y"
  shows "coprime (x * y) (x\<^sup>2 + y\<^sup>2)"
proof-
  {assume c: "\<not> coprime (x * y) (x\<^sup>2 + y\<^sup>2)"
    from coprime_prime_dvd_ex[OF c] obtain p
      where p: "prime p" "p dvd x*y" "p dvd x\<^sup>2 + y\<^sup>2" by blast
    {assume px: "p dvd x"
      from dvd_mult[OF px, of x] p(3)
        obtain r s where "x * x = p * r" and "x\<^sup>2 + y\<^sup>2 = p * s"
          by (auto elim!: dvdE)
        then have "y\<^sup>2 = p * (s - r)"
          by (auto simp add: power2_eq_square diff_mult_distrib2)
        then have "p dvd y\<^sup>2" ..
      with prime_divexp[OF p(1), of y 2] have py: "p dvd y" .
      from p(1) px py xy[unfolded coprime, rule_format, of p] prime_1
      have False by simp }
    moreover
    {assume py: "p dvd y"
      from dvd_mult[OF py, of y] p(3)
        obtain r s where "y * y = p * r" and "x\<^sup>2 + y\<^sup>2 = p * s"
          by (auto elim!: dvdE)
        then have "x\<^sup>2 = p * (s - r)"
          by (auto simp add: power2_eq_square diff_mult_distrib2)
        then have "p dvd x\<^sup>2" ..
      with prime_divexp[OF p(1), of x 2] have px: "p dvd x" .
      from p(1) px py xy[unfolded coprime, rule_format, of p] prime_1
      have False by simp }
    ultimately have False using prime_divprod[OF p(1,2)] by blast}
  thus ?thesis by blast
qed

lemma distinct_prime_coprime: "prime p \<Longrightarrow> prime q \<Longrightarrow> p \<noteq> q \<Longrightarrow> coprime p q"
  unfolding prime_def coprime_prime_eq by blast

lemma prime_coprime_lt: assumes p: "prime p" and x: "0 < x" and xp: "x < p"
  shows "coprime x p"
proof-
  {assume c: "\<not> coprime x p"
    then obtain g where g: "g \<noteq> 1" "g dvd x" "g dvd p" unfolding coprime_def by blast
  from dvd_imp_le[OF g(2)] x xp have gp: "g < p" by arith
  from g(2) x have "g \<noteq> 0" by - (rule ccontr, simp)
  with g gp p[unfolded prime_def] have False by blast}
thus ?thesis by blast
qed

lemma prime_odd: "prime p \<Longrightarrow> p = 2 \<or> odd p" unfolding prime_def by auto

text {* One property of coprimality is easier to prove via prime factors. *}

lemma prime_divprod_pow:
  assumes p: "prime p" and ab: "coprime a b" and pab: "p^n dvd a * b"
  shows "p^n dvd a \<or> p^n dvd b"
proof-
  {assume "n = 0 \<or> a = 1 \<or> b = 1" with pab have ?thesis
      apply (cases "n=0", simp_all)
      apply (cases "a=1", simp_all) done}
  moreover
  {assume n: "n \<noteq> 0" and a: "a\<noteq>1" and b: "b\<noteq>1"
    then obtain m where m: "n = Suc m" by (cases n, auto)
    from divides_exp2[OF n pab] have pab': "p dvd a*b" .
    from prime_divprod[OF p pab']
    have "p dvd a \<or> p dvd b" .
    moreover
    {assume pa: "p dvd a"
      have pnba: "p^n dvd b*a" using pab by (simp add: mult.commute)
      from coprime_prime[OF ab, of p] p pa have "\<not> p dvd b" by blast
      with prime_coprime[OF p, of b] b
      have cpb: "coprime b p" using coprime_commute by blast
      from coprime_exp[OF cpb] have pnb: "coprime (p^n) b"
        by (simp add: coprime_commute)
      from coprime_divprod[OF pnba pnb] have ?thesis by blast }
    moreover
    {assume pb: "p dvd b"
      have pnba: "p^n dvd b*a" using pab by (simp add: mult.commute)
      from coprime_prime[OF ab, of p] p pb have "\<not> p dvd a" by blast
      with prime_coprime[OF p, of a] a
      have cpb: "coprime a p" using coprime_commute by blast
      from coprime_exp[OF cpb] have pnb: "coprime (p^n) a"
        by (simp add: coprime_commute)
      from coprime_divprod[OF pab pnb] have ?thesis by blast }
    ultimately have ?thesis by blast}
  ultimately show ?thesis by blast
qed

lemma nat_mult_eq_one: "(n::nat) * m = 1 \<longleftrightarrow> n = 1 \<and> m = 1" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume H: "?lhs"
  hence "n dvd 1" "m dvd 1" unfolding dvd_def by (auto simp add: mult.commute)
  thus ?rhs by auto
next
  assume ?rhs then show ?lhs by auto
qed

lemma power_Suc0: "Suc 0 ^ n = Suc 0"
  unfolding One_nat_def[symmetric] power_one ..

lemma coprime_pow: assumes ab: "coprime a b" and abcn: "a * b = c ^n"
  shows "\<exists>r s. a = r^n  \<and> b = s ^n"
  using ab abcn
proof(induct c arbitrary: a b rule: nat_less_induct)
  fix c a b
  assume H: "\<forall>m<c. \<forall>a b. coprime a b \<longrightarrow> a * b = m ^ n \<longrightarrow> (\<exists>r s. a = r ^ n \<and> b = s ^ n)" "coprime a b" "a * b = c ^ n"
  let ?ths = "\<exists>r s. a = r^n  \<and> b = s ^n"
  {assume n: "n = 0"
    with H(3) power_one have "a*b = 1" by simp
    hence "a = 1 \<and> b = 1" by simp
    hence ?ths
      apply -
      apply (rule exI[where x=1])
      apply (rule exI[where x=1])
      using power_one[of  n]
      by simp}
  moreover
  {assume n: "n \<noteq> 0" then obtain m where m: "n = Suc m" by (cases n, auto)
    {assume c: "c = 0"
      with H(3) m H(2) have ?ths apply simp
        apply (cases "a=0", simp_all)
        apply (rule exI[where x="0"], simp)
        apply (rule exI[where x="0"], simp)
        done}
    moreover
    {assume "c=1" with H(3) power_one have "a*b = 1" by simp
        hence "a = 1 \<and> b = 1" by simp
        hence ?ths
      apply -
      apply (rule exI[where x=1])
      apply (rule exI[where x=1])
      using power_one[of  n]
      by simp}
  moreover
  {assume c: "c\<noteq>1" "c \<noteq> 0"
    from prime_factor[OF c(1)] obtain p where p: "prime p" "p dvd c" by blast
    from prime_divprod_pow[OF p(1) H(2), unfolded H(3), OF divides_exp[OF p(2), of n]]
    have pnab: "p ^ n dvd a \<or> p^n dvd b" .
    from p(2) obtain l where l: "c = p*l" unfolding dvd_def by blast
    have pn0: "p^n \<noteq> 0" using n prime_ge_2 [OF p(1)] by simp
    {assume pa: "p^n dvd a"
      then obtain k where k: "a = p^n * k" unfolding dvd_def by blast
      from l have "l dvd c" by auto
      with dvd_imp_le[of l c] c have "l \<le> c" by auto
      moreover {assume "l = c" with l c  have "p = 1" by simp with p have False by simp}
      ultimately have lc: "l < c" by arith
      from coprime_lmul2 [OF H(2)[unfolded k coprime_commute[of "p^n*k" b]]]
      have kb: "coprime k b" by (simp add: coprime_commute)
      from H(3) l k pn0 have kbln: "k * b = l ^ n"
        by (auto simp add: power_mult_distrib)
      from H(1)[rule_format, OF lc kb kbln]
      obtain r s where rs: "k = r ^n" "b = s^n" by blast
      from k rs(1) have "a = (p*r)^n" by (simp add: power_mult_distrib)
      with rs(2) have ?ths by blast }
    moreover
    {assume pb: "p^n dvd b"
      then obtain k where k: "b = p^n * k" unfolding dvd_def by blast
      from l have "l dvd c" by auto
      with dvd_imp_le[of l c] c have "l \<le> c" by auto
      moreover {assume "l = c" with l c  have "p = 1" by simp with p have False by simp}
      ultimately have lc: "l < c" by arith
      from coprime_lmul2 [OF H(2)[unfolded k coprime_commute[of "p^n*k" a]]]
      have kb: "coprime k a" by (simp add: coprime_commute)
      from H(3) l k pn0 n have kbln: "k * a = l ^ n"
        by (simp add: power_mult_distrib mult.commute)
      from H(1)[rule_format, OF lc kb kbln]
      obtain r s where rs: "k = r ^n" "a = s^n" by blast
      from k rs(1) have "b = (p*r)^n" by (simp add: power_mult_distrib)
      with rs(2) have ?ths by blast }
    ultimately have ?ths using pnab by blast}
  ultimately have ?ths by blast}
ultimately show ?ths by blast
qed

text {* More useful lemmas. *}
lemma prime_product:
  assumes "prime (p * q)"
  shows "p = 1 \<or> q = 1"
proof -
  from assms have
    "1 < p * q" and P: "\<And>m. m dvd p * q \<Longrightarrow> m = 1 \<or> m = p * q"
    unfolding prime_def by auto
  from `1 < p * q` have "p \<noteq> 0" by (cases p) auto
  then have Q: "p = p * q \<longleftrightarrow> q = 1" by auto
  have "p dvd p * q" by simp
  then have "p = 1 \<or> p = p * q" by (rule P)
  then show ?thesis by (simp add: Q)
qed

lemma prime_exp: "prime (p^n) \<longleftrightarrow> prime p \<and> n = 1"
proof(induct n)
  case 0 thus ?case by simp
next
  case (Suc n)
  {assume "p = 0" hence ?case by simp}
  moreover
  {assume "p=1" hence ?case by simp}
  moreover
  {assume p: "p \<noteq> 0" "p\<noteq>1"
    {assume pp: "prime (p^Suc n)"
      hence "p = 1 \<or> p^n = 1" using prime_product[of p "p^n"] by simp
      with p have n: "n = 0"
        by (simp only: exp_eq_1 ) simp
      with pp have "prime p \<and> Suc n = 1" by simp}
    moreover
    {assume n: "prime p \<and> Suc n = 1" hence "prime (p^Suc n)" by simp}
    ultimately have ?case by blast}
  ultimately show ?case by blast
qed

lemma prime_power_mult:
  assumes p: "prime p" and xy: "x * y = p ^ k"
  shows "\<exists>i j. x = p ^i \<and> y = p^ j"
  using xy
proof(induct k arbitrary: x y)
  case 0 thus ?case apply simp by (rule exI[where x="0"], simp)
next
  case (Suc k x y)
  from Suc.prems have pxy: "p dvd x*y" by auto
  from prime_divprod[OF p pxy] have pxyc: "p dvd x \<or> p dvd y" .
  from p have p0: "p \<noteq> 0" by - (rule ccontr, simp)
  {assume px: "p dvd x"
    then obtain d where d: "x = p*d" unfolding dvd_def by blast
    from Suc.prems d  have "p*d*y = p^Suc k" by simp
    hence th: "d*y = p^k" using p0 by simp
    from Suc.hyps[OF th] obtain i j where ij: "d = p^i" "y = p^j" by blast
    with d have "x = p^Suc i" by simp
    with ij(2) have ?case by blast}
  moreover
  {assume px: "p dvd y"
    then obtain d where d: "y = p*d" unfolding dvd_def by blast
    from Suc.prems d  have "p*d*x = p^Suc k" by (simp add: mult.commute)
    hence th: "d*x = p^k" using p0 by simp
    from Suc.hyps[OF th] obtain i j where ij: "d = p^i" "x = p^j" by blast
    with d have "y = p^Suc i" by simp
    with ij(2) have ?case by blast}
  ultimately show ?case  using pxyc by blast
qed

lemma prime_power_exp: assumes p: "prime p" and n:"n \<noteq> 0"
  and xn: "x^n = p^k" shows "\<exists>i. x = p^i"
  using n xn
proof(induct n arbitrary: k)
  case 0 thus ?case by simp
next
  case (Suc n k) hence th: "x*x^n = p^k" by simp
  {assume "n = 0" with Suc have ?case by simp (rule exI[where x="k"], simp)}
  moreover
  {assume n: "n \<noteq> 0"
    from prime_power_mult[OF p th]
    obtain i j where ij: "x = p^i" "x^n = p^j"by blast
    from Suc.hyps[OF n ij(2)] have ?case .}
  ultimately show ?case by blast
qed

lemma divides_primepow: assumes p: "prime p"
  shows "d dvd p^k \<longleftrightarrow> (\<exists> i. i \<le> k \<and> d = p ^i)"
proof
  assume H: "d dvd p^k" then obtain e where e: "d*e = p^k"
    unfolding dvd_def  apply (auto simp add: mult.commute) by blast
  from prime_power_mult[OF p e] obtain i j where ij: "d = p^i" "e=p^j" by blast
  from prime_ge_2[OF p] have p1: "p > 1" by arith
  from e ij have "p^(i + j) = p^k" by (simp add: power_add)
  hence "i + j = k" using power_inject_exp[of p "i+j" k, OF p1] by simp
  hence "i \<le> k" by arith
  with ij(1) show "\<exists>i\<le>k. d = p ^ i" by blast
next
  {fix i assume H: "i \<le> k" "d = p^i"
    hence "\<exists>j. k = i + j" by arith
    then obtain j where j: "k = i + j" by blast
    hence "p^k = p^j*d" using H(2) by (simp add: power_add)
    hence "d dvd p^k" unfolding dvd_def by auto}
  thus "\<exists>i\<le>k. d = p ^ i \<Longrightarrow> d dvd p ^ k" by blast
qed

lemma coprime_divisors: "d dvd a \<Longrightarrow> e dvd b \<Longrightarrow> coprime a b \<Longrightarrow> coprime d e"
  by (auto simp add: dvd_def coprime)

lemma mult_inj_if_coprime_nat:
  "inj_on f A \<Longrightarrow> inj_on g B \<Longrightarrow> ALL a:A. ALL b:B. coprime (f a) (g b)
   \<Longrightarrow> inj_on (%(a,b). f a * g b::nat) (A \<times> B)"
apply(auto simp add:inj_on_def)
apply(metis coprime_def dvd_triv_left gcd_proj2_if_dvd_nat gcd_semilattice_nat.inf_commute relprime_dvd_mult)
apply(metis coprime_commute coprime_divprod dvd.neq_le_trans dvd_triv_right)
done

declare power_Suc0[simp del]

end


theory ex2_11 imports Main begin

datatype exp = Var | Const int | Add exp exp | Mult exp exp
fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval Var v = v" |
  "eval (Const i) _ = i" |
  "eval (Add e1 e2) v = eval e1 v + eval e2 v" |
  "eval (Mult e1 e2) v = eval e1 v * eval e2 v"

fun evalp_sub :: "int list \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int" where
  "evalp_sub [] _ _ = 0" |
  "evalp_sub (p#ps) x ith = p * (x ^ ith) + evalp_sub ps x (Suc ith)"
fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp xs v = evalp_sub xs v 0"

value "evalp [4,2,-1,3] 2"

fun add_p :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "add_p [] ys = ys" |
  "add_p xs [] = xs" |
  "add_p (x#xs) (y#ys) = (x+y)#(add_p xs ys)"
fun mult_p :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "mult_p [] ys = []" |
  "mult_p xs [] = []" |
  "mult_p (x#xs) ys = add_p (map (\<lambda>a. a*x) ys) (mult_p xs (0#ys))"
fun coeffs :: "exp \<Rightarrow> int list" where
  "coeffs Var = [0,1]" |
  "coeffs (Const i) = [i]" |
  "coeffs (Add e1 e2) = add_p (coeffs e1) (coeffs e2)" |
  "coeffs (Mult e1 e2) = mult_p (coeffs e1) (coeffs e2)"

value "evalp (coeffs (Mult Var Var)) (-2)"
value "eval (Mult Var Var) (-2)"

(*----------------------*)

lemma add_poly: "evalp_sub (add_p p1 p2) x px = evalp_sub p1 x px + evalp_sub p2 x px"
apply (induct p1 p2 arbitrary: px rule: "add_p.induct")
apply (auto simp add: algebra_simps)
done

lemma mult_const: "evalp_sub (map (\<lambda>a. a * const) ps) x px = const * (evalp_sub ps x px)"
apply (induct ps arbitrary: const x px)
apply (auto simp add: algebra_simps)
done

lemma unfold_poly: "evalp_sub ps x (Suc px) = x * (evalp_sub ps x px)"
apply (induct ps arbitrary: px)
apply (auto simp add: algebra_simps)
done

lemma mult_poly: "evalp_sub (mult_p p1 p2) x 0 = evalp_sub p1 x 0 * evalp_sub p2 x 0"
apply (induct p1 p2 rule: mult_p.induct)
apply (auto simp add: add_poly mult_const)
apply (simp add: algebra_simps)
apply (simp add: unfold_poly)
done

theorem th_2_11: "evalp (coeffs e) x = eval e x"
apply(induct e)
apply (auto simp add: add_poly mult_poly)
done

end


theory Chapter2
imports Main
begin

text \<open>
\section*{Chapter 2}

\exercise
Use the \textbf{value} command to evaluate the following expressions:
\<close>

value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"
value "[a,b] @ [c,d]"

text \<open>
\endexercise

\exercise
Recall the definition of our own addition function on @{typ nat}:
\<close>

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

text \<open>
Prove that @{const add} is associative and commutative.
You will need additional lemmas.
\<close>

lemma add_zero: "add n 0 = n"
  by(induction n, auto)

lemma add_succ: "Suc (add n m) = add n (Suc m)"
  by(induction n, auto)

lemma add_comm: "add m n = add n m"
  by(induction m, auto simp: add_zero add_succ)
(* your definition/proof here *)

text \<open> Define a recursive function \<close>

fun double :: "nat \<Rightarrow> nat" where
"double 0 = 0" |
"double (Suc n) = Suc(Suc(double n))"
(* your definition/proof here *)

text \<open> and prove that \<close>

lemma double_add: "double m = add m m"
  apply(induction m, auto)
  using add_succ by fastforce
(* your definition/proof here *)
text \<open>
\endexercise

\exercise
Define a function that counts the number of occurrences of
an element in a list:
\<close>

fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
"count [] x = 0" |
"count (x#xs) y = count xs y + (if x = y then 1 else 0)"

(* your definition/proof here *)
text \<open>
Test your definition of @{term count} on some examples.
Prove the following inequality:
\<close>

theorem "count xs x \<le> length xs"
  by(induction xs, auto)
(* your definition/proof here *)

text \<open>
\endexercise

\exercise
Define a function @{text snoc} that appends an element to the end of a list.
Do not use the existing append operator @{text "@"} for lists.
\<close>

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] v = [v]" |
"snoc (x#xs) v = x # snoc xs v"
(* your definition/proof here *)

text \<open>
Convince yourself on some test cases that your definition
of @{term snoc} behaves as expected.
With the help of @{text snoc} define a recursive function @{text reverse}
that reverses a list. Do not use the predefined function @{const rev}.
\<close>

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse [] = []" |
"reverse (x#xs) = snoc (reverse xs) x"

(* your definition/proof here *)

text \<open>
Prove the following theorem. You will need an additional lemma.
\<close>

lemma snoc_add_last: "snoc xs v = xs @ [v]"
  by(induction xs, auto)

lemma reverse_last_to_first: "reverse (xs@[v]) = v # reverse xs"
  by(induction xs, auto)

theorem "reverse (reverse xs) = xs"
  apply(induction xs)
   apply auto using snoc_add_last
  by (metis reverse_last_to_first)
(* your definition/proof here *)

text \<open>
\endexercise

\exercise
The aim of this exercise is to prove the summation formula
\[ \sum_{i=0}^{n}i = \frac{n(n+1)}{2} \]
Define a recursive function @{text "sum_upto n = 0 + ... + n"}:
\<close>

fun sum_upto :: "nat \<Rightarrow> nat" where
"sum_upto 0 = 0" |
"sum_upto (Suc n) = (Suc n)+sum_upto n"

(* your definition/proof here *)

text \<open>
Now prove the summation formula by induction on @{text "n"}.
First, write a clear but informal proof by hand following the examples
in the main text. Then prove the same property in Isabelle:
\<close>

lemma "sum_upto n = n * (n+1) div 2"
  by(induction n, auto)
(* your definition/proof here *)

text \<open>
\endexercise

\exercise
Starting from the type @{text "'a tree"} defined in the text, define
a function that collects all values in a tree in a list, in any order,
without removing duplicates.
\<close>

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = []" |
"contents (Node l v r) = v # (contents l) @ (contents r)"

(* your definition/proof here *)

text \<open>
Then define a function that sums up all values in a tree of natural numbers
\<close>

fun sum_tree :: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node l v r) = v + (sum_tree l) + (sum_tree r)"
(* your definition/proof here *)

text \<open> and prove \<close>

lemma "sum_tree t = sum_list(contents t)"
  by(induction t, auto)
(* your definition/proof here *)

text \<open>
\endexercise

\exercise
Define a new type @{text "'a tree2"} of binary trees where values are also
stored in the leaves of the tree.  Also reformulate the
@{text mirror} function accordingly. Define two functions
\<close>

datatype 'a tree2 = Tip 'a | Node "'a tree2" 'a "'a tree2"

fun mirror :: "'a tree2 \<Rightarrow> 'a tree2" where
"mirror (Tip v) = Tip v" |
"mirror (Node l v r) = Node (mirror r) v (mirror l)"

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
"pre_order (Tip v) = [v]" |
"pre_order (Node l v r) = v # (pre_order l) @ (pre_order r)"
(* your definition/proof here *)

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
"post_order (Tip v) = [v]" |
"post_order (Node l v r) = (post_order l) @ (post_order r) @ [v]"
(* your definition/proof here *)

text \<open>
that traverse a tree and collect all stored values in the respective order in
a list. Prove
\<close>

lemma "pre_order (mirror t) = rev (post_order t)"
  by(induction t, auto)
(* your definition/proof here *)

text \<open>
\endexercise

\exercise
Define a recursive function
\<close>

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse a [] = []
" |
"intersperse a [x] = [x]" |
"intersperse a (x#xs) = x#a#(intersperse a xs)"
(* your definition/proof here *)

text \<open>
such that @{text "intersperse a [x\<^sub>1, ..., x\<^sub>n] = [x\<^sub>1, a, x\<^sub>2, a, ..., a, x\<^sub>n]"}.
Prove
\<close>

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  by (induction a xs rule: intersperse.induct, auto)

(* your definition/proof here *)

text \<open>
\endexercise

\exercise
Write a tail-recursive variant of the @{text add} function on @{typ nat}:
\<close>

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd a 0 = a" |
"itadd a (Suc b) = itadd (Suc a) b"
(* your definition/proof here *)

text \<open>
Tail-recursive means that in the recursive case, @{const itadd} needs to call
itself directly: \mbox{@{term"itadd (Suc m) n"}} @{text"= itadd \<dots>"}.
Prove
\<close>

lemma itadd_suc_suc_itadd: "itadd (Suc m) n = Suc (itadd m n)"
  by(induction m n rule: itadd.induct, auto)

lemma "itadd m n = add m n"
  apply(induction m n rule: itadd.induct, auto simp: add_zero)
  using add_succ itadd_suc_suc_itadd by presburger

(* your definition/proof here *)

text \<open>
\endexercise

\exercise\label{exe:tree0}
Define a datatype @{text tree0} of binary tree skeletons which do not store
any information, neither in the inner nodes nor in the leaves.
Define a function that counts the number of all nodes (inner nodes and leaves)
in such a tree:
\<close>

datatype tree0 = Tip | Node tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
"nodes Tip = 1" |
"nodes (Node l r) = (nodes l) + (nodes r) + 1"
(* your definition/proof here *)

text \<open>
Consider the following recursive function:
\<close>

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t" |
"explode (Suc n) t = explode n (Node t t)"

value "explode 2 Tip"

text \<open>
Experiment how @{text explode} influences the size of a binary tree
and find an equation expressing the size of a tree after exploding it
(\noquotes{@{term [source] "nodes (explode n t)"}}) as a function
of @{term "nodes t"} and @{text n}. Prove your equation.
You may use the usual arithmetic operations including the exponentiation
operator ``@{text"^"}''. For example, \noquotes{@{prop [source] "2 ^ 2 = 4"}}.

Hint: simplifying with the list of theorems @{thm[source] algebra_simps}
takes care of common algebraic properties of the arithmetic operators.
\endexercise
\<close>

text \<open>

\exercise
Define arithmetic expressions in one variable over integers (type @{typ int})
as a data type:
\<close>

datatype exp = Var | Const int | Add exp exp | Mult exp exp

text \<open>
Define a function @{text eval} that evaluates an expression at some value:
\<close>

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var i = i" |
"eval (Const c) i = c" |
"eval (Add e1 e2) i = (eval e1 i) + (eval e2 i)" |
"eval (Mult e1 e2) i = (eval e1 i) * (eval e2 i)"
(* your definition/proof here *)

text \<open>
For example, @{prop"eval (Add (Mult (Const 2) Var) (Const 3)) i = 2*i+3"}.

A polynomial can be represented as a list of coefficients, starting with
the constant. For example, @{term "[4, 2, -1, 3::int]"} represents the
polynomial $4 + 2x - x^2 + 3x^3$.
Define a function @{text evalp} that evaluates a polynomial at a given value:
\<close>

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalp [] v = 0" |
"evalp (x#xs) v = x + (evalp xs v) * v"
(* your definition/proof here *)

text \<open>
Define a function @{text coeffs} that transforms an expression into a polynomial.
This will require auxiliary functions.
\<close>

fun multdown :: "exp \<Rightarrow> exp" where
"multdown Var = Var" |
"multdown (Const c) = Const c" |
"multdown (Add e1 e2) = Add (multdown e1) (multdown e2)" |
"multdown (Mult (Const c) (Add e1 e2)) = Add (Mult (Const c) e1) (Mult (Const c) e2)" |
"multdown (Mult (Add e1 e2) (Const c)) = multdown (Mult (Const c) (Add e1 e2))" |
"multdown (Mult Var (Add e1 e2)) = Add (Mult Var e1) (Mult Var  e2)" |
"multdown (Mult (Add e1 e2) Var) = multdown (Mult Var (Add e1 e2))" |
"multdown (Mult e1 e2) = Mult (multdown e1) (multdown e2)"

fun transexpr :: "exp \<Rightarrow> exp" where
"transexpr Var = Var" |
"transexpr (Const c) = (Const c)" |
"transexpr (Mult (Add e1 e2) (Const c)) = transexpr (Mult (Const c) (Add e1 e2))" |
"transexpr ((Const c) Mult (Add e1 e2)) = Add (Mult (Const c) e1) (Mult (Const c) e2)" |
"transexpr (Mult Var (Add e1 e2)) = transexpr (Mult (Add e1 e2) Var)" |
"transexpr (Mult (Add e1 e2) Var) = Add (Mult e1 Var) (Mult e2 Var)"

fun coeffs :: "exp \<Rightarrow> int list" where
(* your definition/proof here *)

text \<open>
Prove that @{text coeffs} preserves the value of the expression:
\<close>

theorem evalp_coeffs: "evalp (coeffs e) x = eval e x"
(* your definition/proof here *)

text \<open>
Hint: consider the hint in Exercise~\ref{exe:tree0}.
\endexercise
\<close>

end


theory Chapter2
imports Main
begin

text \<open>
\section*{Chapter 2}

\exercise
Use the \textbf{value} command to evaluate the following expressions:
\<close>

value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"
value "[a,b] @ [c,d]"

text \<open>
\endexercise

\exercise
Recall the definition of our own addition function on @{typ nat}:
\<close>

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

text \<open>
Prove that @{const add} is associative and commutative.
You will need additional lemmas.
\<close>

lemma add_nil2 [simp]: "add m 0 = m"
  apply (induction m)
   apply auto
  done

lemma add_Suc2 [simp]: "add m (Suc n) = Suc (add m n)"
  apply (induction m)
   apply auto
  done

lemma add_comm: "add m n = add n m"
  apply (induction m)
   apply auto
  done

text \<open> Define a recursive function \<close>

fun double :: "nat \<Rightarrow> nat" where
  "double 0 = 0" |
  "double (Suc n) = Suc (Suc (double n))"

text \<open> and prove that \<close>

lemma double_add: "double m = add m m"
  apply (induction m)
   apply auto
  done

text \<open>
\endexercise

\exercise
Define a function that counts the number of occurrences of
an element in a list:
\<close>

fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
  "count [] _ = 0" |
  "count (x # xs) y = (if x = y then Suc (count xs y) else count xs y)"

text \<open>
Test your definition of @{term count} on some examples.
Prove the following inequality:
\<close>

theorem "count xs x \<le> length xs"
  apply (induction xs)
   apply auto
  done

text \<open>
\endexercise

\exercise
Define a function @{text snoc} that appends an element to the end of a list.
Do not use the existing append operator @{text "@"} for lists.
\<close>

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc [] a = [a]" |
  "snoc (x # xs) a = x # snoc xs a"

text \<open>
Convince yourself on some test cases that your definition
of @{term snoc} behaves as expected.
With the help of @{text snoc} define a recursive function @{text reverse}
that reverses a list. Do not use the predefined function @{const rev}.
\<close>

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse [] = []" |
  "reverse (x # xs) = snoc (reverse xs) x"

text \<open>
Prove the following theorem. You will need an additional lemma.
\<close>
lemma reverse_snoc [simp]: "reverse (snoc xs x) = x # reverse xs"
  apply (induction xs)
   apply auto
  done

theorem "reverse (reverse xs) = xs"
  apply (induction xs)
   apply auto
  done

text \<open>
\endexercise

\exercise
The aim of this exercise is to prove the summation formula
\[ \sum_{i=0}^{n}i = \frac{n(n+1)}{2} \]
Define a recursive function @{text "sum_upto n = 0 + ... + n"}:
\<close>

fun sum_upto :: "nat \<Rightarrow> nat" where
  "sum_upto 0 = 0" |
  "sum_upto (Suc n) = (Suc n) + (sum_upto n)"

text \<open>
Now prove the summation formula by induction on @{text "n"}.
First, write a clear but informal proof by hand following the examples
in the main text. Then prove the same property in Isabelle:
\<close>

lemma "sum_upto n = n * (n+1) div 2"
  apply (induction n)
   apply auto
  done

text \<open>
\endexercise

\exercise
Starting from the type @{text "'a tree"} defined in the text, define
a function that collects all values in a tree in a list, in any order,
without removing duplicates.
\<close>

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
  "contents Tip = []" |
  "contents (Node l x r) = x # contents l @ contents r"

text \<open>
Then define a function that sums up all values in a tree of natural numbers
\<close>

fun sum_tree :: "nat tree \<Rightarrow> nat" where
  "sum_tree Tip = 0" |
  "sum_tree (Node l n r) = n + sum_tree l + sum_tree r"

text \<open> and prove \<close>

lemma "sum_tree t = sum_list(contents t)"
  apply (induction t)
   apply auto
  done

text \<open>
\endexercise

\exercise
Define a new type @{text "'a tree2"} of binary trees where values are also
stored in the leaves of the tree.  Also reformulate the
@{text mirror} function accordingly. Define two functions \<close>

datatype 'a tree2 = Tip 'a | Node "'a tree2" 'a "'a tree2"

primrec mirror :: "'a tree2 \<Rightarrow> 'a tree2" where
  "mirror (Tip a) = (Tip a)" |
  "mirror (Node l a r) = Node (mirror r) a (mirror l)"

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
  "pre_order (Tip a) = [a]" |
  "pre_order (Node l a r) = a # pre_order l @ pre_order r"

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
  "post_order (Tip a) = [a]" |
  "post_order (Node l a r) = post_order l @ post_order r @ [a]"

text \<open>
that traverse a tree and collect all stored values in the respective order in
a list. Prove \<close>

lemma "pre_order (mirror t) = rev (post_order t)"
  apply (induction t)
   apply auto
  done

text \<open>
\endexercise

\exercise
Define a recursive function
\<close>

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intersperse _ [] = []" |
  "intersperse _ [x] = [x]" |
  "intersperse a (x # xs) = x # a # intersperse a xs"

text \<open>
such that @{text "intersperse a [x\<^sub>1, ..., x\<^sub>n] = [x\<^sub>1, a, x\<^sub>2, a, ..., a, x\<^sub>n]"}.
Prove
\<close>

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs rule: intersperse.induct)
    apply auto
  done

text \<open>
\endexercise

\exercise
Write a tail-recursive variant of the @{text add} function on @{typ nat}:
\<close>

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "itadd m 0 = m" |
  "itadd m (Suc n) = itadd (Suc m) n"

text \<open>
Tail-recursive means that in the recursive case, @{const itadd} needs to call
itself directly: \mbox{@{term"itadd (Suc m) n"}} @{text"= itadd \<dots>"}.
Prove
\<close>

lemma "itadd m (Suc n) = Suc (add m n)"
  apply (induction n arbitrary: m)
   apply auto
  done

lemma "itadd m n = add m n"
  apply (induction n arbitrary: m)
   apply auto
  done

text \<open>
\endexercise

\exercise\label{exe:tree0}
Define a datatype @{text tree0} of binary tree skeletons which do not store
any information, neither in the inner nodes nor in the leaves.
Define a function that counts the number of all nodes (inner nodes and leaves)
in such a tree:
\<close>

datatype tree0 = Tip | Node "tree0" "tree0"

fun nodes :: "tree0 \<Rightarrow> nat" where
  "nodes Tip = 1" |
  "nodes (Node l r) = 1 + nodes l + nodes r"

text \<open>
Consider the following recursive function:
\<close>

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t" |
"explode (Suc n) t = explode n (Node t t)"

text \<open>
Experiment how @{text explode} influences the size of a binary tree
and find an equation expressing the size of a tree after exploding it
(\noquotes{@{term [source] "nodes (explode n t)"}}) as a function
of @{term "nodes t"} and @{text n}. Prove your equation.
You may use the usual arithmetic operations including the exponentiation
operator ``@{text"^"}''. For example, \noquotes{@{prop [source] "2 ^ 2 = 4"}}.

Hint: simplifying with the list of theorems @{thm[source] algebra_simps}
takes care of common algebraic properties of the arithmetic operators.
\endexercise
\<close>

lemma "nodes (explode n t) = (2 ^ n - 1) + (2 ^ n) * nodes t"
  apply (induction n arbitrary: t)
   apply (simp_all add: algebra_simps)
  done

text \<open>

\exercise
Define arithmetic expressions in one variable over integers (type @{typ int})
as a data type:
\<close>

datatype exp = Var | Const int | Add exp exp | Mult exp exp

text \<open>
Define a function @{text eval} that evaluates an expression at some value:
\<close>

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval Var x = x" |
  "eval (Const c) _ = c" |
  "eval (Add a b) x = eval a x + eval b x" |
  "eval (Mult a b) x = eval a x * eval b x"

text \<open>
For example, @{prop "eval (Add (Mult (Const 2) Var) (Const 3)) i = 2*i+3"}.

A polynomial can be represented as a list of coefficients, starting with
the constant. For example, @{term "[4, 2, -1, 3::int]"} represents the
polynomial $4 + 2x - x^2 + 3x^3$.
Define a function @{text evalp} that evaluates a polynomial at a given value:
\<close>

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp [] x = 0" |
  "evalp (a # as) x = a + x * evalp as x"

text \<open>
Define a function @{text coeffs} that transforms an expression into a polynomial.
This will require auxiliary functions.
\<close>

fun add_list :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "add_list [] ys = ys" |
  "add_list xs [] = xs" |
  "add_list (x # xs) (y # ys) = (x + y) # add_list xs ys"

definition mul_c_list :: "int list \<Rightarrow> int \<Rightarrow> int list" where
  "mul_c_list a c = map ((*) c) a"

lemma [simp]: "evalp (mul_c_list a c) x = c * evalp a x"
  apply (induction a)
   apply (auto simp add: mul_c_list_def algebra_simps)
  done

primrec mul_list :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "mul_list [] ys = []" |
  "mul_list (x # xs) ys = add_list (mul_c_list ys x) (0 # mul_list xs ys)"

lemma [simp]: "evalp (mul_list a b) x = evalp a x * evalp b x"
  apply (induction a arbitrary: b)
   apply (auto simp add: algebra_simps)
  done

fun coeffs :: "exp \<Rightarrow> int list" where
  "coeffs Var = [0, 1]" |
  "coeffs (Const c) = [c]" |
  "coeffs (Add a b) = add_list (coeffs a) (coeffs b)" |
  "coeffs (Mult a b) = mul_list (coeffs a) (coeffs b)"

text \<open>
Prove that @{text coeffs} preserves the value of the expression:
\<close>

theorem evalp_coeffs: "evalp (coeffs e) x = eval e x"
  apply (induction e)
     apply auto
  done

text \<open>
Hint: consider the hint in Exercise~\ref{exe:tree0}.
\endexercise
\<close>

end


theory Exercises2_10
  imports Main
begin

(*---------------- Exercise 2.10----------------*)
(* binary tree datatype *)
datatype tree0 = Leaf | Node "tree0" "tree0"

(* function to count nodes *)
fun nodes :: "tree0 \<Rightarrow> nat" where
"nodes Leaf = (Suc 0)" |
"nodes (Node a b) = 1 + nodes a + nodes b"

(* explode function *)
fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t" |
"explode (Suc n) t = explode n (Node t t)"

(* finding equation, for c = nodes t
n = 0, c
n = 1, 2*c + 1
n = 2, 4*c + 2 + 1
arbitrary n, 2^n*c + 2^{n-1} + 2^{n-2} + ... 2^{0}
            \<Rightarrow> 2^n*c + 2^n - 1 (sum of progression)
 *)
theorem explode_count : "nodes(explode n t) = 2^n*(nodes t + 1) - 1"
  apply(induction n arbitrary: t)
  apply(auto)
  apply(simp add: algebra_simps)
  done

end


theory Chapter2
  imports Main
begin

(* Exercise 2.1. Use the value command to evaluate the following expressions:
"1 + (2::nat )", "1 + (2::int )", "1 − (2::nat )" and "1 − (2::int )". *)

value "1 + (2::nat )"
value "1 + (2::int )"
value "1 - (2::nat )"
value "1 - (2::int )"

(* Exercise 2.2. Start from the definition of add given above. Prove that add
is associative and commutative. Define a recursive function double :: nat \<Rightarrow>
nat and prove double m = add m m. *)

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc (add m n)"

lemma add_02 [simp]: "add m 0 = m"
  apply(induction m)
   apply(auto)
  done

lemma add_succ [simp]: "add n (Suc m) = Suc (add n m)"
  apply(induction n)
   apply(auto)
  done

lemma add_assoc [simp]: "add (add x y) z = add x (add y z)"
  apply(induction x)
   apply(auto)
  done

lemma add_comm [simp]: "add x y = add y x"
  apply(induction x)
   apply(auto)
  done

fun double :: "nat \<Rightarrow> nat" where
"double 0 = 0" |
"double (Suc m) = Suc (Suc (double m))"

lemma double_equals_add_self [simp]: "double m = add m m"
  apply(induction m)
   apply(auto)
  done

(* Exercise 2.3. Define a function count :: 0 a \<Rightarrow> 0 a list \<Rightarrow> nat that counts the
number of occurrences of an element in a list. Prove count x xs 6 length xs. *)

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count x [] = 0" |
"count x xs = (if x = hd(xs) then Suc (count x (tl xs)) else count x (tl xs))"

lemma count_lt_length [simp]: "count x xs \<le> length xs"
  apply(induction xs)
   apply(auto)
  done

(* Exercise 2.4. Define a recursive function snoc :: 0 a list \<Rightarrow> 0 a \<Rightarrow> 0 a list
that appends an element to the end of a list. With the help of snoc define
a recursive function reverse :: 0 a list \<Rightarrow> 0 a list that reverses a list. Prove
reverse (reverse xs) = xs. *)

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] x = [x]" |
"snoc (x # xs) y = x # (snoc xs y)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse [] = []" |
"reverse (x # xs) = snoc (reverse xs) x"

lemma reverse_snoc [simp]: "reverse (snoc xs x) = x # (reverse xs)"
  apply(induction xs)
   apply(auto)
  done

lemma reverse_reverse_identity [simp]: "reverse (reverse xs) = xs"
  apply(induction xs)
   apply(auto)
  done

(* Exercise 2.5. Define a recursive function sum_upto :: nat \<Rightarrow> nat such that
sum_upto n = 0 + ... + n and prove sum_upto n = n \<^emph> (n + 1) div 2. *)

fun sum_upto :: "nat \<Rightarrow> nat" where
"sum_upto 0 = 0" |
"sum_upto (Suc n) =(Suc n) + (sum_upto n)"

lemma sum_upto_equals [simp]: "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
   apply(auto)
  done

(* Exercise 2.6. Starting from the type 'a tree defined in the text, define a
function contents :: 'a tree \<Rightarrow> 'a list that collects all values in a tree in a list,
in any order, without removing duplicates. Then define a function sum_tree
:: nat tree \<Rightarrow> nat that sums up all values in a tree of natural numbers and
prove sum_tree t = sum_list (contents t ) (where sum_list is predefined). *)

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = []" |
"contents (Node l a r) =  a # contents(l) @ contents(r)"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node l a r) = a + sum_tree(l) + sum_tree(r)"

lemma "sum_tree t = sum_list (contents t)"
  apply(induction t)
   apply(auto)
  done

(* Exercise 2.7. Define a new type 'a tree2 of binary trees where values are
also stored in the leaves of the tree. Also reformulate the mirror function
accordingly. Define two functions pre_order and post_order of type 'a tree2
\<Rightarrow> 'a list that traverse a tree and collect all stored values in the respective
order in a list. Prove pre_order (mirror t ) = rev (post_order t ). *)

datatype 'a tree2 = Leaf 'a | Node 'a "'a tree2" "'a tree2"

fun mirror :: "'a tree2 \<Rightarrow> 'a tree2" where
"mirror (Leaf a) = Leaf a" |
"mirror (Node a l r) = Node a (mirror r) (mirror l)"

(* pre_order traversal: root, left, right *)
fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
"pre_order (Leaf a) = [a]" |
"pre_order (Node a l r) = [a] @ (pre_order l) @ (pre_order r)"

(* post_order traversal: left, right, root *)
fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
"post_order (Node a l r) = (post_order l) @ (post_order r) @ [a]" |
"post_order (Leaf a) = [a]"

lemma pre_order_mirror_equal_rev_post_order [simp]: "pre_order (mirror t) = rev (post_order t)"
  apply(induction t)
   apply(auto)
  done

(* Exercise 2.8. Define a function intersperse :: 'a \<Rightarrow> 'a list \<Rightarrow> 'a list such
that intersperse a [x 1 , ..., x n ] = [x 1 , a, x 2 , a, ..., a, x n ]. Now prove that
map f (intersperse a xs) = intersperse (f a) (map f xs). *)

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse a [] = []" |
"intersperse a (x # xs) = [x, a] @ (intersperse a xs)"

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs)
   apply(auto)
  done

(* Exercise 2.9. Write a tail-recursive variant of the add function on nat :
itadd. Tail-recursive means that in the recursive case, itadd needs to call
itself directly: itadd (Suc m) n = itadd . . .. Prove itadd m n = add m n. *)

lemma add_suc [simp]: "add m (Suc n) = Suc(add m n)"
  apply(induction m)
   apply(auto)
  done

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd 0       m = m" |
"itadd (Suc m) n = itadd m (Suc n)"

value "itadd 3 2"

lemma "itadd m n = add m n"
  apply(induction m arbitrary: n)
   apply(auto)
  done

(* Exercise 2.10. Define a datatype tree0 of binary tree skeletons which do not
store any information, neither in the inner nodes nor in the leaves. Define a
function nodes :: tree0 \<Rightarrow> nat that counts the number of all nodes (inner
nodes and leaves) in such a tree. Consider the following recursive function:
fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t" |
"explode (Suc n) t = explode n (Node t t )"
Find an equation expressing the size of a tree after exploding it (nodes
(explode n t )) as a function of nodes t and n. Prove your equation. You
may use the usual arithmetic operators, including the exponentiation opera-
tor “^”. For example, 2 ^ 2 = 4.
Hint: simplifying with the list of theorems algebra_simps takes care of
common algebraic properties of the arithmetic operators. *)

datatype tree0 = Leaf | Node tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
"nodes (Leaf)     = 1" |
"nodes (Node l r) = Suc (nodes l + nodes r)"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t       = t" |
"explode (Suc n) t = explode n (Node t t)"

(* Experimenting with explode and nodes *)

(* n is 1,2,3, and size of tree is 3 *)
value "nodes (Node (Leaf) (Leaf) :: tree0)"             (* 3 *)
value "nodes (explode 1 (Node (Leaf) (Leaf) :: tree0))" (* 7 *)
value "nodes (explode 2 (Node (Leaf) (Leaf) :: tree0))" (* 15 *)
value "nodes (explode 3 (Node (Leaf) (Leaf) :: tree0))" (* 31 *)

(* n is 1,2,3, and size of tree is 5 *)
value "nodes (Node (Node Leaf Leaf) (Leaf) :: tree0)"             (* 5 *)
value "nodes (explode 1 (Node (Node Leaf Leaf) (Leaf) :: tree0))" (* 11 *)
value "nodes (explode 2 (Node (Node Leaf Leaf) (Leaf) :: tree0))" (* 23 *)
value "nodes (explode 3 (Node (Node Leaf Leaf) (Leaf) :: tree0))" (* 47 *)

(* It seems that the formula is 2^n * (tree nodes count) + (2^n - 1) *)

theorem "let c = nodes t in (nodes (explode n t)) = (2^n * c) + (2^n - 1)"
  apply (simp add: Let_def)
  apply (induction n arbitrary: t)
   apply(auto simp add: algebra_simps)
  done

(* Exercise 2.11. Define arithmetic expressions in one variable over integers
(type int ) as a data type:
datatype exp = Var | Const int | Add exp exp | Mult exp exp
Define a function eval :: exp \<Rightarrow> int \<Rightarrow> int such that eval e x evaluates e at
the value x.
A polynomial can be represented as a list of coefficients, starting with the
constant. For example, [4, 2, − 1, 3] represents the polynomial 4+2x−x 2 +3x 3 .
Define a function evalp :: int list \<Rightarrow> int \<Rightarrow> int that evaluates a polynomial at
the given value. Define a function coeffs :: exp \<Rightarrow> int list that transforms an
expression into a polynomial. This may require auxiliary functions. Prove that
coeffs preserves the value of the expression: evalp (coeffs e) x = eval e x.
Hint: consider the hint in Exercise 2.10. *)

end


(* Title:      Residuated Lattices
   Author:     Victor Gomes <vborgesferreiragomes1 at sheffield.ac.uk>
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

theory Residuated_Lattices
  imports Kleene_Algebra.Signatures
begin

notation
  times (infixl "\<cdot>" 70)

unbundle lattice_syntax

section \<open>Residuated Lattices\<close>

subsection \<open>Residuated Functions on a Partial Order\<close>

text \<open>
  We follow Galatos and \emph{al.} to define residuated funtions on
  partial orders. Material from articles by Maddux, and J{\'o}sson and Tsinakis are also considered.

  This development should in the future be expanded to functions or categories where the sources and targets have
  different type.

  Let $P$ be a partial order, or a poset.
  A map $f : P \to P$ is residuated if there exists a map
  $g: P \to P$ such that $f(x) \le y \Leftrightarrow x \le g(y)$
  for all $x, y \in P$.
  That is, they are adjoints of a Galois connection.
\<close>

context order begin

definition residuated_pair :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "residuated_pair f g \<equiv> \<forall>x y. f(x) \<le> y \<longleftrightarrow> x \<le> g(y)"

theorem residuated_pairI [intro]:
  assumes "\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"
  and "\<forall>x y. x \<le> y \<longrightarrow> g x \<le> g y"
  and "\<forall>x. x \<le> (g o f) x"
  and "\<forall>x. (f o g) x \<le> x"
  shows "residuated_pair f g"
  by (metis assms comp_apply local.order_trans residuated_pair_def antisym)

definition residuated :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "residuated f \<equiv> \<exists>g. residuated_pair f g"

text \<open>
  If a map $f$ is residuated, then its residual $g$ is unique.
\<close>

lemma residual_unique: "residuated f \<Longrightarrow> \<exists>!g. residuated_pair f g"
  unfolding residuated_def residuated_pair_def
  by (metis ext eq_refl order.antisym)

text \<open>
  Since the residual of a map $f$ is unique, it makes sense to
  define a residual operator.
\<close>

definition residual :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "residual f \<equiv> THE g. residuated_pair f g"

lemma residual_galois: "residuated f \<Longrightarrow> f(x) \<le> y \<longleftrightarrow> x \<le> residual f y"
  apply (clarsimp simp: residuated_def residuated_pair_def)
  apply (subgoal_tac "residual f = g")
  apply (simp_all add: residual_def)
  apply (rule the1_equality)
  apply (metis residuated_def residuated_pair_def residual_unique)
  by (simp add: residuated_pair_def)

lemma residual_galoisI1: "residuated f \<Longrightarrow> f(x) \<le> y \<Longrightarrow> x \<le> residual f y"
  by (metis residual_galois)

lemma residual_galoisI2: "residuated f \<Longrightarrow> x \<le> residual f y \<Longrightarrow> f(x) \<le> y"
  by (metis residual_galois)

text \<open>
  A closure operator on a poset is a map that is expansive, isotone and
  idempotent.
  The composition of the residual of a function $f$ with $f$ is a closure operator.
\<close>

definition closure :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "closure f \<equiv> (\<forall>x. x \<le> f x) \<and> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y) \<and> (\<forall>x. f(f x) = f x)"

lemma res_c1: "residuated f \<Longrightarrow> x \<le> residual f (f x)"
  by (metis local.order.refl residual_galois)

lemma res_c2: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> residual f (f x) \<le> residual f (f y)"
  by (metis local.order.refl local.order_trans residual_galois)

lemma res_c3: "residuated f \<Longrightarrow> residual f (f (residual f (f x))) = residual f (f x)"
  by (metis order.eq_iff local.order_trans res_c1 residual_galois)

lemma res_closure: "residuated f \<Longrightarrow> closure (residual f o f)"
  by (auto simp: closure_def intro: res_c1 res_c2 res_c3)

text \<open>
  Dually, an interior operator on a poset is a map that is contractive, isotone and
  idempotent.
  The composition of $f$ with its residual is an interior operator.
\<close>

definition interior :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "interior f \<equiv> (\<forall>x. f x \<le> x) \<and> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y) \<and> (\<forall>x. f(f x) = f x)"

lemma res_i1: "residuated f \<Longrightarrow> f (residual f x) \<le> x"
  by (metis local.order.refl residual_galois)

lemma res_i2: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> f (residual f x) \<le> f (residual f y)"
  by (metis local.order.refl local.order_trans residual_galois)

lemma res_i3: "residuated f \<Longrightarrow> f (residual f (f (residual f x))) = f (residual f x)"
  by (metis local.antisym_conv res_c1 res_c3 res_i1 residual_galois)

lemma res_interior: "residuated f \<Longrightarrow> interior (f o residual f)"
  by (auto simp: interior_def intro: res_i1 res_i2 res_i3)

text \<open>Next we show a few basic lemmas about residuated maps.\<close>

lemma res_iso: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis local.order.trans res_c1 residual_galois)

lemma res_residual_iso: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> residual f x \<le> residual f y"
  by (metis local.order.trans res_i1 residual_galois)

lemma res_comp1 [simp]: "residuated f \<Longrightarrow> f o residual f o f = f"
proof -
  assume resf: "residuated f"
  {
    fix x
    have "(f o residual f o f) x = f x"
      by (metis resf comp_apply order.eq_iff res_c1 res_i1 res_iso)
  }
  thus ?thesis
    by (metis ext)
qed

lemma res_comp2 [simp]: "residuated f \<Longrightarrow> residual f o f o residual f = residual f"
proof -
  assume resf: "residuated f"
  {
    fix x
    have "(residual f o f o residual f) x = residual f x"
      by (metis resf comp_apply order.eq_iff res_c1 res_i1 res_residual_iso)
  }
  thus ?thesis
    by (metis ext)
qed

end (* order *)

text \<open>
  A residuated function $f$ preserves all existing joins.
  Dually, its residual preserves all existing meets.
  We restrict our attention to semilattices, where binary joins or meets exist, and to
  complete lattices, where arbitrary joins and meets exist.
\<close>

lemma (in semilattice_sup) residuated_sup: "residuated f \<Longrightarrow> f (x \<squnion> y) = f x \<squnion> f y"
proof (rule order.antisym)
  assume assm: "residuated f"
  thus "f (x \<squnion> y) \<le> f x \<squnion> f y"
    by (metis local.residual_galoisI1 local.residual_galoisI2 local.sup.bounded_iff local.sup_ge1 local.sup_ge2)
  show "f x \<squnion> f y \<le> f (x \<squnion> y)"
    by (metis assm local.res_iso local.sup.bounded_iff local.sup_ge1 local.sup_ge2)
qed

lemma (in semilattice_inf) residuated_inf: "residuated f \<Longrightarrow> residual f (x \<sqinter> y) = residual f x \<sqinter> residual f y"
proof (rule order.antisym)
  assume assm: "residuated f"
  thus "residual f (x \<sqinter> y) \<le> residual f x \<sqinter> residual f y"
    by (metis local.inf.boundedI local.inf.cobounded1 local.inf.cobounded2 local.res_residual_iso)
  show "residual f x \<sqinter> residual f y \<le> residual f (x \<sqinter> y)"
    by (metis assm local.inf.bounded_iff local.inf.cobounded1 local.inf.cobounded2 local.residual_galoisI1 local.residual_galoisI2)
qed

context bounded_lattice begin

lemma residuated_strict: "residuated f \<Longrightarrow> f \<bottom> = \<bottom>"
  by (metis local.bot_least local.bot_unique local.res_i1 local.res_iso)

lemma res_top: "residuated f \<Longrightarrow> residual f \<top> = \<top>"
  by (metis local.residual_galoisI1 local.top_greatest local.top_unique)

end

context complete_lattice begin

text \<open>
  On a complete lattice, a function $f$ is residuated if and only if
  it preserves arbitrary (possibly infinite) joins.
  Dually, a function $g$ is a residual of a residuated funtion $f$
  if and only if $g$ preserver arbitrary meets.
\<close>

lemma residual_eq1: "residuated f \<Longrightarrow> residual f y = \<Squnion> {x. f x \<le> y}"
proof (rule order.antisym)
  assume assm: "residuated f"
  thus "residual f y \<le> \<Squnion>{x. f x \<le> y}"
    by (auto simp: res_i1 intro!: Sup_upper)
  show "\<Squnion>{x. f x \<le> y} \<le> residual f y"
    by (auto simp: assm intro!: Sup_least residual_galoisI1)
qed

lemma residual_eq2: "residuated f \<Longrightarrow> f x = \<Sqinter> {y. x \<le> residual f y}"
proof (rule order.antisym)
  assume assm: "residuated f"
  thus "f x \<le> \<Sqinter>{y. x \<le> residual f y}"
    by (auto intro: Inf_greatest residual_galoisI2)
  show "\<Sqinter>{y. x \<le> residual f y} \<le> f x"
    using assm by (auto simp: res_c1 intro!: Inf_lower)
qed

lemma residuated_Sup: "residuated f \<Longrightarrow> f(\<Squnion> X) = \<Squnion>{f x | x. x \<in> X}"
proof (rule order.antisym)
  assume assm: "residuated f"
  obtain y where y_def: "y = \<Squnion>{f x |x. x \<in> X}"
    by auto
  hence "\<forall>x \<in> X. f x \<le> y"
    by (auto simp: y_def intro: Sup_upper)
  hence "\<forall>x \<in> X. x \<le> residual f y"
    by (auto simp: assm intro!: residual_galoisI1)
  hence "\<Squnion>X \<le> residual f y"
    by (auto intro: Sup_least)
  thus "f(\<Squnion> X) \<le> \<Squnion>{f x |x. x \<in> X}"
    by (metis y_def assm residual_galoisI2)
qed (clarsimp intro!: Sup_least res_iso Sup_upper)

lemma residuated_Inf: "residuated f \<Longrightarrow> residual f(\<Sqinter> X) = \<Sqinter>{residual f x | x. x \<in> X}"
proof (rule order.antisym, clarsimp intro!: Inf_greatest res_residual_iso Inf_lower)
  assume assm: "residuated f"
  obtain y where y_def: "y = \<Sqinter>{residual f x |x. x \<in> X}"
    by auto
  hence "\<forall>x \<in> X. y \<le> residual f x"
    by (auto simp: y_def intro: Inf_lower)
  hence "\<forall>x \<in> X. f y \<le> x"
    by (metis assm residual_galoisI2)
  hence "f y \<le> \<Sqinter> X"
    by (auto intro: Inf_greatest)
  thus "\<Sqinter>{residual f x |x. x \<in> X} \<le> residual f (\<Sqinter>X)"
    by (auto simp: assm y_def intro!: residual_galoisI1)
qed

lemma Sup_sup: "\<forall>X. f(\<Squnion> X) = \<Squnion>{f x | x. x \<in> X} \<Longrightarrow> f (x \<squnion> y) = f x \<squnion> f y"
  apply (erule_tac x="{x, y}" in allE)
  by (force intro: Sup_eqI)

lemma Sup_residuatedI: "\<forall>X. f(\<Squnion> X) = \<Squnion>{f x | x. x \<in> X} \<Longrightarrow> residuated f"
proof (unfold residuated_def residuated_pair_def, standard+)
  fix x y
  assume "f x \<le> y"
  thus "x \<le> \<Squnion>{x. f x \<le> y}"
    by (clarsimp intro!: Sup_upper)
next
  fix x y
  assume assm: "\<forall>X. f (\<Squnion>X) = \<Squnion>{f x |x. x \<in> X}"
  hence f_iso: "\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"
    using Sup_sup by (auto simp: le_iff_sup)
  assume "x \<le> \<Squnion>{x. f x \<le> y}"
  hence "f x \<le> f(\<Squnion>{x. f x \<le> y})"
    by (metis f_iso)
  also have "... = \<Squnion>{f x | x . f x \<le> y}"
    using assm by auto
  finally show "f x \<le> y"
    apply (rule order_trans)
    by (auto intro!: Sup_least)
qed

lemma Inf_inf: "\<forall>X. f(\<Sqinter> X) = \<Sqinter>{f x | x. x \<in> X} \<Longrightarrow> f (x \<sqinter> y) = f x \<sqinter> f y"
  apply (erule_tac x="{x, y}" in allE)
  by (force intro: Inf_eqI)

lemma Inf_residuatedI: "\<forall>X. \<Sqinter>{g x | x. x \<in> X} = g (\<Sqinter> X) \<Longrightarrow> \<exists>f. residuated_pair f g"
proof (unfold residuated_pair_def, standard+)
  fix x y
  assume "x \<le> g y"
  thus "\<Sqinter>{y. x \<le> g y} \<le> y"
    by (clarsimp intro!: Inf_lower)
next
  fix x y
  assume assm: "\<forall>X. \<Sqinter>{g x | x. x \<in> X} = g (\<Sqinter> X)"
  hence g_iso: "\<forall>x y. x \<le> y \<longrightarrow> g x \<le> g y"
    using Inf_inf by (auto simp: le_iff_inf)
  assume "\<Sqinter>{y. x \<le> g y} \<le> y"
  hence "g (\<Sqinter>{y. x \<le> g y}) \<le> g y"
    by (metis g_iso)
  hence "(\<Sqinter>{g y | y. x \<le> g y}) \<le> g y"
    using assm apply (erule_tac x="{y. x \<le> g y}" in allE)
    by (auto intro!: Inf_lower)
  thus "x \<le> g y"
    apply (rule local.dual_order.trans)
    by (auto intro: Inf_greatest)
qed

end (* complete lattices *)

subsection \<open>Residuated Structures\<close>

text \<open>
  In this section, we define residuated algebraic structures, starting from the simplest of all,
  a \emph{residuated partial ordered groupoid}, to
  \emph{residuated l-monoids}, which are residuated
  lattices where the multiplicative operator forms a monoid.
\<close>

class pogroupoid = order + times +
  assumes mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  and mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"

text \<open>
  A residuated partial ordered groupoid is simply a partial order and a multiplicative groupoid with
  two extra operators satisfying the residuation laws.
  It is straighforward to prove that multiplication is compatible with the order,
  that is, multiplication is isotone.

  Most of the lemmas below come in pairs; they are related by opposition duality.
  Formalising this duality is left for future work.
\<close>

class residual_r_op =
  fixes residual_r :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<rightarrow>" 60)

class residual_l_op =
  fixes residual_l :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leftarrow>" 60)

class residuated_pogroupoid = order + times + residual_l_op + residual_r_op +
  assumes resl_galois: "x \<le> z \<leftarrow> y \<longleftrightarrow> x \<cdot> y \<le> z"
  and resr_galois: "x \<cdot> y \<le> z \<longleftrightarrow> y \<le> x \<rightarrow> z"
begin

lemma reslI [intro]: "x \<cdot> y \<le> z \<Longrightarrow> x \<le> z \<leftarrow> y"
  by (metis resl_galois)

lemma residuated_pair_multl [simp]: "residuated_pair (\<lambda>x. x \<cdot> y) (\<lambda>x. x \<leftarrow> y)"
  by (auto simp: residuated_pair_def resl_galois)

lemma residuated_pair_multr [simp]: "residuated_pair (\<lambda>y. x \<cdot> y) (\<lambda>y. x \<rightarrow> y)"
  by (auto simp: residuated_pair_def resr_galois)

text \<open>
  Multiplication is then obviously residuated.
\<close>

lemma residuated_multl [simp]: "residuated (\<lambda>x. x \<cdot> y)"
  by (metis residuated_def residuated_pair_multl)

lemma residuated_multr [simp]: "residuated (\<lambda>y. x \<cdot> y)"
  by (metis residuated_def residuated_pair_multr)

lemma resl_eq [simp]: "residual (\<lambda>x. x \<cdot> y) = (\<lambda>x. x \<leftarrow> y)"
  unfolding residual_def apply (rule the1_equality)
  by (auto simp: intro!: residual_unique)

lemma resr_eq [simp]: "residual (\<lambda>y. x \<cdot> y) = (\<lambda>y. x \<rightarrow> y)"
  unfolding residual_def apply (rule the1_equality)
  by (auto simp: intro!: residual_unique)

text \<open>
  Next we prove a few lemmas, all of which are instantiation of more general facts about residuated functions.
\<close>

lemma res_lc1: "x \<le> x \<cdot> y \<leftarrow> y"
  by auto

lemma res_lc2: "x \<le> y \<Longrightarrow> x \<cdot> z \<leftarrow> z \<le> y \<cdot> z \<leftarrow> z"
  by (metis local.res_c2 resl_eq residuated_multl)

lemma res_lc3 [simp]: "(x \<cdot> y \<leftarrow> y) \<cdot> y \<leftarrow> y = x \<cdot> y \<leftarrow> y"
  by (metis local.res_c3 resl_eq residuated_multl)

lemma res_rc1: "x \<le> y \<rightarrow> y \<cdot> x"
  by auto

lemma res_rc2: "x \<le> y \<Longrightarrow> z \<rightarrow> z \<cdot> x \<le> z \<rightarrow> z \<cdot> y"
  by (metis local.res_c2 resr_eq residuated_multr)

lemma res_rc3 [simp]: "y \<rightarrow> y \<cdot> (y \<rightarrow> y \<cdot> x) = y \<rightarrow> y \<cdot> x"
  by (metis local.res_c3 resr_eq residuated_multr)

lemma res_li1: "(x \<leftarrow> y) \<cdot> y \<le> x"
  by (metis local.res_i1 resl_eq residuated_multl)

lemma res_li2: "x \<le> y \<Longrightarrow> (x \<leftarrow> z) \<cdot> z \<le> (y \<leftarrow> z) \<cdot> z"
  by (metis local.res_i2 resl_eq residuated_multl)

lemma res_li3 [simp]: "((x \<leftarrow> y) \<cdot> y \<leftarrow> y) \<cdot> y = (x \<leftarrow> y) \<cdot> y"
  by (metis local.res_i3 resl_eq residuated_multl)

lemma res_ri1: "y \<cdot> (y \<rightarrow> x) \<le> x"
  by (metis local.res_i1 resr_eq residuated_multr)

lemma res_ri2: "x \<le> y \<Longrightarrow> z \<cdot> (z \<rightarrow> x) \<le> z \<cdot> (z \<rightarrow> y)"
  by (metis local.res_i2 resr_eq residuated_multr)

lemma res_ri3 [simp]: "y \<cdot> (y \<rightarrow> y \<cdot> (y \<rightarrow> x)) = y \<cdot> (y \<rightarrow> x)"
  by (metis local.res_i3 resr_eq residuated_multr)

subclass pogroupoid
proof
  fix x y z
  show "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
    by (metis local.res_iso residuated_multl)
  show "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
    by (metis local.res_iso residuated_multr)
qed

lemma resl_iso: "x \<le> y \<Longrightarrow> x \<leftarrow> z \<le> y \<leftarrow> z"
  by (metis res_residual_iso resl_eq residuated_multl)

lemma resr_iso: "x \<le> y \<Longrightarrow> z \<rightarrow> x \<le> z \<rightarrow> y"
  by (metis res_residual_iso resr_eq residuated_multr)

lemma resl_comp1 [simp]: "(x \<cdot> y \<leftarrow> y) \<cdot> y = x \<cdot> y"
  by (metis order.antisym local.mult_isor res_lc1 res_li1)

lemma resl_comp2 [simp]: "(x \<leftarrow> y) \<cdot> y \<leftarrow> y = x \<leftarrow> y"
  by (metis order.eq_iff res_lc1 res_li1 resl_iso)

lemma resr_comp1 [simp]: "y \<cdot> (y \<rightarrow> y \<cdot> x) = y \<cdot> x"
  by (metis order.antisym local.mult_isol res_rc1 res_ri1)

lemma resr_comp2 [simp]: "y \<rightarrow> y \<cdot> (y \<rightarrow> x) = y \<rightarrow> x"
  by (metis order.eq_iff res_rc1 res_ri1 resr_iso)

lemma resl_antitoner: "x \<le> y \<longrightarrow> z \<leftarrow> y \<le> z \<leftarrow> x"
  by (metis local.dual_order.trans local.mult_isol res_li1 reslI)

lemma resr_antitonel: "x \<le> y \<longrightarrow> y \<rightarrow> z \<le> x \<rightarrow> z"
  by (metis local.dual_order.trans local.resl_galois res_ri1 resrI)

text \<open>The following lemmas are taken from Galatos and \emph{al.}\<close>

lemma jipsen1l: "x \<le> y \<leftarrow> (x \<rightarrow> y)"
  by (metis res_ri1 reslI)

lemma jipsen1r: "x \<le> (y \<leftarrow> x) \<rightarrow> y"
  by (metis res_li1 resrI)

lemma jipsen2l: "(y \<leftarrow> (x \<rightarrow> y)) \<rightarrow> y = x \<rightarrow> y"
  by (metis jipsen1l jipsen1r order.eq_iff local.resr_antitonel)

lemma jipsen2r: "y \<leftarrow> ((y \<leftarrow> x) \<rightarrow> y) = y \<leftarrow> x"
  by (metis jipsen1l jipsen1r order.eq_iff local.resl_antitoner)

end (* residuated_pogroupoid *)

text \<open>
  In a residuated partial ordered semigroup, the multiplicative operator is associative.
\<close>

class residuated_posemigroup = semigroup_mult + residuated_pogroupoid
begin

lemma resl_trans: "(x \<leftarrow> y)  \<cdot>  (y \<leftarrow> z) \<le> x \<leftarrow> z"
  by (metis local.res_li1 local.resl_antitoner local.resl_galois mult_assoc)

lemma resr_trans: "(x \<rightarrow> y)  \<cdot>  (y \<rightarrow> z) \<le> x \<rightarrow> z"
  by (metis local.res_ri1 local.resr_antitonel local.resr_galois mult_assoc)

lemma resr1: "(x \<rightarrow> y) \<cdot> z \<le> (x \<rightarrow> y \<cdot> z)"
  by (metis local.mult_isor local.res_ri1 local.resrI mult_assoc)

lemma resr2: "x \<rightarrow> y \<le> z \<cdot> x \<rightarrow> z \<cdot> y"
  by (metis local.mult_isol local.res_ri1 local.resrI mult_assoc)

lemma resr3: "x \<cdot> y \<rightarrow> z = y \<rightarrow> (x \<rightarrow> z)"
  by (metis order.eq_iff local.resr_galois mult_assoc)

lemma resl1: "z \<cdot> (x \<leftarrow> y) \<le> (z \<cdot> x \<leftarrow> y)"
  by (metis local.mult_isol local.res_li1 local.reslI mult_assoc)

lemma resl2: "x \<leftarrow> y \<le> x \<cdot> z \<leftarrow> y \<cdot> z"
  by (metis local.mult_isor local.res_li1 local.reslI mult_assoc)

lemma resl3: "x \<leftarrow> y \<cdot> z = (x \<leftarrow> z) \<leftarrow> y"
  by (metis order.eq_iff local.resl_galois mult_assoc)

lemma residual_assoc: "x \<rightarrow> (y \<leftarrow> z) = (x \<rightarrow> y) \<leftarrow> z"
proof (rule order.antisym)
  show "x \<rightarrow> (y \<leftarrow> z) \<le> (x \<rightarrow> y) \<leftarrow> z"
    by (metis local.res_ri1 local.resl_galois local.resr_galois mult_assoc)
  show "(x \<rightarrow> y) \<leftarrow> z \<le> x \<rightarrow> (y \<leftarrow> z)"
    by (metis local.res_li1 local.resl_galois local.resr_galois mult_assoc)
qed

end (* residuated_posemigroup *)

text \<open>
  In a residuated partially ordered monoid, the multiplicative operator has a unit $1$; that is,
  its reduct forms a monoid.
\<close>

class residuated_pomonoid = monoid_mult + residuated_pogroupoid
begin

subclass residuated_posemigroup ..

lemma resl_unit: "x \<leftarrow> 1 = x"
  by (metis local.mult_1_right local.resl_comp1)

lemma resr_unit: "1 \<rightarrow> x = x"
  by (metis local.mult_1_left local.resr_comp1)

lemma mult_one_resl: "x \<cdot> (1 \<leftarrow> y) \<le> x \<leftarrow> y"
  by (metis local.mult_1_right local.resl1)

lemma mult_one_resr: "(x \<rightarrow> 1) \<cdot> y \<le> x \<rightarrow> y"
  by (metis local.mult_1_left local.resr1)

text \<open>More lemmas from Galatos and \emph{al.} follow.\<close>

lemma jipsen3l: "1 \<le> x \<leftarrow> x"
  by (metis local.jipsen1l resr_unit)

lemma jipsen3r: "1 \<le> x \<rightarrow> x"
  by (metis local.jipsen1r resl_unit)

lemma jipsen4l [simp]: "(x \<leftarrow> x) \<cdot> x = x"
  by (metis local.mult_1_left local.resl_comp1)

lemma jipsen4r [simp]: "x \<cdot> (x \<rightarrow> x) = x"
  by (metis local.mult_1_right local.resr_comp1)

lemma jipsen5l [simp]: "(x \<leftarrow> x) \<cdot> (x \<leftarrow> x) = x \<leftarrow> x"
  by (metis jipsen4l local.resl3)

lemma jipsen5r [simp]: "(x \<rightarrow> x) \<cdot> (x \<rightarrow> x) = x \<rightarrow> x"
  by (metis jipsen4r local.resr3)

lemma jipsen6l: "y \<leftarrow> x \<le> (y \<leftarrow> z) \<leftarrow> (x \<leftarrow> z)"
  by (metis local.resl_galois local.resl_trans)

lemma jipsen6r: "x \<rightarrow> y \<le> (z \<rightarrow> x) \<rightarrow> (z \<rightarrow> y)"
  by (metis local.resr_galois local.resr_trans)

lemma jipsen7l: "y \<leftarrow> x \<le> (z \<leftarrow> y) \<rightarrow> (z \<leftarrow> x)"
  by (metis local.resr_galois local.resl_trans)

lemma jipsen7r: "x \<rightarrow> y \<le> (x \<rightarrow> z) \<leftarrow> (y \<rightarrow> z)"
  by (metis local.resl_galois local.resr_trans)

end (* residuated_pomonoid *)

text \<open>
  Residuated partially ordered groupoids can be expanded residuated join semilattice ordered groupoids.
  They are used as a base for action algebras, which are expansions
  of Kleene algebras by operations of residuation.
  Action algebras can be found in the AFP entry for Kleene algebras.
\<close>

class residuated_sup_lgroupoid = semilattice_sup + residuated_pogroupoid
begin

lemma distl: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
  by (metis local.residuated_multr local.residuated_sup)

lemma distr: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
  by (metis local.residuated_multl local.residuated_sup)

lemma resl_subdist_var: "x \<leftarrow> z \<le> (x \<squnion> y) \<leftarrow> z"
  by (metis local.resl_iso local.sup_ge1)

lemma resl_subdist: "(x \<leftarrow> z) \<squnion> (y \<leftarrow> z) \<le> (x \<squnion> y) \<leftarrow> z"
  by (metis local.le_sup_iff local.sup_commute resl_subdist_var)

lemma resr_subdist_var: "(x \<rightarrow> y) \<le> x \<rightarrow> (y \<squnion> z)"
  by (metis local.resr_iso local.sup_ge1)

lemma resr_subdist: "(x \<rightarrow> y) \<squnion> (x \<rightarrow> z) \<le> x \<rightarrow> (y \<squnion> z)"
  by (metis sup_commute sup_least resr_subdist_var)

lemma resl_superdist_var: "x \<leftarrow> (y \<squnion> z) \<le> x \<leftarrow> y"
  by (metis local.le_sup_iff local.res_li1 local.reslI local.resr_galois)

lemma resr_superdist_var: "(x \<squnion> y) \<rightarrow> z \<le> x \<rightarrow> z"
  by (metis local.le_sup_iff local.res_ri1 local.resl_galois local.resrI)

end (* residuated_sup_lgroupoid *)

text \<open>
  Similarly, semigroup and monoid variants can be defined.
\<close>

class residuated_sup_lsemigroup = semilattice_sup + residuated_posemigroup
subclass (in residuated_sup_lsemigroup) residuated_sup_lgroupoid ..

class residuated_sup_lmonoid = semilattice_sup + residuated_posemigroup
subclass (in residuated_sup_lmonoid) residuated_sup_lsemigroup ..

text \<open>
  By lattice duality, we define residuated meet semillatice ordered groupoid.
\<close>

class residuated_inf_lgroupoid = semilattice_inf + residuated_pogroupoid
begin

lemma resl_dist: "(x \<sqinter> y) \<leftarrow> z = (x \<leftarrow> z) \<sqinter> (y \<leftarrow> z)"
  by (metis local.resl_eq local.residuated_inf local.residuated_multl)

lemma resr_dist: "x \<rightarrow> (y \<sqinter> z) = (x \<rightarrow> y) \<sqinter> (x \<rightarrow> z)"
  by (metis local.resr_eq local.residuated_inf local.residuated_multr)

lemma resl_inf_superdist: "x \<leftarrow> y \<le> x \<leftarrow> (y \<sqinter> z)"
  by (metis local.inf_le1 local.resl_antitoner)

lemma resr_inf_superdist_var: "x \<rightarrow> y \<le> (x \<sqinter> z) \<rightarrow> y"
  by (metis local.inf_le1 local.resr_antitonel)

end (* residuated_inf_lgroupoid *)

class residuated_inf_lsemigroup = semilattice_inf + residuated_posemigroup
subclass (in residuated_inf_lsemigroup) residuated_inf_lgroupoid ..

class residuated_inf_lmonoid = semilattice_inf + residuated_posemigroup
subclass (in residuated_inf_lmonoid) residuated_inf_lsemigroup ..

text \<open>
  Finally, we obtain residuated lattice groupoids.
\<close>

class residuated_lgroupoid = lattice + residuated_pogroupoid
begin

subclass residuated_sup_lgroupoid ..

lemma resl_distr: "z \<leftarrow> (x \<squnion> y) = (z \<leftarrow> x) \<sqinter> (z \<leftarrow> y)"
proof (rule order.antisym)
  show "z \<leftarrow> x \<squnion> y \<le> (z \<leftarrow> x) \<sqinter> (z \<leftarrow> y)"
    by (metis local.inf.bounded_iff local.resl_superdist_var local.sup_commute)
  show "(z \<leftarrow> x) \<sqinter> (z \<leftarrow> y) \<le> z \<leftarrow> x \<squnion> y"
    by (metis local.inf.cobounded1 local.inf.cobounded2 local.resl_galois local.resr_galois local.sup.bounded_iff)
qed

lemma resr_distl: "(x \<squnion> y) \<rightarrow> z = (x \<rightarrow> z) \<sqinter> (y \<rightarrow> z)"
proof (rule order.antisym)
  show "x \<squnion> y \<rightarrow> z \<le> (x \<rightarrow> z) \<sqinter> (y \<rightarrow> z)"
    by (metis local.inf.bounded_iff local.resr_antitonel local.resr_superdist_var local.sup_ge2)
  show "(x \<rightarrow> z) \<sqinter> (y \<rightarrow> z) \<le> x \<squnion> y \<rightarrow> z"
    by (metis local.inf.cobounded1 local.inf.cobounded2 local.resl_galois local.resr_galois local.sup_least)
qed

end (* residuated_lgroupoid *)

class residuated_lsemigroup = lattice + residuated_sup_lsemigroup
subclass (in residuated_lsemigroup) residuated_lgroupoid ..

class residuated_lmonoid = lattice + residuated_sup_lmonoid
subclass (in residuated_lmonoid) residuated_lsemigroup ..

class residuated_blgroupoid = bounded_lattice + residuated_pogroupoid
begin

lemma multl_strict [simp]: "x \<cdot> \<bottom> = \<bottom>"
  by (metis local.residuated_multr local.residuated_strict)

lemma multr_strict [simp]: "\<bottom> \<cdot> x = \<bottom>"
  by (metis local.residuated_multl local.residuated_strict)

lemma resl_top [simp]: "\<top> \<leftarrow> x = \<top>"
  by (metis local.res_top local.residuated_multl local.resl_eq)

lemma resl_impl [simp]: "x \<leftarrow> \<bottom> = \<top>"
  by (metis local.resl_comp2 multl_strict resl_top)

lemma resr_top [simp]: "x \<rightarrow> \<top> = \<top>"
  by (metis local.resrI local.top_greatest local.top_unique)

lemma resr_impl [simp]: "\<bottom> \<rightarrow> x = \<top>"
  by (metis local.resr_comp2 multr_strict resr_top)

end (* residuated_blgroupoid *)

class residuated_blsemigroup = bounded_lattice + residuated_sup_lsemigroup
subclass (in residuated_blsemigroup) residuated_blgroupoid ..

class residuated_blmonoid = bounded_lattice + residuated_sup_lmonoid
subclass (in residuated_blmonoid) residuated_blsemigroup ..

class residuated_clgroupoid = complete_lattice + residuated_pogroupoid
begin

lemma resl_eq_def: "y \<leftarrow> x = \<Squnion> {z. z \<cdot> x \<le> y}"
  by (metis local.residual_eq1 local.residuated_multl local.resl_eq)

lemma resr_eq_def: "x \<rightarrow> y = \<Squnion> {z. x \<cdot> z \<le> y}"
  by (metis local.residual_eq1 local.residuated_multr local.resr_eq)

lemma multl_def: "x \<cdot> y = \<Sqinter> {z. x \<le> z \<leftarrow> y}"
proof -
  have "\<Sqinter>{ya. x \<le> residual (\<lambda>a. a \<cdot> y) ya} = \<Sqinter>{z. x \<le> z \<leftarrow> y}"
    by simp
  thus ?thesis
    by (metis residuated_multl residual_eq2)
qed

lemma multr_def: "x \<cdot> y = \<Sqinter> {z. y \<le> x \<rightarrow> z}"
proof -
  have "\<Sqinter>{ya. y \<le> residual ((\<cdot>) x) ya} = \<Sqinter>{z. y \<le> x \<rightarrow> z}"
    by simp
  thus ?thesis
    by (metis residuated_multr residual_eq2)
qed

end (* residuated_clgroupoid *)

class residuated_clsemigroup = complete_lattice + residuated_sup_lsemigroup
subclass (in residuated_clsemigroup) residuated_clgroupoid ..

class residuated_clmonoid = complete_lattice + residuated_sup_lmonoid
subclass (in residuated_clmonoid) residuated_clsemigroup ..

end