section \<open>Digit functions\<close>

theory Bits_Digits
  imports Main
begin

text \<open>We define the n-th bit of a number in base 2 representation \<close>
definition nth_bit :: "nat \<Rightarrow> nat \<Rightarrow> nat" (infix "\<exclamdown>" 100) where
  "nth_bit num k = (num div (2 ^ k)) mod 2"

text \<open>as well as the n-th digit of a number in an arbitrary base \<close>
definition nth_digit :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nth_digit num k base = (num div (base ^ k)) mod base"

text \<open>In base 2, the two definitions coincide. \<close>
lemma nth_digit_base2_equiv:"nth_bit a k = nth_digit a k (2::nat)"
  by (auto simp add:nth_bit_def nth_digit_def)

lemma general_digit_base:
  assumes "t1 > t2" and "b>1"
  shows "nth_digit (a * b^t1) t2 b = 0"
proof -
  have 1: "b^t1 div b^t2 = b^(t1-t2)" using assms apply auto
    by (metis Suc_lessD less_imp_le less_numeral_extra(3) power_diff)
  have "b^t2 dvd b^t1" using `t1 > t2`
    by (simp add: le_imp_power_dvd)
  hence "(a * b^t1) div b^t2 = a * b^(t1-t2)" using div_mult_swap[of "b^t2" "b^t1" "a"] 1 by auto
  thus ?thesis using nth_digit_def assms by auto
qed

lemma nth_bit_bounded: "nth_bit a k \<le> 1"
  by (auto simp add: nth_bit_def)

lemma nth_digit_bounded: "b>1 \<Longrightarrow> nth_digit a k b \<le> b-1"
  apply (auto simp add: nth_digit_def)
  using less_Suc_eq_le by fastforce

lemma obtain_smallest: "P (n::nat) \<Longrightarrow> \<exists>k\<le>n. P k \<and> (\<forall>a<k.\<not>(P a))"
  by (metis ex_least_nat_le not_less_zero zero_le)

subsection \<open>Simple properties and equivalences\<close>

text \<open>Reduce the @{term nth_digit} function to @{term nth_bit} if the base is a power of 2\<close>

lemma digit_gen_pow2_reduct:
  \<open>(nth_digit a t (2 ^ c)) \<exclamdown> k = a \<exclamdown> (c * t + k)\<close> if \<open>k < c\<close>
proof -
  have moddiv: "(x mod 2 ^ c) \<exclamdown> k = x \<exclamdown> k" for x
  proof-
    define n where \<open>n = c - k\<close>
    with \<open>k < c\<close> have c_nk: \<open>c = n + k\<close>
      by simp
    obtain a b where x_def: "x = a * 2 ^ c + b" and "b < 2 ^ c"
      by (meson mod_div_decomp mod_less_divisor zero_less_numeral zero_less_power)
    then have bk: "(x mod 2 ^ c) \<exclamdown> k = b \<exclamdown> k" by simp
    from \<open>b < 2 ^ c\<close> have \<open>x div 2 ^ k = a * 2 ^ (c - k) + b div 2 ^ k\<close>
      by (simp add: x_def c_nk power_add flip: mult.commute [of \<open>2 ^ k\<close>] mult.left_commute [of \<open>2 ^ k\<close>])
    then have "x \<exclamdown> k = (a*2^(c-k) + b div 2^k) mod 2" by (simp add: nth_bit_def)
    then have "x \<exclamdown> k = b \<exclamdown> k" using nth_bit_def \<open>k < c\<close> by (simp add: mod2_eq_if)
    then show ?thesis using nth_bit_def bk by linarith
  qed
  have "a div ((2 ^ c) ^ t * 2 ^ k) = a div (2 ^ c) ^ t div 2 ^ k" using div_mult2_eq by blast
  moreover have "a div (2 ^ c) ^ t mod 2 ^ c div 2 ^ k mod 2 = a div (2 ^ c) ^ t div 2 ^ k mod 2"
    using moddiv nth_bit_def by auto
  ultimately show "(nth_digit a t (2^c)) \<exclamdown> k = a \<exclamdown> (c*t+k)"
    using nth_digit_def nth_bit_def by (auto simp: power_add power_mult)
qed

text \<open>Show equivalence of numbers by equivalence of all their bits (digits)\<close>

lemma aux_even_pow2_factor: "a > 0 \<Longrightarrow> \<exists>k b. ((a::nat) = (2^k) * b \<and> odd b)"
proof(induction  a rule: full_nat_induct)
  case (1 n)
  then show ?case
  proof (cases "odd n")
    case True
    then show ?thesis by (metis nat_power_eq_Suc_0_iff power_Suc power_Suc0_right power_commutes)
  next
    case False
    have "(\<exists>t. n = 2 * t)" using False by auto
    then obtain t where n_def:"n = 2 * t" ..
    then have "t < n" using "1.prems" by linarith
    then have ih:"\<exists>r s. t = 2^r * s \<and> odd s" using 1 n_def by simp
    then have "\<exists>r s. n = 2^(Suc r) * s" using n_def by auto
    then show ?thesis by (metis ih n_def power_commutes semiring_normalization_rules(18)
                          semiring_normalization_rules(28))
  qed
qed

lemma aux0_digit_wise_equiv:"a > 0 \<Longrightarrow> (\<exists>k. nth_bit a k = 1)"
proof -
  assume a_geq_0: "a > 0"
  consider (odd) "a mod 2 = 1" | (even) "a mod 2 = 0" by force
  then show ?thesis
  proof(cases)
    case odd
    then show ?thesis by (metis div_by_1 nth_bit_def power_0)
  next
    case even
    then have bk_def:"\<exists>k b. (a = (2^k) * b \<and> odd b)"
      using aux_even_pow2_factor a_geq_0 by simp
    then obtain b k where bk_cond:"(a = (2^k) * b \<and> odd b)" by blast
    then have "b = a div (2^k)" by simp
    then have digi_b:"nth_bit b 0 = 1" using bk_def
      using bk_cond nth_bit_def odd_iff_mod_2_eq_one by fastforce
    then have "nth_bit a k = (nth_bit b 0)" using nth_bit_def bk_cond by force
    then have "nth_bit a k = 1" using digi_b by simp
    then show ?thesis by blast
  qed
qed

lemma aux1_digit_wise_equiv:"(\<forall>k.(nth_bit a k = 0)) \<longleftrightarrow> a = 0" (is "?P \<longleftrightarrow> ?Q")
proof
  assume "?Q"
  then show "?P" by (simp add: nth_bit_def)
next
  {
    assume a_neq_0:"\<not>?Q"
    then have "a > 0" by blast
    then have "\<not>?P" using aux0_digit_wise_equiv by (metis zero_neq_one)
  }
  thus "?P \<Longrightarrow> ?Q" by blast
qed

lemma aux2_digit_wise_equiv: "(\<forall>r<k. nth_bit a r = 0) \<longrightarrow> (a mod 2^k = 0)"
proof(induct k)
  case 0
  then show ?case
    by (auto simp add: nth_bit_def)
next
  case (Suc k)
  then show ?case
    by (auto simp add: nth_bit_def)
       (metis dvd_imp_mod_0 dvd_mult_div_cancel dvd_refl even_iff_mod_2_eq_zero
        lessI minus_mod_eq_div_mult minus_mod_eq_mult_div mult_dvd_mono)
qed

lemma digit_wise_equiv: "(a = b) \<longleftrightarrow> (\<forall>k. nth_bit a k = nth_bit b k)" (is "?P \<longleftrightarrow> ?Q")
proof
  assume "?P"
  then show "?Q" by simp
next
  {
    assume notP: "\<not>?P"
    have "\<not>(\<forall>k. nth_bit a k = nth_bit b k)" if ab: "a<b" for a b
    proof-
      define c::nat where "c = b - a"
      have b: "a+c=b" by (auto simp add: c_def "ab" less_imp_le)
      have  "\<exists>k.(nth_bit c k = 1)" using nth_bit_def aux1_digit_wise_equiv
        by (metis c_def not_less0 not_mod_2_eq_1_eq_0 that zero_less_diff)
      then obtain k where k1:"nth_bit c k = 1" and k2:"\<forall>r < k. (nth_bit c r \<noteq> 1)"
        by (auto dest: obtain_smallest)
      then have cr0: "\<forall>r < k. (nth_bit c r = 0)" by (simp add: nth_bit_def)
      from aux2_digit_wise_equiv cr0 have "c mod 2^k = 0" by auto
      then have "a div 2 ^ k mod 2 \<noteq> b div 2 ^ k mod 2"
        by auto (metis b div_plus_div_distrib_dvd_right even_add k1 nth_bit_def odd_iff_mod_2_eq_one)
      then show ?thesis by (auto simp add: nth_bit_def)
    qed
    from this [of a b] this [of b a] notP have "\<forall>k. nth_bit a k = nth_bit b k \<Longrightarrow> a = b"
      using linorder_neqE_nat by auto
  }
  then show "?Q ==> ?P" by auto
qed

text \<open>Represent natural numbers in their binary expansion\<close>

lemma aux3_digit_sum_repr:
  assumes "b < 2^r"
  shows "(a*2^r + b) \<exclamdown> r = (a*2^r) \<exclamdown> r"
  by (auto simp add: nth_bit_def assms)

lemma aux2_digit_sum_repr:
  assumes "n < 2^c" "r < c"
  shows "(a*2^c+n) \<exclamdown> r = n \<exclamdown> r"
proof -
  have [simp]: \<open>a*(2::nat) ^ c div 2 ^ r = a*2 ^ (c - r)\<close>
    using assms(2)
    by (auto simp: less_iff_Suc_add
          monoid_mult_class.power_add ac_simps)
  show ?thesis
    using assms
    by (auto simp add: nth_bit_def
            div_plus_div_distrib_dvd_left
            le_imp_power_dvd
          simp flip: mod_add_left_eq)
qed

lemma aux1_digit_sum_repr:
assumes "n < 2^c" "r<c"
shows "(\<Sum>k<c.((n \<exclamdown> k)*2^k)) \<exclamdown> r = n \<exclamdown> r"
proof-
  define a where "a \<equiv> (\<Sum>k=0..<Suc(r).((n \<exclamdown> k)*2^k))"
  define d where "d \<equiv> (\<Sum>k=Suc(r)..<c.((n \<exclamdown> k)*2^k))"
  define e where "e \<equiv> (\<Sum>k=Suc r..<c.((n \<exclamdown> k)*2^(k-Suc(r))))"
  define b where "b \<equiv> (\<Sum>k=0..<r.((n \<exclamdown> k)*2^k))"
  have ad: "(\<Sum>k=0..<c.((n \<exclamdown> k)*2^k)) = a + d"
    using a_def d_def assms
    by (metis (no_types, lifting) Suc_leI a_def assms(2) d_def sum.atLeastLessThan_concat zero_le)
  have "d = (\<Sum>k=Suc(r)..<c.(2^(Suc r) * (n \<exclamdown> k *  2^(k - Suc r))))"
    using d_def apply (simp)
    apply (rule sum.cong; auto simp: algebra_simps)
    by (metis add_Suc le_add_diff_inverse numerals(2) power_Suc power_add)
  hence d2r: "d = 2^Suc(r)*e" using d_def e_def
     sum_distrib_left[of "2^(Suc r)" "\<lambda>k. (n \<exclamdown> k) *  2^(k - Suc r)" "{Suc r..<c}"] by auto
  have "(\<Sum>k<c.((n \<exclamdown> k)*2^k)) = a +2^Suc(r)*e" by (simp add: d2r ad lessThan_atLeast0)
  moreover have "(\<Sum>k=0..<Suc(r).((n \<exclamdown> k)*2^k)) < 2 ^ Suc(r)" using assms
  proof(induct r)
    case 0
    then show ?case
    proof -
      have "n \<exclamdown> 0 < Suc 1"
        by (metis (no_types) atLeastLessThan_empty atLeastLessThan_iff lessI linorder_not_less
                  nth_bit_bounded)
      then show ?thesis
        by simp
    qed
    next
      case (Suc r)
      have r2: "n \<exclamdown> Suc(r) *  2 ^ Suc(r) \<le>  2 ^ Suc(r)" using nth_bit_bounded by simp
      have "(\<Sum>k=0..<Suc(r).((n \<exclamdown> k)*2^k)) < 2 ^ Suc(r)"
        using Suc.hyps using Suc.prems(2) Suc_lessD assms(1) by blast
      then show ?case using "r2"
        by (smt Suc_leI Suc_le_lessD add_Suc add_le_mono mult_2 power_Suc sum.atLeast0_lessThan_Suc)
    qed
    then have "a < 2 ^Suc(r)" using a_def by blast
  ultimately have ar:"(a+d) \<exclamdown> r = a \<exclamdown> r" using d2r
    by (metis (no_types, lifting) aux2_digit_sum_repr lessI semiring_normalization_rules(24)
              semiring_normalization_rules(7))
    (* Second part of proof *)
  have ab: "a =(n \<exclamdown> r)*2^r + b" using a_def b_def d_def by simp
  have "(\<Sum>k=0..<r.((n \<exclamdown> k)*2^k)) <2^r"
  proof(induct r)
    case 0
      then show ?case by auto
    next
      case (Suc r)
      have r2: "n \<exclamdown> r *  2 ^ r \<le>  2 ^ r" using nth_bit_bounded by simp
      have "(\<Sum>k = 0..<r. n \<exclamdown> k * 2 ^ k) < 2^r" using Suc.hyps by auto
      then show ?case apply simp using "r2" by linarith
  qed
  then have b: "b < 2^r" using b_def by blast
  then have "a \<exclamdown> r = ((n \<exclamdown> r)*2^r) \<exclamdown> r" using ab aux3_digit_sum_repr by simp
  then have "a \<exclamdown> r = (n \<exclamdown> r)" using nth_bit_def by simp
  then show ?thesis using ar a_def by (simp add: ad lessThan_atLeast0)
qed

lemma digit_sum_repr:
  assumes "n < 2^c"
  shows "n = (\<Sum>k < c.((n \<exclamdown> k) * 2^k))"
proof -
  have "\<forall>k. (c\<le>k \<longrightarrow> n<2^k)" using assms less_le_trans by fastforce
  then have nik: "\<forall>k.( k\<ge> c \<longrightarrow> (n \<exclamdown> k = 0))"  by (auto simp add: nth_bit_def)
  have "(\<Sum>r<c.((n \<exclamdown> r)*(2::nat)^r))<(2::nat)^c"
  proof (induct c)
    case 0
    then show ?case by simp
  next
    case (Suc c)
    then show ?case
      using nth_bit_bounded
            add_mono_thms_linordered_field[of "(n \<exclamdown> c)* 2 ^ c" " 2 ^ c" "(\<Sum>r<c. n \<exclamdown> r * 2 ^ r)" "2^c"]
      by simp
  qed
  then have "\<forall>k. k\<ge> c \<longrightarrow> (\<Sum>r<c.((n \<exclamdown> r)*2^r)) \<exclamdown> k = 0"
    using less_le_trans by (auto simp add: nth_bit_def) fastforce
  then have "\<forall>r\<ge>c.(n \<exclamdown> r  = (\<Sum>k<c.((n \<exclamdown> k)*2^k)) \<exclamdown> r)" by (simp add: nik)
  moreover have "\<forall>r<c.(n \<exclamdown> r  = (\<Sum>k<c.((n \<exclamdown> k)*2^k)) \<exclamdown> r)" using aux1_digit_sum_repr assms by simp
  ultimately have "\<forall>r.(\<Sum>k<c.((nth_bit n k)*2^k)) \<exclamdown> r = n \<exclamdown> r " by (metis not_less)
  then show ?thesis using digit_wise_equiv by presburger
qed

lemma digit_sum_repr_variant:
  "n =(\<Sum>k<n.((nth_bit n k)*2^k))"
  using less_exp digit_sum_repr by auto

lemma digit_sum_index_variant:
  "r>n \<longrightarrow> ((\<Sum>k< n.((n \<exclamdown> k)*2^k)) = (\<Sum>k< r.(n \<exclamdown> k)*2^k))"
proof-
  have "\<forall>r.(2^r > r)" using less_exp by simp
  then have pow2: "\<forall>r.(r>n \<longrightarrow> 2^r>n)" using less_trans by blast
  then have "\<forall>r.(r > n \<longrightarrow> (n \<exclamdown> r = 0))" by (auto simp add: nth_bit_def)
  then have "\<forall>r. r > n \<longrightarrow> (n \<exclamdown> r)*2^r = 0" by auto
  then show ?thesis using digit_sum_repr digit_sum_repr_variant pow2 by auto
qed

text \<open>Digits are preserved under shifts\<close>

lemma digit_shift_preserves_digits:
  assumes "b>1"
  shows "nth_digit (b * y) (Suc t) b = nth_digit y t b"
  using nth_digit_def assms by auto

lemma digit_shift_inserts_zero_least_siginificant_digit:
  assumes "t>0" and "b>1"
  shows "nth_digit (1 + b * y) t b = nth_digit (b * y) t b"
  using nth_digit_def assms apply auto
proof -
  assume "0 < t"
  assume "Suc 0 < b"
  hence "Suc (b * y) mod b = 1"
    by (simp add: Suc_times_mod_eq)
  hence "b * y div b = Suc (b * y) div b"
    using \<open>b>1\<close> by (metis (no_types) One_nat_def diff_Suc_Suc gr_implies_not0 minus_mod_eq_div_mult
                 mod_mult_self1_is_0 nonzero_mult_div_cancel_right)
  then show "Suc (b * y) div b ^ t mod b = b * y div b ^ t mod b"
    using \<open>t>0\<close> by (metis Suc_pred div_mult2_eq power_Suc)
qed

text \<open>Represent natural numbers in their base-b digitwise expansion\<close>

lemma aux3_digit_gen_sum_repr:
  assumes "d < b^r" and "b > 1"
  shows "nth_digit (a*b^r + d) r b = nth_digit (a*b^r) r b"
  using \<open>b>1\<close> by (auto simp: nth_digit_def assms)

lemma aux2_digit_gen_sum_repr:
  assumes "n < b^c" "r < c"
  shows "nth_digit (a*b^c+n) r b = nth_digit n r b"
proof -
  have [simp]: \<open>a*b ^ c div b ^ r = a*b ^ (c - r)\<close>
    using assms(2)
    by (auto simp: less_iff_Suc_add
          monoid_mult_class.power_add ac_simps)
  show ?thesis
    using assms
    by (auto simp add: nth_digit_def
            div_plus_div_distrib_dvd_left
            le_imp_power_dvd
          simp flip: mod_add_left_eq)
qed

lemma aux1_digit_gen_sum_repr:
assumes "n < b^c" "r<c" and "b>1"
shows "nth_digit (\<Sum>k<c.((nth_digit n k b)*b^k)) r b = nth_digit n r b"
proof-
  define a where "a \<equiv> (\<Sum>k=0..<Suc(r).((nth_digit n k b)*b^k))"
  define d where "d \<equiv> (\<Sum>k=Suc(r)..<c.((nth_digit n k b)*b^k))"
  define e where "e \<equiv> (\<Sum>k=Suc r..<c.((nth_digit n k b)*b^(k-Suc(r))))"
  define f where "f \<equiv> (\<Sum>k=0..<r.((nth_digit n k b)*b^k))"
  have ad: "(\<Sum>k=0..<c.((nth_digit n k b)*b^k)) = a + d"
    using a_def d_def assms
    by (metis (no_types, lifting) Suc_leI a_def assms(2) d_def sum.atLeastLessThan_concat zero_le)
  have "d = (\<Sum>k=Suc(r)..<c.(b^(Suc r) * (nth_digit n k b * b^(k - Suc r))))"
    using d_def apply (auto) apply (rule sum.cong; auto simp: algebra_simps)
    by (metis add_Suc le_add_diff_inverse power_Suc power_add)
  hence d2r: "d = b^Suc(r)*e" using d_def e_def sum_distrib_left[of "b^(Suc r)"
                          "\<lambda>k. (nth_digit n k b) *  b^(k - Suc r)" "{Suc r..<c}"] by auto
  have "(\<Sum>k<c.((nth_digit n k b)*b^k)) = a +b^Suc(r)*e"
    by (simp add: d2r ad lessThan_atLeast0)
  moreover have "(\<Sum>k=0..<Suc(r).((nth_digit n k b)*b^k)) < b ^ Suc(r)" using assms
  proof(induct r)
    case 0
    then show ?case
    proof -
      have "nth_digit n 0 b < b"
        using nth_digit_bounded[of "b" "n" "0"] \<open>b>1\<close> by auto
      then show ?thesis
        by simp
    qed
    next
      case (Suc r)
      have r2: "(nth_digit n (Suc r) b) * b ^ Suc(r) \<le> (b-1) * b ^ Suc(r)"
        using nth_digit_bounded[of "b" "n" "Suc r"] \<open>b>1\<close> by auto
      moreover have "(\<Sum>k=0..<Suc(r).((nth_digit n k b)*b^k)) < b ^ Suc(r)"
        using Suc.hyps using Suc.prems(2) Suc_lessD assms(1) \<open>b>1\<close> by blast
      ultimately have "(nth_digit n (Suc r) b) * b ^ Suc(r)
                     + (\<Sum>k=0..<Suc(r).((nth_digit n k b)*b^k)) < b ^ Suc (Suc r)"
        using assms(3) mult_eq_if by auto
      then show ?case by auto
    qed
    hence "a < b^Suc(r)" using a_def by blast
  ultimately have ar:"nth_digit (a+d) r b = nth_digit a r b" using d2r
    by (metis (no_types, lifting) aux2_digit_gen_sum_repr lessI semiring_normalization_rules(24)
              semiring_normalization_rules(7))
    (* Second part of proof *)
  have ab: "a =(nth_digit n r b)*b^r + f" using a_def f_def d_def by simp
  have "(\<Sum>k=0..<r.((nth_digit n k b)*b^k)) < b^r"
  proof(induct r)
    case 0
      then show ?case by auto
    next
      case (Suc r)
      have r2: "nth_digit n r b * b ^ r \<le> (b-1) * b ^ r"
        using nth_digit_bounded[of "b"] \<open>b>1\<close> by auto
      have "(\<Sum>k = 0..<r. nth_digit n k b * b ^ k) < b^r" using Suc.hyps by auto
      then show ?case using "r2" assms(3) mult_eq_if by auto
  qed
  hence f: "f < b^r" using f_def by blast
  hence "nth_digit a r b = (nth_digit (nth_digit n r b * b^r) r b)"
    using ab aux3_digit_gen_sum_repr \<open>b>1\<close> by simp
  hence "nth_digit a r b = nth_digit n r b"
    using nth_digit_def \<open>b>1\<close> by simp
  then show ?thesis using ar a_def by (simp add: ad lessThan_atLeast0)
qed

lemma aux_gen_b_factor: "a > 0 \<Longrightarrow> b>1 \<Longrightarrow> \<exists>k c. ((a::nat) = (b^k) * c \<and> \<not>(c mod b = 0))"
proof(induction  a rule: full_nat_induct)
  case (1 n)
  show ?case
  proof(cases "n mod b = 0")
    case True
    then obtain t where n_def: "n = b * t" by blast
    hence "t < n"
      using 1 by auto
    with 1 have ih:"\<exists>r s. t = b^r * s \<and> \<not>(s mod b = 0)"
      by (metis Suc_leI gr0I mult_0_right n_def)
    hence "\<exists>r s. n = b^(Suc r) * s" using n_def by auto
    then show ?thesis by (metis ih mult.commute mult.left_commute n_def power_Suc)
  next
    case False
    then show ?thesis by (metis mult.commute power_0 power_Suc power_Suc0_right)
  qed
qed

lemma aux0_digit_wise_gen_equiv:
  assumes "b>1" and a_geq_0: "a > 0"
  shows "(\<exists>k. nth_digit a k b \<noteq> 0)"
proof(cases "a mod b = 0")
  case True
  hence "\<exists>k c. a = (b^k) * c \<and> \<not>(c mod b = 0)"
    using aux_gen_b_factor a_geq_0 assms by simp
  then obtain c k where ck_cond:"a = (b^k) * c \<and> \<not>(c mod b = 0)" by blast
  hence c_cond:"c = a div (b^k)" using a_geq_0 by auto
  hence digi_b:"nth_digit c 0 b \<noteq> 0"
    using ck_cond nth_digit_def by force
  hence "nth_digit a k b = nth_digit c 0 b"
    using nth_digit_def c_cond by simp
  hence "nth_digit a k b \<noteq> 0" using digi_b by simp
  then show ?thesis by blast next
  case False
  then show ?thesis
    by (metis div_by_1 nth_digit_def power.simps(1))
qed

lemma aux1_digit_wise_gen_equiv:
  assumes "b>1"
  shows "(\<forall>k.(nth_digit a k b = 0)) \<longleftrightarrow> a = 0" (is "?P \<longleftrightarrow> ?Q")
proof
  assume "?Q"
  then show "?P" by (simp add: nth_digit_def)
next
  {
    assume a_neq_0:"\<not>?Q"
    hence "a > 0" by blast
    hence "\<not>?P" using aux0_digit_wise_gen_equiv \<open>b>1\<close> by auto
  } from this show "?P \<Longrightarrow> ?Q" by blast
qed

lemma aux2_digit_wise_gen_equiv: "(\<forall>r<k. nth_digit a r b = 0) \<longrightarrow> (a mod b^k = 0)"
proof(induct k)
  case 0
  then show ?case by auto
next
  case (Suc k)
  then show ?case apply(auto simp add: nth_digit_def)
    using dvd_imp_mod_0 dvd_mult_div_cancel dvd_refl
        lessI minus_mod_eq_div_mult minus_mod_eq_mult_div mult_dvd_mono
    by (metis mod_0_imp_dvd)
qed

text \<open>Two numbers are the same if and only if their digits are the same\<close>

lemma digit_wise_gen_equiv:
  assumes "b>1"
  shows "(x = y) \<longleftrightarrow> (\<forall>k. nth_digit x k b = nth_digit y k b)" (is "?P \<longleftrightarrow> ?Q")
proof
  assume "?P"
  then show "?Q" by simp
next{
    assume notP: "\<not>?P"
    have"\<not>(\<forall>k. nth_digit x k b = nth_digit y k b)" if xy: "x<y" for x y
    proof-
      define c::nat where "c = y - x"
      have y: "x+c=y" by (auto simp add: c_def "xy" less_imp_le)
      have  "\<exists>k.(nth_digit c k b \<noteq> 0)"
        using nth_digit_def \<open>b>1\<close> aux0_digit_wise_gen_equiv
        by (metis c_def that zero_less_diff)
      then obtain k where k1:"nth_digit c k b \<noteq> 0"
                      and k2:"\<forall>r < k. (nth_digit c r b = 0)"
        apply(auto dest: obtain_smallest) done
      hence cr0: "\<forall>r < k. (nth_digit c r b = 0)" by (simp add: nth_digit_def)
      from aux2_digit_wise_gen_equiv cr0 have "c mod b^k = 0" by auto
      hence "x div b ^ k mod b \<noteq> y div b ^ k mod b"
        using y k1 \<open>b>1\<close> aux1_digit_wise_gen_equiv[of "b" "c"] nth_digit_def apply auto
                proof - (* this ISAR proof was found by sledgehammer  *)
                        fix ka :: nat
                        assume a1: "b ^ k dvd c"
                        assume a2: "x div b ^ k mod b = (x + c) div b ^ k mod b"
                        assume a3: "y = x + c"
                        assume a4: "\<And>num k base. nth_digit num k base
                                    = num div base ^ k mod base"
                have f5: "\<forall>n na. (na::nat) + n - na = n"
                  by simp
                  have f6: "x div b ^ k + c div b ^ k = y div b ^ k"
                    using a3 a1 by (simp add: add.commute div_plus_div_distrib_dvd_left)
                  have f7: "\<forall>n. (x div b ^ k + n) mod b = (y div b ^ k + n) mod b"
                    using a3 a2 by (metis add.commute mod_add_right_eq)
                  have "\<forall>n na nb. ((nb::nat) mod na + n - (nb + n) mod na) mod na = 0"
                    by (metis (no_types) add.commute minus_mod_eq_mult_div mod_add_right_eq
                        mod_mult_self1_is_0)
                  then show "c div b ^ ka mod b = 0"
                    using f7 f6 f5 a4 by (metis (no_types) k1)
                qed
      then show ?thesis by (auto simp add: nth_digit_def)
    qed
    from this [of x y] this [of y x] notP
      have "\<forall>k. nth_digit x k b = nth_digit y k b \<Longrightarrow> x = y" apply(auto)
      using linorder_neqE_nat by blast}then show "?Q ==> ?P" by auto
qed

text \<open>A number is equal to the sum of its digits multiplied by powers of two\<close>

lemma digit_gen_sum_repr:
  assumes "n < b^c" and "b>1"
  shows "n = (\<Sum>k < c.((nth_digit n k b) * b^k))"
proof -
  have 1: "(c\<le>k \<longrightarrow> n<b^k)" for k using assms less_le_trans by fastforce
  hence nik: "c\<le>k \<longrightarrow> (nth_digit n k b = 0)" for k
    by (auto simp add: nth_digit_def)
  have "(\<Sum>r<c.((nth_digit n r b)*b^r))<b^c" apply(induct c, auto)
    subgoal for c
    proof -
      assume IH: "(\<Sum>r<c. nth_digit n r b * b ^ r) < b ^ c"
      have bound: "(nth_digit n c b) * b ^ c \<le> (b-1) * b^c"
        using nth_digit_bounded \<open>b>1\<close> by auto
      thus ?thesis using assms IH
        by (metis (no_types, lifting) bound add_mono_thms_linordered_field(1)
            add_mono_thms_linordered_field(5) le_less mult_eq_if not_one_le_zero)
    qed
    done
  hence "k\<ge>c \<longrightarrow> nth_digit (\<Sum>r<c.((nth_digit n r b)*b^r)) k b = 0" for k
    apply(auto simp add: nth_digit_def) using less_le_trans assms(2) by fastforce
  hence "\<forall>r\<ge>c.(nth_digit n r b
    = nth_digit (\<Sum>k<c.((nth_digit n k b)*b^k)) r b)" by (simp add: nik)
  moreover have "\<forall>r<c.(nth_digit n r b
               = nth_digit (\<Sum>k<c.((nth_digit n k b) * b^k)) r b)"
    using aux1_digit_gen_sum_repr assms by simp
  ultimately have "\<forall>r. nth_digit (\<Sum>k<c.((nth_digit n k b)*b^k)) r b
                    = nth_digit n r b" by (metis not_less)
  then show ?thesis
    using digit_wise_gen_equiv[of "b" "(\<Sum>k<c. nth_digit n k b * b ^ k)" "n"] \<open>b>1\<close> by auto
qed

lemma digit_gen_sum_repr_variant:
  assumes "b>1"
  shows "n = (\<Sum>k<n.((nth_digit n k b)*b^k))"
proof-
  have "n < b^n" using \<open>b>1\<close> apply (induct n, auto) by (simp add: less_trans_Suc)
  then show ?thesis using digit_gen_sum_repr \<open>b>1\<close> by auto
qed

lemma digit_gen_sum_index_variant:
  assumes "b>1" shows "r>n \<Longrightarrow>
  (\<Sum>k< n.((nth_digit n k b )*b^k)) = (\<Sum>k< r.(nth_digit n k b)*b^k)"
proof -
  assume "r>n"
  have "b^r > r" for r using \<open>b>1\<close>  by (induction r, auto simp add: less_trans_Suc)
  hence powb: "\<forall>r.(r>n \<longrightarrow> b^r>n)" using less_trans by auto
  hence "r > n \<longrightarrow> (nth_digit n r b = 0)" for r
    by (auto simp add: nth_digit_def)
  hence "r > n \<longrightarrow> (nth_digit n r b) * b^r = 0" for r by auto
  then show ?thesis using digit_gen_sum_repr digit_gen_sum_repr_variant powb \<open>n < r\<close> assms by auto
qed

text \<open>@{text nth_digit} extracts coefficients from a base-b digitwise expansion\<close>

lemma nth_digit_gen_power_series:
  fixes c b k q
  defines "b \<equiv> 2^(Suc c)"
  assumes bound: "\<forall>k. (f k) < b" (* < 2^c makes proof easier, but is too strong for const f *)
  shows "nth_digit (\<Sum>k=0..q. (f k) * b^k) t b = (if t\<le>q then (f t) else 0)"
proof (induction q arbitrary: t)
  case 0
  have "b>1" using b_def
    using one_less_numeral_iff power_gt1 semiring_norm(76) by blast
  have "f 0 < b" using bound by auto
  hence "t>0 \<longrightarrow> f 0 < b^t" using \<open>b>1\<close>
    using bound less_imp_le_nat less_le_trans by (metis self_le_power)
  thus ?case using nth_digit_def bound by auto
next
  case (Suc q)
  thus ?case
  proof (cases "t \<le> Suc q")
    case True
    have f_le_bound: "f k \<le> b-1" for k using bound apply auto
      by (metis Suc_pred b_def less_Suc_eq_le numeral_2_eq_2 zero_less_Suc zero_less_power)
    have series_bound: "(\<Sum>k = 0..q. f k * b ^ k) < b^(Suc q)"
      apply (induct q)
        subgoal using bound by (simp add: less_imp_le_nat)
        subgoal for q
          proof -
            assume asm: "(\<Sum>k = 0..q. f k * b ^ k) < b ^ Suc q"
            have "(\<Sum>k = 0..q. f k * b ^ k) + f (Suc q) * (b * b ^ q)
                \<le> (\<Sum>k = 0..q. f k * b ^ k) + (b-1) * (b * b ^ q)" using f_le_bound by auto
            also have "... < b^(Suc q) + (b-1) * (b * b ^ q)" using asm by auto
            also have "... \<le> b * b * b^q" apply auto
              by (metis One_nat_def Suc_neq_Zero b_def eq_imp_le mult.assoc mult_eq_if numerals(2)
                  power_not_zero)
            finally show ?thesis using asm by auto
          qed
        done
    hence "nth_digit ((\<Sum>k = 0..q. f k * b ^ k) + f (Suc q) * (b * b ^ q)) t b = f t"
      using Suc nth_digit_def apply (cases "t = Suc q", auto)
        subgoal using  Suc_n_not_le_n add.commute add.left_neutral b_def bound div_mult_self1
              less_imp_le_nat less_mult_imp_div_less mod_less not_one_le_zero one_less_numeral_iff
              one_less_power power_Suc semiring_norm(76) zero_less_Suc by auto
        subgoal
          proof -
            assume "t \<noteq> Suc q"
            hence "t < Suc q" using True by auto
            hence "nth_digit (f (Suc q) * b ^ Suc q + (\<Sum>k = 0..q. f k * b ^ k)) t b
                = nth_digit (\<Sum>k = 0..q. f k * b ^ k) t b"
              using aux2_digit_gen_sum_repr[of "\<Sum>k = 0..q. f k * b ^ k" "b" "Suc q" "t"
                    "f (Suc q)"] series_bound by auto
            hence "((\<Sum>k = 0..q. f k * b ^ k) + f (Suc q) * (b * b ^ q)) div b ^ t mod b
                  = (\<Sum>k = 0..q. f k * b ^ k) div b ^ t mod b"
              using nth_digit_def by (auto simp:add.commute)
            thus ?thesis using Suc[of "t"] nth_digit_def True \<open>t \<noteq> Suc q\<close> by auto
          qed
        done
    thus ?thesis using True by auto
  next
    case False (* t > Suc q *)
    hence "t \<ge> Suc (Suc q)" by auto
    have f_le_bound: "f k \<le> b-1" for k using bound apply auto
      by (metis Suc_pred b_def less_Suc_eq_le numeral_2_eq_2 zero_less_Suc zero_less_power)
    have bound: "(\<Sum>k = 0..q. f k * b ^ k) < b^(Suc q)" for q
      apply (induct q)
        subgoal using bound by (simp add: less_imp_le_nat)
        subgoal for q
          proof -
            assume asm: "(\<Sum>k = 0..q. f k * b ^ k) < b ^ Suc q"
            have "(\<Sum>k = 0..q. f k * b ^ k) + f (Suc q) * (b * b ^ q)
                \<le> (\<Sum>k = 0..q. f k * b ^ k) + (b-1) * (b * b ^ q)" using f_le_bound by auto
            also have "... < b^(Suc q) + (b-1) * (b * b ^ q)" using asm by auto
            also have "... \<le> b * b * b^q" apply auto
              by (metis One_nat_def Suc_neq_Zero b_def eq_imp_le mult.assoc mult_eq_if numerals(2)
                  power_not_zero)
            finally show ?thesis using asm by auto
          qed
        done
    have "(\<Sum>k = 0..q. f k * b ^ k) + f (Suc q) * (b * b ^ q) < (b ^ Suc (Suc q))"
      using bound[of "Suc q"] by auto
    also have "... \<le> b^t" using \<open>t \<ge> Suc (Suc q)\<close>
      apply auto by (metis b_def nat_power_less_imp_less not_le numeral_2_eq_2 power_Suc
                     zero_less_Suc zero_less_power)
    finally show ?thesis using \<open>t \<ge> Suc (Suc q)\<close> bound[of "Suc q"] nth_digit_def by auto
  qed
qed

text \<open>Equivalence condition for the @{text nth_digit} function \<^cite>\<open>"h10lecturenotes"\<close>
      (see equation 2.29)\<close>

lemma digit_gen_equiv:
  assumes "b>1"
  shows "d = nth_digit a k b \<longleftrightarrow> (\<exists>x.\<exists>y.(a = x * b^(k+1) + d*b^k +y \<and> d < b \<and> y < b^k))"
  (is "?P \<longleftrightarrow> ?Q")
proof
  assume p: ?P
  then show ?Q
  proof(cases "k<a")
    case True

    (* 3rd condition *)
    have "(\<Sum>i<k.((nth_digit a i b)*b^i)) < b^k"
    proof(induct k)
      case 0
      then show ?case by auto
    next
      case (Suc k)
      have "(\<Sum>i<Suc k. nth_digit a i b * b ^ i) = (nth_digit a k b) * b^k
            + (\<Sum>i<k.((nth_digit a i b)*b^i))" by simp
      moreover have " (nth_digit a k b) * b^k \<le> (b-1) * b^ k"
        using assms mult_le_mono nth_digit_bounded by auto
      moreover have "(\<Sum>i<k.((nth_digit a i b)*b^i)) < b ^ (Suc k)"
        using Suc.hyps assms order.strict_trans2 by fastforce
      ultimately show ?case using assms using Suc.hyps mult_eq_if by auto
    qed
    moreover define y where "y = (\<Sum>i<k.((nth_digit a i b)*b^i))"
    ultimately have 3: "y < b^k"  by blast

    (* 2nd condition*)
     have 2: "d < b" using nth_digit_bounded[of b a k] p assms by linarith

    (* 1st condition *)
    define x where "x =  (\<Sum>i=Suc k..<a. ((nth_digit a i b)*b^(i-Suc k)))"
    have "a = (\<Sum>i<a.((nth_digit a i b)*b^i))" using assms digit_gen_sum_repr_variant by blast
    hence s:"a = y + d * b^k
            + (\<Sum>i=Suc k..<a.((nth_digit a i b)*b^i))" using True y_def p
      by (metis (no_types, lifting) Suc_leI atLeast0LessThan gr_implies_not0
          linorder_not_less sum.atLeastLessThan_concat sum.lessThan_Suc)
    have "(\<Sum>n = Suc k..<a. nth_digit a n b * b ^ (n - Suc k) * b ^ Suc k)
          =  (\<Sum>i = Suc k..<a. nth_digit a i b * b ^ i)"
      apply (rule sum.cong; auto simp: algebra_simps)
      by (metis Suc_le_lessD Zero_not_Suc add_diff_cancel_left' diff_Suc_1 diff_Suc_Suc
          less_imp_Suc_add power_add power_eq_if)
    hence "x * b^(k+1) = (\<Sum>i=Suc k..<a.((nth_digit a i b)*b^i))"
      using x_def sum_distrib_right[of "\<lambda>i. (nth_digit a i b) *  b^(i - Suc k)"] by simp
    hence "a = x * b^(k+1) + d*b^k +y" using s by auto
    thus ?thesis using 2 3 by blast
  next
    case False
    then have "a < b^k" using assms power_gt_expt[of b k] by auto
    moreover have "d = 0" by (simp add: calculation nth_digit_def p)
    ultimately show ?thesis
      using assms by force
  qed
next
  assume ?Q
  then obtain x y where conds: "a = x * b^(k+1) + d*b^k +y \<and> d < b \<and> y < b^k" by auto
  hence "nth_digit a k b = nth_digit(x * b^(k+1) + d*b^k) k b"
    using aux3_digit_gen_sum_repr[of y b "k" "x*b + d"] assms by (auto simp: algebra_simps)
  hence "nth_digit a k b = nth_digit(d*b^k) k b"
    using aux2_digit_gen_sum_repr[of "d*b^k" "b" "k+1" k x] conds by auto
  then show ?P using conds nth_digit_def by simp
qed

end


(* Author: Tobias Nipkow, based on work by Daniel Somogyi *)

section \<open>Optimal BSTs: The `Cubic' Algorithm\label{sec:cubic}\<close>

theory Optimal_BST
imports Weighted_Path_Length
begin

subsection \<open>Function \<open>argmin\<close>\<close>

text \<open>Function \<open>argmin\<close> iterates over a list and returns the rightmost element
that minimizes a given function:\<close>

fun argmin :: "('a \<Rightarrow> ('b::linorder)) \<Rightarrow> 'a list \<Rightarrow> 'a" where
"argmin f (x#xs) =
  (if xs = [] then x else
   let m = argmin f xs in if f x < f m then x else m)"

text \<open>An optimized version that avoids repeated computation of \<open>f x\<close>:\<close>

fun argmin2 :: "('a \<Rightarrow> ('b::linorder)) \<Rightarrow> 'a list \<Rightarrow> 'a * 'b" where
"argmin2 f (x#xs) =
  (let fx = f x
   in if xs = [] then (x, fx)
      else let mfm = argmin2 f xs
           in if fx < snd mfm then (x,fx) else mfm)"

lemma argmin_argmin2[code]: "argmin f xs = (if xs = [] then undefined else fst(argmin2 f xs))"
apply(auto simp: argmin2_argmin)
apply (meson argmin.elims list.distinct(1))
done

lemma argmin_forall: "xs \<noteq> [] \<Longrightarrow> (\<And>x. x\<in>set xs \<Longrightarrow> P x) \<Longrightarrow> P (argmin f xs)"
by(induction xs) (auto simp: Let_def)

lemma argmin_in: "xs \<noteq> [] \<Longrightarrow> argmin f xs \<in> set xs"
using argmin_forall[of xs "\<lambda>x. x\<in>set xs"] by blast

lemma argmin_Min: "xs \<noteq> [] \<Longrightarrow> f (argmin f xs) = Min (f ` set xs)"
by(induction xs) (auto simp: min_def intro!: antisym)

lemma argmin_pairs: "xs \<noteq> [] \<Longrightarrow>
  (argmin f xs,f (argmin f xs)) = argmin snd (map (\<lambda>x. (x,f x)) xs)"
by (induction f xs rule:argmin.induct) (auto, smt snd_conv)

lemma argmin_map: "xs \<noteq> [] \<Longrightarrow> argmin c (map f xs) = f(argmin (c o f) xs)"
by(induction xs) (simp_all add: Let_def)

subsection \<open>The `Cubic' Algorithm\<close>

text \<open>We hide the details of the access frequencies \<open>a\<close> and \<open>b\<close> by working with an abstract
version of function \<open>w\<close> definied above (summing \<open>a\<close> and \<open>b\<close>). Later we interpret \<open>w\<close> accordingly.\<close>

locale Optimal_BST =
fixes w :: "int \<Rightarrow> int \<Rightarrow> nat"
begin

subsubsection \<open>Functions \<open>wpl\<close> and \<open>min_wpl\<close>\<close>

sublocale wpl where w = w .

text \<open>Function \<open>min_wpl i j\<close> computes the minimal weighted path length of any tree \<open>t\<close>
where @{prop"inorder t = [i..j]"}. It simply tries all possible indices between \<open>i\<close> and \<open>j\<close>
as the root. Thus it implicitly constructs all possible trees.\<close>

declare conj_cong [fundef_cong]
function min_wpl :: "int \<Rightarrow> int \<Rightarrow> nat" where
"min_wpl i j =
  (if i > j then 0
   else Min ((\<lambda>k. min_wpl i (k-1) + min_wpl (k+1) j) ` {i..j}) + w i j)"
by auto
termination by (relation "measure (\<lambda>(i,j). nat(j-i+1))") auto
declare min_wpl.simps[simp del]

text \<open>Note that for efficiency reasons we have pulled \<open>+ w i j\<close> out of \<open>Min\<close>.
In the lemma below this is reversed because it simplifies the proofs.
Similar optimizations are possible in other functions below.\<close>

lemma min_wpl_simps[simp]:
  "i > j \<Longrightarrow> min_wpl i j = 0"
  "i \<le> j \<Longrightarrow> min_wpl i j =
     Min ((\<lambda>k. min_wpl i (k-1) + min_wpl (k+1) j + w i j) ` {i..j})"
by(auto simp add: min_wpl.simps[of i j] Min_add_commute)

lemma upto_split1:
  "\<lbrakk> i \<le> j;  j \<le> k \<rbrakk> \<Longrightarrow> [i..k] = [i..j-1] @ [j..k]"
proof (induction j rule: int_ge_induct)
  case base thus ?case by (simp add: upto_rec1)
next
  case step thus ?case using upto_rec1 upto_rec2 by simp
qed

text\<open>Function @{const min_wpl} returns a lower bound for all possible BSTs:\<close>

theorem min_wpl_is_optimal:
  "inorder t = [i..j] \<Longrightarrow> min_wpl i j \<le> wpl i j t"
proof(induction i j t rule: wpl.induct)
  case 1
  thus ?case by(simp add: upto.simps split: if_splits)
next
  case (2 i j l k r)
  then show ?case
  proof cases
    assume "i > j" thus ?thesis by(simp)
  next
    assume [arith]: "\<not> i > j"

    note inorder = inorder_upto_split[OF "2.prems"]

    let ?M = "(\<lambda>k. min_wpl i (k-1) + min_wpl (k+1) j + w i j) ` {i..j}"
    let ?w = "min_wpl i (k-1) + min_wpl (k+1) j + w i j"

    have aux_min:"Min ?M \<le> ?w"
    proof (rule Min_le)
      show "finite ?M" by simp
      show "?w \<in> ?M" using inorder(3,4) by simp
    qed

    have "min_wpl i j = Min ?M" by(simp)
    also have "... \<le> ?w" by (rule aux_min)
    also have "... \<le> wpl i (k-1) l + wpl (k+1) j r + w i j"
      using inorder(1,2) "2.IH" by simp
    also have "... = wpl i j \<langle>l,k,r\<rangle>" by simp
    finally show ?thesis .
  qed
qed

text \<open>Now we show that the lower bound computed by @{const min_wpl}
is the wpl of an optimal tree that can be computed in the same manner.\<close>

subsubsection \<open>Function \<open>opt_bst\<close>\<close>

text\<open>This is the functional equivalent of the standard cubic imperative algorithm.
Unless it is memoized, the complexity is again exponential.
The pattern of recursion is the same as for @{const min_wpl} but instead of the minimal weight
it computes a tree with the minimal weight:\<close>

function opt_bst :: "int \<Rightarrow> int \<Rightarrow> int tree" where
"opt_bst i j =
  (if i > j then Leaf
   else argmin (wpl i j) [\<langle>opt_bst i (k-1), k, opt_bst (k+1) j\<rangle>. k \<leftarrow> [i..j]])"
by auto
termination by (relation "measure (\<lambda>(i,j) . nat(j-i+1))") auto
declare opt_bst.simps[simp del]

corollary opt_bst_simps[simp]:
  "i > j \<Longrightarrow> opt_bst i j = Leaf"
  "i \<le> j \<Longrightarrow> opt_bst i j =
     (argmin (wpl i j) [\<langle>opt_bst i (k-1), k, opt_bst (k+1) j\<rangle>. k \<leftarrow> [i..j]])"
by(auto simp add: opt_bst.simps[of i j])

text \<open>As promised, @{const opt_bst} computes a tree with the minimal wpl:\<close>

theorem wpl_opt_bst: "wpl i j (opt_bst i j) = min_wpl i j"
proof(induction i j rule: min_wpl.induct)
  case (1 i j)
  show ?case
  proof cases
    assume "i > j"
    thus ?thesis by(simp)
  next
    assume [arith]: "\<not> i > j"
    let ?ts = "[\<langle>opt_bst i (k-1), k, opt_bst (k+1) j\<rangle>. k \<leftarrow> [i..j]]"
    let ?M = "((\<lambda>k. min_wpl i (k-1) + min_wpl (k+1) j + w i j) ` {i..j})"
    have 1: "?ts \<noteq> []" by (auto simp add: upto.simps)
    have "wpl i j (opt_bst i j) = wpl i j (argmin (wpl i j) ?ts)" by simp
    also have "\<dots> = Min (wpl i j ` (set ?ts))"
      by(rule argmin_Min[OF 1])
    also have "\<dots> = Min ?M"
    proof (rule arg_cong[where f=Min])
      show "wpl i j ` (set ?ts) = ?M" using "1.IH"
        by (force simp: Bex_def image_iff "1.IH")
    qed
    also have "\<dots> = min_wpl i j" by simp
    finally show ?thesis .
  qed
qed

corollary opt_bst_is_optimal:
  "inorder t = [i..j] \<Longrightarrow> wpl i j (opt_bst i j) \<le> wpl i j t"
by (simp add: min_wpl_is_optimal wpl_opt_bst)

subsubsection \<open>Function \<open>opt_bst_wpl\<close>\<close>

text \<open>Function @{const opt_bst} is simplistic because it computes the wpl
of each tree anew rather than returning it with the tree. That is what \<open>opt_bst_wpl\<close> does:\<close>

function opt_bst_wpl :: "int \<Rightarrow> int \<Rightarrow> int tree \<times> nat" where
"opt_bst_wpl i j =
  (if i > j then (Leaf, 0)
   else argmin snd [let (t1,c1) = opt_bst_wpl i (k-1);
                        (t2,c2) = opt_bst_wpl (k+1) j
                     in (\<langle>t1,k,t2\<rangle>, c1 + c2 + w i j). k \<leftarrow> [i..j]])"
by auto
termination
  by (relation "measure (\<lambda>(i,j). nat(j-i+1))")(auto)
declare opt_bst_wpl.simps[simp del]

text\<open>Function @{const opt_bst_wpl} returns an optimal tree and its wpl:\<close>

lemma opt_bst_wpl_eq_pair:
  "opt_bst_wpl i j = (opt_bst i j, wpl i j (opt_bst i j))"
proof(induction i j rule: opt_bst_wpl.induct)
  case (1 i j)
  note [simp] = opt_bst_wpl.simps[of i j]
  show ?case
  proof cases
    assume "i > j" thus ?thesis using "1.prems" by auto
  next
    assume "\<not> i > j"
    thus ?thesis by (simp add: argmin_pairs comp_def "1.IH" cong: list.map_cong_simp)
  qed
qed

corollary opt_bst_wpl_eq_pair': "opt_bst_wpl i j = (opt_bst i j, min_wpl i j)"
by (simp add: opt_bst_wpl_eq_pair wpl_opt_bst)

end (* locale Optimal_BST *)

end


theory ex2_07 imports Main begin

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)"

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]"

value "pre_order (Node (Tip 2) 1 (Node (Tip 4) 3 (Tip 5)))"
value "post_order (Node (Tip 2) 1 (Node (Tip 4) 3 (Tip 5)))"

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

end


theory Graph_Definitions
  imports "Graph_Theory.Digraph_Component" "Graph_Theory.Shortest_Path"
    "Misc" "Graph_Theory_Batteries"
begin

context wf_digraph
begin

section \<open>K-neighborhood definition\<close>
definition k_neighborhood :: "'b weight_fun \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a set" where
  "k_neighborhood w v k = {u \<in> verts G. \<mu> w v u \<le> k } - {v}"

lemma k_nh_reachable: "u \<in> k_neighborhood w v k \<Longrightarrow> v \<rightarrow>\<^sup>* u"
  unfolding k_neighborhood_def
  using shortest_path_inf by fastforce

lemma source_nmem_k_nh: "v \<notin> k_neighborhood w v k"
  unfolding k_neighborhood_def by simp

section \<open>Diameter and finite diameter\<close>
text \<open>
The diameter is defined as the longest shortest path in the corresponding graph. If there is no path
between any two vertices in the graph, then the diameter is infinite.
We also make use of the notion of a @{text fin_diameter} which only considers the shortest path
between connected nodes.
\<close>

definition sp_costs :: "'b weight_fun \<Rightarrow> ereal set" where
  "sp_costs f = {c | u v c. u \<in> verts G \<and> v \<in> verts G \<and> \<mu> f u v = c}"

definition diameter :: "'b weight_fun \<Rightarrow> ereal" where
  "diameter f = Sup (sp_costs f)"

definition fin_sp_costs :: "'b weight_fun \<Rightarrow> ereal set" where
  "fin_sp_costs f = {c | u v c. u \<in> verts G \<and> v \<in> verts G \<and> \<mu> f u v = c \<and> c < \<infinity>}"

definition fin_diameter :: "'b weight_fun \<Rightarrow> ereal" where
  "fin_diameter f = Sup (fin_sp_costs f)"

subsection \<open>In general graphs\<close>

lemma empty_imp_dia_minf: "verts G = {} \<Longrightarrow> diameter w = -\<infinity>"
  unfolding diameter_def sp_costs_def
  by (simp add: bot_ereal_def)

lemma empty_imp_fin_dia_minf: "verts G = {} \<Longrightarrow> fin_diameter w = -\<infinity>"
  unfolding fin_diameter_def fin_sp_costs_def
  by (simp add: bot_ereal_def)

lemma dia_eq_fin_dia_if_finite: "diameter f < \<infinity> \<Longrightarrow> diameter f = fin_diameter f"
proof -
  assume "diameter f < \<infinity>"
  then have "\<infinity> \<notin> sp_costs f"
    unfolding diameter_def using Sup_eq_PInfty by auto
  then have "sp_costs f = fin_sp_costs f"
    unfolding sp_costs_def fin_sp_costs_def by auto
  then show ?thesis
    unfolding diameter_def fin_diameter_def by simp
qed

lemma fin_dia_lowerB: "\<lbrakk> u \<in> verts G; v \<in> verts G; \<mu> w u v < \<infinity>\<rbrakk>
  \<Longrightarrow> fin_diameter w \<ge> \<mu> w u v"
  unfolding fin_diameter_def fin_sp_costs_def
  by (metis (mono_tags, lifting) Sup_upper mem_Collect_eq)

lemma dia_lowerB: "\<lbrakk> u \<in> verts G; v \<in> verts G \<rbrakk>
  \<Longrightarrow> diameter w \<ge> \<mu> w u v"
  unfolding diameter_def sp_costs_def
  by (metis (mono_tags, lifting) Sup_upper mem_Collect_eq)

subsection \<open>In finite graphs\<close>

lemma (in fin_digraph) sp_costs_finite: "finite (sp_costs f)"
  unfolding sp_costs_def by auto

lemma (in fin_digraph) fin_sp_costs_finite: "finite (fin_sp_costs f)"
  unfolding fin_sp_costs_def by auto

lemma (in fin_digraph) ex_sp_eq_dia:
  "verts G \<noteq> {} \<Longrightarrow> \<exists>u \<in> verts G. \<exists>v \<in> verts G. \<mu> f u v = diameter f"
proof -
  assume "verts G \<noteq> {}"
  then have "sp_costs f \<noteq> {}"
    unfolding sp_costs_def using \<mu>_reach_conv by fastforce

  with sp_costs_finite have "\<exists>c \<in> sp_costs f. c = diameter f"
    by (simp add: Sup_in_set diameter_def)
  then show "?thesis" unfolding diameter_def
    unfolding sp_costs_def by auto
qed

text \<open>Analogous to the proof of @{thm fin_digraph.ex_sp_eq_dia}.\<close>
lemma (in fin_digraph) ex_sp_eq_fin_dia:
  "verts G \<noteq> {} \<Longrightarrow> \<exists>u \<in> verts G. \<exists>v \<in> verts G. \<mu> f u v = fin_diameter f"
proof -
  assume "verts G \<noteq> {}"
  then have "fin_sp_costs f \<noteq> {}"
    unfolding fin_sp_costs_def using \<mu>_reach_conv by fastforce

  with fin_sp_costs_finite have "\<exists>c \<in> fin_sp_costs f. c = fin_diameter f"
    by (simp add: Sup_in_set fin_diameter_def)
  then show "?thesis" unfolding fin_diameter_def
    unfolding fin_sp_costs_def by auto
qed

lemma (in fin_digraph) fin_diameter_finite: "fin_diameter f < \<infinity>"
proof(rule ccontr)
  fix f assume dia_infty: "\<not> fin_diameter f < \<infinity>"

  then have infty_cont: "\<infinity> \<in> fin_sp_costs f" if *: "fin_sp_costs f \<noteq> {}"
    unfolding fin_diameter_def using *
    by (metis ereal_infty_less(1) fin_sp_costs_finite infinite_growing less_Sup_iff)

  then show "False"
  proof(cases "fin_sp_costs f = {}")
    case True
    then have "fin_diameter f = -\<infinity>"
      unfolding fin_diameter_def by (simp add: bot_ereal_def)
    with dia_infty show ?thesis by simp
  next
    case False
    from infty_cont[OF this] dia_infty show ?thesis
      unfolding fin_diameter_def fin_sp_costs_def by auto
  qed
qed

lemma (in fin_digraph) ex_min_apath_eq_fin_dia:
  "\<lbrakk> verts G \<noteq> {}; \<forall>e \<in> arcs G. f e \<ge> 0 \<rbrakk>
  \<Longrightarrow> \<exists>u \<in> verts G. \<exists>v \<in> verts G. \<exists>p. apath u p v \<and> awalk_cost f p = fin_diameter f"
proof -
  assume "verts G \<noteq> {}" and w_non_neg: "\<forall>e \<in> arcs G. f e \<ge> 0"
  from ex_sp_eq_fin_dia[OF this(1)] obtain u v
    where u_v: "u \<in> verts G" "v \<in> verts G" and sp_eq_dia: "\<mu> f u v = fin_diameter f"
    by blast
  from sp_eq_dia have "\<mu> f u v < \<infinity>" using fin_diameter_finite by auto
  then have "u \<rightarrow>\<^sup>* v" using \<mu>_reach_conv by blast
  from min_cost_awalk[OF this] w_non_neg obtain p
    where "apath u p v" "\<mu> f u v = awalk_cost f p"
    by auto
  with u_v sp_eq_dia show ?thesis by auto
qed

subsection \<open>Relation between diameter and finite diameter\<close>

theorem dia_eq_fin_dia_if_strongly_con: "strongly_connected G \<Longrightarrow> diameter = fin_diameter"
proof
  fix f assume strongly_con: "strongly_connected G"
  then have "\<infinity> \<notin> sp_costs f"
    unfolding sp_costs_def using \<mu>_reach_conv by auto
  then have "sp_costs f = fin_sp_costs f"
    unfolding fin_sp_costs_def sp_costs_def by auto
  then show "diameter f = fin_diameter f"
    unfolding diameter_def fin_diameter_def by auto
qed

end

section \<open>N-nearest vertices\<close>
text \<open>
The definition of @{text n_nearest_verts} is used to formalize the abstract behaviour of the
Dijkstra algorithm which iteratively visits the nearest undiscovered vertex until all
vertices are discovered.
\<close>
context wf_digraph begin

definition unvisited_verts :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a set" where
"unvisited_verts u U = {x. x \<in> verts G - U \<and> u \<rightarrow>\<^sup>* x}"

definition nearest_vert :: "'b weight_fun \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> 'a" where
"nearest_vert w u U =
  (SOME x. x \<in> unvisited_verts u U \<and> (\<forall>y \<in> unvisited_verts u U. \<mu> w u y \<ge> \<mu> w u x))"

inductive n_nearest_verts :: "'b weight_fun \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a set \<Rightarrow> bool"
  where
zero_nnvs: "u \<in> verts G \<Longrightarrow> n_nearest_verts _ u 0 {u}" |
n_nnvs_unvis: "\<lbrakk> n_nearest_verts w u n U; unvisited_verts u U \<noteq> {}\<rbrakk>
   \<Longrightarrow> n_nearest_verts w u (Suc n) (insert (nearest_vert w u U) U)" |
n_nnvs_vis: "\<lbrakk> n_nearest_verts w u n U; unvisited_verts u U = {} \<rbrakk>
   \<Longrightarrow> n_nearest_verts w u (Suc n) U"

inductive_cases nnvs_ind_cases: "n_nearest_verts w u n U"
thm nnvs_ind_cases

subsection \<open>In general graphs\<close>

lemma source_mem_nnvs: "n_nearest_verts w u n U \<Longrightarrow> u \<in> verts G"
  by (induction rule: n_nearest_verts.induct) auto

lemma unvis_insert: "unvisited_verts u (insert x U) = (unvisited_verts u U) - {x}"
  unfolding unvisited_verts_def by auto

lemma disj_unvis_vis: "unvisited_verts u U \<inter> U = {}"
  unfolding unvisited_verts_def by auto

lemma nnvs_finite: "n_nearest_verts w u n U \<Longrightarrow> finite U"
  by (induction rule: n_nearest_verts.induct) auto

lemma nnvs_card_le_n: "n_nearest_verts w u n U \<Longrightarrow> card U \<le> Suc n"
  by (induction rule: n_nearest_verts.induct) (auto simp: card_insert_le_m1)

lemma nnvs_mem: "n_nearest_verts w u n U \<Longrightarrow> u \<in> U"
  by (induction rule: n_nearest_verts.induct) auto

lemma unvis_empty: "unvisited_verts u {a. u \<rightarrow>\<^sup>* a} = {}"
  unfolding unvisited_verts_def by auto

end

subsection \<open>In finite graphs\<close>
context fin_digraph begin

lemma k_nh_finite: "finite (k_neighborhood w v k)"
  unfolding k_neighborhood_def using finite_verts by force

lemma unvis_finite: "finite (unvisited_verts u U)"
  unfolding unvisited_verts_def using finite_verts by auto

lemma ex_unvis_vert:"\<lbrakk> unvisited_verts u U \<noteq> {} \<rbrakk> \<Longrightarrow>
   \<exists>x \<in> unvisited_verts u U. (\<forall>y \<in> unvisited_verts u U. \<mu> w u y \<ge> \<mu> w u x)"
  unfolding nearest_vert_def using unvis_finite
proof(induction "unvisited_verts u U" arbitrary: u U rule: finite_induct)
  case (insert x F)
  then have "F = unvisited_verts u U - {x}"
    by auto
  then have F: "F = unvisited_verts u (insert x U)"
    using unvis_insert[symmetric] by simp

  show ?case
  proof(cases "unvisited_verts u (insert x U) = {}")
    case True
    with insert.prems show ?thesis using unvis_insert by auto
  next
    case False
    from insert(3)[OF F this] obtain x' where "x' \<in> unvisited_verts u (insert x U)"
      and "\<forall>y\<in>unvisited_verts u (insert x U). \<mu> w u x' \<le> \<mu> w u y" by blast
    note x' = this

    show ?thesis
    proof(cases "\<mu> w u x' \<le> \<mu> w u x")
      case True
      from x' F insert.hyps(4) have "x' \<in> unvisited_verts u U" by blast
      moreover
      have "\<forall>y \<in> unvisited_verts u U. \<mu> w u x' \<le> \<mu> w u y"
        using F True insert.hyps(4) x' by auto
      ultimately show ?thesis by blast
    next
      case False
      with x' have "\<forall>y \<in> unvisited_verts u (insert x U). \<mu> w u x \<le> \<mu> w u y"
        by fastforce
      with F insert.hyps(4) have "\<forall>y \<in> unvisited_verts u U. \<mu> w u x \<le> \<mu> w u y"
        by fastforce
      with insert.hyps(4) show ?thesis by blast
    qed
  qed
qed blast

lemma some_unvis_vert:
  fixes x
  assumes "unvisited_verts u U \<noteq> {}" and "x = nearest_vert w u U"
  shows "x \<in> unvisited_verts u U"
    and "\<forall>y \<in> unvisited_verts u U. \<mu> w u y \<ge> \<mu> w u x"
proof -
  define nv where "nv \<equiv> \<lambda>x. x \<in> unvisited_verts u U
    \<and> (\<forall>y\<in>unvisited_verts u U. \<mu> w u x \<le> \<mu> w u y)"

  from ex_unvis_vert[OF assms(1)]
  obtain x' where "nv x'" unfolding nv_def
    by blast
  then have "nv (SOME x. nv x)" using some_eq_ex by blast
  with assms(2) have "nv x" unfolding nearest_vert_def nv_def by blast
  then show
    "x \<in> unvisited_verts u U" and
    "\<forall>y \<in> unvisited_verts u U. \<mu> w u y \<ge> \<mu> w u x"
    unfolding nv_def by blast+
qed

lemma nearest_vert_unvis: "unvisited_verts u U \<noteq> {}
  \<Longrightarrow> nearest_vert w u U \<in> unvisited_verts u U"
  using some_unvis_vert by simp

lemma nearest_vert_not_mem: "unvisited_verts u U \<noteq> {}
  \<Longrightarrow> nearest_vert w u U \<notin> U"
  using disj_unvis_vis some_unvis_vert(1) by fastforce

lemma nearest_vert_reachable: "unvisited_verts u U \<noteq> {}
  \<Longrightarrow> u \<rightarrow>\<^sup>* nearest_vert w u U"
  using some_unvis_vert(1) unvisited_verts_def by auto

lemma nnvs_card_ge_n: "\<lbrakk> n_nearest_verts w u n U; unvisited_verts u U \<noteq> {} \<rbrakk>
  \<Longrightarrow> card U \<ge> Suc n"
proof(induction rule: n_nearest_verts.induct)
  case (n_nnvs_unvis w u n U)
  have "nearest_vert w u U \<notin> U"
    using nearest_vert_unvis[OF n_nnvs_unvis.hyps(2)] disj_unvis_vis by auto
  then have "card (insert (nearest_vert w u U) U) = Suc (card U)"
    using n_nnvs_unvis.hyps(1) nnvs_finite by auto
  with n_nnvs_unvis.IH[OF n_nnvs_unvis.hyps(2)] show ?case by simp
qed simp_all

corollary nnvs_card_eq_n: "\<lbrakk> n_nearest_verts w u n U; unvisited_verts u U \<noteq> {} \<rbrakk>
  \<Longrightarrow> card U = Suc n"
  using nnvs_card_le_n nnvs_card_ge_n le_antisym by blast

subsubsection \<open>Reachability and n-nearest vertices\<close>

lemma reachable_subs_nnvs: "\<lbrakk> u \<in> verts G; Suc n \<le> card {x. u \<rightarrow>\<^sup>* x} \<rbrakk>
 \<Longrightarrow> \<exists>A \<subseteq> {x. u \<rightarrow>\<^sup>* x}. card A = Suc n \<and> n_nearest_verts w u n A"
proof(induction n)
  case 0
  then have "{u} \<subseteq> {x. u \<rightarrow>\<^sup>* x}" by simp
  with zero_nnvs[OF \<open>u \<in> verts G\<close>] show ?case
    by (metis card_Suc_eq card.empty empty_iff)
next
  case (Suc n)
  from Suc.IH[OF Suc.prems(1)] obtain A
    where "A \<subseteq> {a. u \<rightarrow>\<^sup>* a}" and "card A = Suc n" and "n_nearest_verts w u n A"
    using Suc.prems(2) Suc_leD by blast
  note A = this

  show ?case
  proof(cases "Suc n = card {a. u \<rightarrow>\<^sup>* a}")
    case True
    with A Suc.prems(2) show ?thesis by linarith
  next
    case False
    with Suc.prems(2) have "Suc n < card {a. u \<rightarrow>\<^sup>* a}" by simp
    with A have "\<exists>x \<in> {a. u \<rightarrow>\<^sup>* a}. x \<notin> A"
      using subset_antisym by fastforce
    then have unvis_non_empty: "unvisited_verts u A \<noteq> {}"
      unfolding unvisited_verts_def using reachable_in_verts(2) by auto

    let ?A' = "insert (nearest_vert w u A) A"

    note n_nnvs_unvis[OF A(3) unvis_non_empty]
    moreover
    from A(1) have "?A' \<subseteq> {a. u \<rightarrow>\<^sup>* a}"
      using some_unvis_vert[OF unvis_non_empty]
      by (simp add: unvisited_verts_def)
    moreover
    note nearest_vert_not_mem[OF unvis_non_empty]
    with A(2) card.insert[OF nnvs_finite[OF A(3)]] nnvs_finite
    have "card ?A' = Suc (Suc n)" by auto

    ultimately show ?thesis by blast
  qed
qed

corollary all_reachable_eq_nnvs: "\<lbrakk> U = {x. u \<rightarrow>\<^sup>* x}; card U = Suc n \<rbrakk>
 \<Longrightarrow> n_nearest_verts w u n U"
  using reachable_subs_nnvs reachable_verts_finite reachable_in_verts(1)
  by (metis card_Suc_eq card_subset_eq insertI1 le_Suc_eq mem_Collect_eq)

lemma all_reachable_eq_nnvs_Suc:
  assumes "u \<in> verts G" and "U = {x. u \<rightarrow>\<^sup>* x}" and "Suc n \<ge> card U"
  shows "n_nearest_verts w u n U"
proof -
  note * = all_reachable_eq_nnvs le_Suc_eq
  show ?thesis using assms
  proof(induction n)
    case 0
    then show ?case using * reachable_verts_finite by auto
  next
    case (Suc n)
    then show ?case using  * n_nnvs_vis unvis_empty by auto
  qed
qed

lemma nnvs_imp_reachable:"\<lbrakk> n_nearest_verts w u n A; Suc n \<le> card {x. u \<rightarrow>\<^sup>* x} \<rbrakk>
 \<Longrightarrow> A \<subseteq> {x. u \<rightarrow>\<^sup>* x} \<and> card A = Suc n"
proof(induction rule: n_nearest_verts.induct)
  case (zero_nnvs u)
  then show ?case using nearest_vert_reachable by simp
next
  case (n_nnvs_unvis w u n U)
  then show ?case using nearest_vert_reachable
    by (simp add: nearest_vert_not_mem nnvs_finite)
next
  case (n_nnvs_vis w u n U)
  from n_nnvs_vis.hyps(2) have "{a. u \<rightarrow>\<^sup>* a} \<subseteq> U"
    unfolding unvisited_verts_def using reachable_in_verts(2) by auto
  moreover
  from n_nnvs_vis have "U \<subseteq> {a. u \<rightarrow>\<^sup>* a}"
    using Suc_leD by blast
  ultimately show ?case
    using n_nnvs_vis by auto
qed

corollary nnvs_imp_all_reachable:
  "\<lbrakk> n_nearest_verts w u n U; Suc n = card {x. u \<rightarrow>\<^sup>* x} \<rbrakk>
  \<Longrightarrow> U = {x. u \<rightarrow>\<^sup>* x}"
  using nnvs_imp_reachable
  by (simp add: card_subset_eq reachable_verts_finite)

lemma nnvs_imp_all_reachable_Suc:
  assumes "n_nearest_verts w u n U"  "Suc n \<ge> card {x. u \<rightarrow>\<^sup>* x}"
  shows "U = {x. u \<rightarrow>\<^sup>* x}"
  using assms
proof(induction rule: n_nearest_verts.induct)
  case (zero_nnvs u)
  have u_mem: "u \<in> {a. u \<rightarrow>\<^sup>* a}" by (simp add: zero_nnvs.hyps)
  moreover
  from u_mem have "card {a. u \<rightarrow>\<^sup>* a} = 1"
    using le_Suc_eq reachable_verts_finite zero_nnvs.prems by force
  ultimately show ?case by (metis card_1_singletonE singletonD)
next
  case (n_nnvs_unvis w u n U)
  then show ?case
    by (metis le_Suc_eq n_nearest_verts.n_nnvs_unvis
        nnvs_imp_all_reachable unvis_empty)
next
  case (n_nnvs_vis w u n U)
  then show ?case
    by (metis le_Suc_eq n_nearest_verts.n_nnvs_vis
        nnvs_imp_all_reachable)
qed

lemma nnvs_subs_verts: "n_nearest_verts w u n U \<Longrightarrow> U \<subseteq> verts G"
proof(induction rule: n_nearest_verts.induct)
  case (n_nnvs_unvis w u n U)
  then have "nearest_vert w u U \<in> unvisited_verts u U"
    by (simp add: nearest_vert_unvis)
  then have "nearest_vert w u U \<in> verts G"
    unfolding unvisited_verts_def by simp
  with n_nnvs_unvis show ?case by blast
qed auto

subsubsection \<open>Relation between n-nearest vertices and k-neighborhood\<close>

lemma unvis_nearest_vert_contr:
  "\<lbrakk> n_nearest_verts w u n U; x \<in> U; x \<noteq> u; y \<in> unvisited_verts u U; \<mu> w u y < \<mu> w u x \<rbrakk>
  \<Longrightarrow> False"
proof(induction rule: n_nearest_verts.induct)
  case (n_nnvs_unvis w u n U)
  then obtain x where x: "x \<in> insert (nearest_vert w u U) U - {u}"
    "\<exists>y\<in>unvisited_verts u (insert (nearest_vert w u U) U). \<mu> w u y < \<mu> w u x" by blast
  then show ?case
  proof(cases "x = nearest_vert w u U")
    case True
    with n_nnvs_unvis x show ?thesis
      using some_unvis_vert unvis_insert by (metis DiffD1 not_le)
  next
    case False
    with n_nnvs_unvis x show ?thesis
      using unvis_insert by (auto, metis not_le some_unvis_vert(2))
  qed
qed blast

lemma nnvs_subs_k_nh:
  assumes nnvs: "n_nearest_verts w u n U"
      and card_N: "card (k_neighborhood w u k) \<ge> n"
    shows "U - {u} \<subseteq> k_neighborhood w u k"
proof -
  from nnvs_card_le_n[OF nnvs] have card_U: "card (U - {u}) \<le> n"
    using nnvs_mem[OF nnvs] nnvs_finite[OF nnvs] by auto
  show ?thesis
  proof(rule ccontr, auto, rule ccontr)
    fix x assume x: "x \<in> U" "x \<notin> k_neighborhood w u k" "x \<noteq> u"
    then have "{x, u} \<subseteq> U" using nnvs_mem[OF nnvs] by auto
    from card_mono[OF nnvs_finite[OF nnvs], OF this] have "card U \<ge> 2"
      using x(3) by auto
    then have "card (U - {u} - {x}) < card (U - {u})"
      using nnvs nnvs_finite nnvs_mem x(1,3) by auto
    also have "\<dots> \<le> card (k_neighborhood w u k)"
      using card_N card_U by linarith
    finally have "card (U - {u} - {x}) < card (k_neighborhood w u k)" .
    then obtain y where y: "y \<in> k_neighborhood w u k" "y \<notin> U - {u} - {x}"
      using nnvs_finite[OF nnvs] by (meson card_mono finite_Diff not_le subset_iff)
    from k_nh_reachable[OF y(1)] y x(2) have y_unvis: "y \<in> unvisited_verts u U"
      unfolding unvisited_verts_def k_neighborhood_def by blast

    from y have "\<mu> w u y \<le> k" unfolding k_neighborhood_def by simp
    moreover
    from x have "\<mu> w u x > k" unfolding k_neighborhood_def
      using nnvs_subs_verts[OF nnvs] by fastforce
    ultimately have "\<mu> w u y < \<mu> w u x" by simp
    from unvis_nearest_vert_contr[OF nnvs \<open>x \<in> U\<close> \<open>x \<noteq> u\<close> y_unvis this] show "False" .
  qed
qed

lemma k_nh_subs_nnvs:
  assumes nnvs: "n_nearest_verts w u n U"
      and card_nh: "card (k_neighborhood w u k) < card U"
    shows "k_neighborhood w u k \<subseteq> U"
proof(rule ccontr)
  assume "\<not> k_neighborhood w u k \<subseteq> U"
  then obtain v where v: "v \<in> verts G" "v \<noteq> u" "\<mu> w u v \<le> k" "v \<notin> U"
    unfolding k_neighborhood_def by auto
  then have v_unvis: "v \<in> unvisited_verts u U"
    unfolding unvisited_verts_def
    using \<mu>_reach_conv[of w u v] PInfty_neq_ereal(1)[of k] by force

  let ?close_verts = "{v \<in> verts G. \<mu> w u v \<le> k} - {u}"
  let ?far_verts = "{v \<in> verts G. \<mu> w u v > k} - {u}"

  have vert_part: "verts G - {u} = ?close_verts \<union> ?far_verts"
    "?close_verts \<inter> ?far_verts = {}" by auto
  with finite_verts have "finite ?close_verts" and "finite ?far_verts"
    by auto

  have "card (k_neighborhood w u k) \<le> card (U - {u})"
    using card_nh nnvs nnvs_finite nnvs_mem by auto
  then have "card ?close_verts \<le> card (U - {u})"
    unfolding k_neighborhood_def
    by (cases "\<mu> w u u \<le> k") (auto simp: insert_absorb source_mem_nnvs[OF nnvs])

  have "?far_verts \<inter> (U - {u}) \<noteq> {}"
  proof(rule ccontr, simp)
    assume "?far_verts \<inter> (U - {u}) = {}"
    then have "U - {u} \<subseteq> ?close_verts"
      using nnvs_subs_verts[OF nnvs] by auto
    then have "card (U - {u}) \<le> card ?close_verts"
      by (simp add: card_mono)
    with \<open>card ?close_verts \<le> card (U - {u})\<close> have "?close_verts = U - {u}"
      using card_seteq[OF \<open>finite ?close_verts\<close> \<open>U - {u} \<subseteq> ?close_verts\<close>]
      by blast
    then show "False" using v by auto
  qed
  then obtain x where x: "x \<in> ?far_verts" "x \<in> U" "x \<noteq> u"
    by auto
  then have "\<mu> w u v < \<mu> w u x" using \<open>\<mu> w u v \<le> k\<close> by auto
  from unvis_nearest_vert_contr[OF nnvs x(2,3) v_unvis this]
  show "False" .
qed

end

end


theory Ch02
  imports Main
begin

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

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

lemma add_0[simp]: "add n 0 = n"
  apply (induction n)
  apply (auto)
  done

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

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

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

value "double 42"

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

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

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

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

value "snoc [] a"
value "snoc [a,b,c,d] e"

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

value "rerverse []"
value "reverse [a,b,c]"

lemma rev_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

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

value "(sum_upto 3)"
value "(sum_upto 10)"

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

(* Exercise 2.6 *)
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

value "(Node (Node Tip a Tip) b (Node Tip c Tip))"

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

value "contents ((Node (Node Tip a Tip) b (Node Tip c Tip)))"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node t1 x t2) = x + (sum_tree t1) + (sum_tree t2)"

value "sum_tree (Node (Node Tip 1 Tip) 2 (Node Tip 3 Tip))"

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

(* Exercise 2.7 *)
datatype 'a tree2 = Leaf 'a | Node "'a tree2" 'a "'a tree2"

fun mirror :: "'a tree2 \<Rightarrow> 'a tree2" where
"mirror (Leaf x) = Leaf x" |
"mirror (Node t1 x t2) = Node (mirror t2) x (mirror t1)"

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
"pre_order (Leaf x) = [x]" |
"pre_order (Node t1 x t2) = x # pre_order t1 @ pre_order t2"

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
"post_order (Leaf x) = [x]" |
"post_order (Node t1 x t2) = post_order t1 @ post_order t2 @ [x]"

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

(* Exercise 2.8 *)
fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse x [] = []" |
"intersperse x (y # ys) = [y, x] @ intersperse x ys"

value "intersperse a [a,b,c]"
value "intersperse 1 [1,2,3] :: int list"

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

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

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

(* Exercise 2.10 *)
datatype tree0 = Tip | Node tree0 tree0

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

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

(* Exercise 2.11 *)
datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var n = n" |
"eval (Const c) _ = c" |
"eval (Add l r) n = (eval l n) + (eval r n)" |
"eval (Mult l r) n = (eval l n) * (eval r n)"

value "eval (Add (Mult (Const 2) Var) (Const 3)) i"

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

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

(* TODO: fun coeffs :: "exp \<Rightarrow> int list" *)

(* TODO: theorem evalp_coeffs: "evalp (coeffs e) x = eval e x" *)

end


theory primes_mod_four
imports "Main"
        "HOL-Computational_Algebra.Primes"
begin

lemma aux1:
  fixes m k :: "nat"
  assumes "(m * k) mod 4 = 3"
  shows "m mod 4 = 3 \<or> k mod 4 = 3"
  by (smt One_nat_def add_Suc_right assms mod_double_modulus mod_mod_trivial
       mod_mult_right_eq mult.right_neutral mult_0_right mult_2_right
       not_mod2_eq_Suc_0_eq_0 numeral_2_eq_2 numeral_3_eq_3
       numeral_Bit0 one_add_one zero_le zero_less_Suc zero_neq_numeral)

\<comment> \<open>an alternative proof\<close>
lemma aux1':
  fixes m k :: "nat"
  assumes "(m * k) mod 4 = 3"
  shows "m mod 4 = 3 \<or> k mod 4 = 3"
proof (rule ccontr)
  assume "\<not> (m mod 4 = 3 \<or> k mod 4 = 3)"
  moreover have "m mod 4 = 0 \<or> m mod 4 = 1 \<or> m mod 4 = 2 \<or> m mod 4 = 3"
    by linarith
  moreover have "k mod 4 = 0 \<or> k mod 4 = 1 \<or> k mod 4 = 2 \<or> k mod 4 = 3"
    by linarith
  moreover have "(m * k) mod 4 = ((m mod 4) * (k mod 4)) mod 4"
    by (simp add: mod_mult_eq)
  ultimately show False
    using \<open>(m * k) mod 4 = 3\<close> by auto
qed

lemma aux2:
  fixes n :: "nat"
  shows "n mod 4 = 3 \<longrightarrow> (\<exists> p. prime p \<and> p dvd n \<and> p mod 4 = 3)"
proof (induct n rule: less_induct)
  case (less n)
  then have IH: "\<And> m. m < n \<Longrightarrow> m mod 4 = 3 \<longrightarrow>
                    (\<exists> p. prime p \<and> p dvd m \<and> p mod 4 = 3)" by simp
  show "n mod 4 = 3 \<longrightarrow> (\<exists> p. prime p \<and> p dvd n \<and> p mod 4 = 3)"
  proof (clarify)
    assume h: "n mod 4 = 3"
    show "(\<exists> p. prime p \<and> p dvd n \<and> p mod 4 = 3)"
    proof cases
      assume "prime n"
      with h show ?thesis by auto
    next
      assume "\<not> prime n"
      moreover from h have "n \<ge> 2" by linarith
      ultimately obtain m k where "m < n" and "k < n" and "n = m * k"
        by (metis Suc_1 dvd_def dvd_imp_le le_neq_implies_less
              less_le_trans mult.commute mult.right_neutral
              nat_mult_eq_cancel_disj prime_nat_naiveI zero_less_Suc)
      have "m mod 4 = 3 \<or> k mod 4 = 3"
        using \<open>n = m * k\<close> aux1 h by blast
      show "\<exists>p. prime p \<and> p dvd n \<and> p mod 4 = 3"
        using IH \<open>k < n\<close> \<open>m < n\<close> \<open>m mod 4 = 3 \<or> k mod 4 = 3\<close> \<open>n = m * k\<close>
              prime_dvd_mult_eq_nat by blast
    qed
  qed
qed

theorem infinite_primes_three_mod_four: "infinite {p :: nat. prime p \<and> p mod 4 = 3}"
proof
  let ?S = "{p :: nat. prime p \<and> p mod 4 = 3}"
  assume fS: "finite ?S"
  let ?u = "4 * (\<Prod> x \<in> ?S. x) - 1"
  have h1: "(\<Prod> x \<in> ?S. x) \<ge> 1"
    by (metis (no_types, lifting) mem_Collect_eq prime_ge_1_nat prod_ge_1)
  hence h2: "(\<Prod> x \<in> ?S. x) = (\<Prod> x \<in> ?S. x) - 1 + 1"
    by linarith
  have "?u mod 4 = 3"
    by (subst h2) (simp add: ring_distribs)
  then obtain p where "prime p" and "p dvd ?u" and "p mod 4 = 3"
    using aux2 by blast
  have "p \<notin> ?S"
  proof
    assume "p \<in> ?S"
    hence "p dvd 4 * (\<Prod> x \<in> ?S. x)"
      by (simp add: dvd_prod_eqI fS)
    with \<open>p dvd ?u\<close> have "p dvd 1"
      by (metis (no_types, lifting) dvd_diffD1 h1 less_one
          mult_eq_0_iff not_le zero_neq_numeral)
    thus False
      using \<open>prime p\<close> not_prime_unit by blast
  qed
  moreover with \<open>prime p\<close> \<open>p mod 4 = 3\<close> have "p \<in> ?S" by auto
  ultimately show False by simp
qed

end


(*
  File:    Triangle.thy
  Author:  Manuel Eberl <eberlm@in.tum.de>

  Sine and cosine laws, angle sum in a triangle, congruence theorems,
  Isosceles Triangle Theorem
*)

section \<open>Basic Properties of Triangles\<close>
theory Triangle
imports
  Angles
begin

text \<open>
  We prove a number of basic geometric properties of triangles. All theorems hold
  in any real inner product space.
\<close>
subsection \<open>Thales' theorem\<close>

theorem thales:
  fixes A B C :: "'a :: real_inner"
  assumes "dist B (midpoint A C) = dist A C / 2"
  shows   "orthogonal (A - B) (C - B)"
proof -
  have "dist A C ^ 2 = dist B (midpoint A C) ^ 2 * 4"
    by (subst assms) (simp add: field_simps power2_eq_square)
  thus ?thesis
    by (auto simp: orthogonal_def dist_norm power2_norm_eq_inner midpoint_def
                   algebra_simps inner_commute)
qed

subsection \<open>Sine and cosine laws\<close>

text \<open>
  The proof of the Law of Cosines follows trivially from the definition of the angle,
  the definition of the norm in vector spaces with an inner product and the bilinearity
  of the inner product.
\<close>

lemma cosine_law_vector:
  "norm (u - v) ^ 2 = norm u ^ 2 + norm v ^ 2 - 2 * norm u * norm v * cos (vangle u v)"
  by (simp add: power2_norm_eq_inner cos_vangle algebra_simps inner_commute)

lemma cosine_law_triangle:
  "dist b c ^ 2 = dist a b ^ 2 + dist a c ^ 2 - 2 * dist a b * dist a c * cos (angle b a c)"
  using cosine_law_vector[of "b - a" "c - a"]
  by (simp add: dist_norm angle_def vangle_commute norm_minus_commute)

text \<open>
  According to our definition, angles are always between $0$ and $\pi$ and therefore,
  the sign of an angle is always non-negative. We can therefore look at
  $\sin(\alpha)^2$, which we can express in terms of $\cos(\alpha)$ using the
  identity $\sin(\alpha)^2 + \cos(\alpha)^2 = 1$. The remaining proof is then a
  trivial consequence of the definitions.
\<close>
lemma sine_law_triangle:
  "sin (angle a b c) * dist b c = sin (angle b a c) * dist a c" (is "?A = ?B")
proof (cases "a = b")
  assume neq: "a \<noteq> b"
  show ?thesis
  proof (rule power2_eq_imp_eq)
    from neq have "(sin (angle a b c) * dist b c) ^ 2 * dist a b ^ 2 =
                     dist a b ^ 2 * dist b c ^ 2 - ((a - b) \<bullet> (c - b)) ^ 2"
      by (simp add: sin_squared_eq cos_angle dist_commute field_simps)
    also have "\<dots> = dist a b ^ 2 * dist a c ^ 2 - ((b - a) \<bullet> (c - a)) ^ 2"
      by (simp only: dist_norm power2_norm_eq_inner)
         (simp add: power2_eq_square algebra_simps inner_commute)
    also from neq have "\<dots> = (sin (angle b a c) * dist a c) ^ 2 * dist a b ^ 2"
      by (simp add: sin_squared_eq cos_angle dist_commute field_simps)
    finally show "?A^2 = ?B^2" using neq by (subst (asm) mult_cancel_right) simp_all
  qed (auto intro!: mult_nonneg_nonneg sin_angle_nonneg)
qed simp_all

text \<open>
  The following forms of the Law of Sines/Cosines are more convenient for eliminating
  sines/cosines from a goal completely.
\<close>

lemma cosine_law_triangle':
  "2 * dist a b * dist a c * cos (angle b a c) = (dist a b ^ 2 + dist a c ^ 2 - dist b c ^ 2)"
  using cosine_law_triangle[of b c a] by simp

lemma cosine_law_triangle'':
  "cos (angle b a c) = (dist a b ^ 2 + dist a c ^ 2 - dist b c ^ 2) / (2 * dist a b * dist a c)"
  using cosine_law_triangle[of b c a] by simp

lemma sine_law_triangle':
  "b \<noteq> c \<Longrightarrow> sin (angle a b c) = sin (angle b a c) * dist a c / dist b c"
  using sine_law_triangle[of a b c] by (simp add: divide_simps)

lemma sine_law_triangle'':
  "b \<noteq> c \<Longrightarrow> sin (angle c b a) = sin (angle b a c) * dist a c / dist b c"
  using sine_law_triangle[of a b c] by (simp add: divide_simps angle_commute)

subsection \<open>Sum of angles\<close>

context
begin

private lemma gather_squares: "a * (a * b) = a^2 * (b :: real)"
  by (simp_all add: power2_eq_square)

private lemma eval_power: "x ^ numeral n = x * x ^ pred_numeral n"
  by (subst numeral_eq_Suc, subst power_Suc) simp

text \<open>
  The proof that the sum of the angles in a triangle is $\pi$ is somewhat more
  involved. Following the HOL Light proof by John Harrison, we first prove
  that $\cos(\alpha + \beta + \gamma) = -1$ and $\alpha + \beta + \gamma \in [0;3\pi)$,
  which then implies the theorem.

  The main work is proving $\cos(\alpha + \beta + \gamma)$. This is done using the
  addition theorems for the sine and cosine, then using the Laws of Sines to eliminate
  all $\sin$ terms save $\sin(\gamma)^2$, which only appears squared in the remaining goal.
  We then use $\sin(\gamma)^2 = 1 - \cos(\gamma)^2$ to eliminate this term and apply
  the law of cosines to eliminate this term as well.

  The remaining goal is a non-linear equation containing only the length of the sides
  of the triangle. It can be shown by simple algebraic rewriting.
\<close>
lemma angle_sum_triangle:
  assumes "a \<noteq> b \<or> b \<noteq> c \<or> a \<noteq> c"
  shows   "angle c a b + angle a b c + angle b c a = pi"
proof (rule cos_minus1_imp_pi)
  show "cos (angle c a b + angle a b c + angle b c a) = - 1"
  proof (cases "a \<noteq> b")
    case True
    thus "cos (angle c a b + angle a b c + angle b c a) = -1"
      apply (simp add: cos_add sin_add cosine_law_triangle'' field_simps
                       sine_law_triangle''[of a b c] sine_law_triangle''[of b a c]
                       angle_commute dist_commute gather_squares sin_squared_eq)
      apply (simp add: eval_power algebra_simps dist_commute)
      done
  qed (insert assms, auto)

  show "angle c a b + angle a b c + angle b c a < 3 * pi"
  proof (rule ccontr)
    assume "\<not>(angle c a b + angle a b c + angle b c a < 3 * pi)"
    with angle_le_pi[of c a b] angle_le_pi[of a b c] angle_le_pi[of b c a]
      have A: "angle c a b = pi" "angle a b c = pi" by simp_all
    thus False using angle_eq_pi_imp_dist_additive[of c a b]
                     angle_eq_pi_imp_dist_additive[of a b c] by (simp add: dist_commute)
  qed
qed (auto intro!: add_nonneg_nonneg angle_nonneg)

end

subsection \<open>Congruence Theorems\<close>

text \<open>
  If two triangles agree on two angles at a non-degenerate side, the third angle
  must also be equal.
\<close>
lemma similar_triangle_aa:
  assumes "b1 \<noteq> c1" "b2 \<noteq> c2"
  assumes "angle a1 b1 c1 = angle a2 b2 c2"
  assumes "angle b1 c1 a1 = angle b2 c2 a2"
  shows   "angle b1 a1 c1 = angle b2 a2 c2"
proof -
  from assms angle_sum_triangle[of a1 b1 c1] angle_sum_triangle[of a2 b2 c2, symmetric]
    show ?thesis by (auto simp: algebra_simps angle_commute)
qed

text \<open>
  A triangle is defined by its three angles and the lengths of three sides up to congruence.
  Two triangles are congruent if they have their angles are the same and their sides have
  the same length.
\<close>

locale congruent_triangle =
  fixes a1 b1 c1 :: "'a :: real_inner" and a2 b2 c2 :: "'b :: real_inner"
  assumes sides':  "dist a1 b1 = dist a2 b2" "dist a1 c1 = dist a2 c2" "dist b1 c1 = dist b2 c2"
      and angles': "angle b1 a1 c1 = angle b2 a2 c2" "angle a1 b1 c1 = angle a2 b2 c2"
                   "angle a1 c1 b1 = angle a2 c2 b2"
begin

lemma angles:
  "angle b1 a1 c1 = angle b2 a2 c2" "angle a1 b1 c1 = angle a2 b2 c2" "angle a1 c1 b1 = angle a2 c2 b2"
  "angle c1 a1 b1 = angle b2 a2 c2" "angle c1 b1 a1 = angle a2 b2 c2" "angle b1 c1 a1 = angle a2 c2 b2"
  "angle b1 a1 c1 = angle c2 a2 b2" "angle a1 b1 c1 = angle c2 b2 a2" "angle a1 c1 b1 = angle b2 c2 a2"
  "angle c1 a1 b1 = angle c2 a2 b2" "angle c1 b1 a1 = angle c2 b2 a2" "angle b1 c1 a1 = angle b2 c2 a2"
  using angles' by (simp_all add: angle_commute)

end

lemmas congruent_triangleD = congruent_triangle.sides congruent_triangle.angles

text \<open>
  Given two triangles that agree on a subset of its side lengths and angles that are
  sufficient to define a triangle uniquely up to congruence, one can conclude that they
  must also agree on all remaining quantities, i.e. that they are congruent.

  The following four congruence theorems state what constitutes such a uniquely-defining
  subset of quantities. Each theorem states in its name which quantities are required and
  in which order (clockwise or counter-clockwise): an ``s'' stands for a side,
  an ``a'' stands for an angle.

  The lemma ``congruent-triangleI-sas, for example, requires that two adjacent sides and the
  angle inbetween are the same in both triangles.
\<close>

lemma congruent_triangleI_sss:
  fixes a1 b1 c1 :: "'a :: real_inner" and a2 b2 c2 :: "'b :: real_inner"
  assumes "dist a1 b1 = dist a2 b2"
  assumes "dist b1 c1 = dist b2 c2"
  assumes "dist a1 c1 = dist a2 c2"
  shows   "congruent_triangle a1 b1 c1 a2 b2 c2"
proof -
  have A: "angle a1 b1 c1 = angle a2 b2 c2"
    if "dist a1 b1 = dist a2 b2" "dist b1 c1 = dist b2 c2" "dist a1 c1 = dist a2 c2"
    for a1 b1 c1 :: 'a and a2 b2 c2 :: 'b
  proof -
    from that cosine_law_triangle''[of a1 b1 c1] cosine_law_triangle''[of a2 b2 c2]
      show ?thesis by (intro cos_angle_eqD) (simp add: dist_commute)
  qed
  from assms show ?thesis by unfold_locales (auto intro!: A simp: dist_commute)
qed

lemmas congruent_triangle_sss = congruent_triangleD[OF congruent_triangleI_sss]

lemma congruent_triangleI_sas:
  assumes "dist a1 b1 = dist a2 b2"
  assumes "dist b1 c1 = dist b2 c2"
  assumes "angle a1 b1 c1 = angle a2 b2 c2"
  shows   "congruent_triangle a1 b1 c1 a2 b2 c2"
proof (rule congruent_triangleI_sss)
  show "dist a1 c1 = dist a2 c2"
  proof (rule power2_eq_imp_eq)
    from cosine_law_triangle[of a1 c1 b1] cosine_law_triangle[of a2 c2 b2] assms
      show "(dist a1 c1)\<^sup>2 = (dist a2 c2)\<^sup>2" by (simp add: dist_commute)
  qed simp_all
qed fact+

lemmas congruent_triangle_sas = congruent_triangleD[OF congruent_triangleI_sas]

lemma congruent_triangleI_aas:
  assumes "angle a1 b1 c1 = angle a2 b2 c2"
  assumes "angle b1 c1 a1 = angle b2 c2 a2"
  assumes "dist a1 b1 = dist a2 b2"
  assumes "\<not>collinear {a1,b1,c1}"
  shows   "congruent_triangle a1 b1 c1 a2 b2 c2"
proof (rule congruent_triangleI_sas)
  from \<open>\<not>collinear {a1,b1,c1}\<close> have neq: "a1 \<noteq> b1" by auto
  with assms(3) have neq': "a2 \<noteq> b2" by auto
  have A: "angle c1 a1 b1 = angle c2 a2 b2" using neq neq' assms
    using angle_sum_triangle[of a1 b1 c1] angle_sum_triangle[of a2 b2 c2]
    by simp
  from assms have B: "angle b1 a1 c1 \<in> {0<..<pi}"
    by (intro not_collinear_angle) (simp_all add: insert_commute)
  from sine_law_triangle[of c1 a1 b1] sine_law_triangle[of c2 a2 b2] assms A B
    show "dist b1 c1 = dist b2 c2"
    by (auto simp: angle_commute dist_commute sin_angle_zero_iff)
qed fact+

lemmas congruent_triangle_aas = congruent_triangleD[OF congruent_triangleI_aas]

lemma congruent_triangleI_asa:
  assumes "angle a1 b1 c1 = angle a2 b2 c2"
  assumes "dist a1 b1 = dist a2 b2"
  assumes "angle b1 a1 c1 = angle b2 a2 c2"
  assumes "\<not>collinear {a1, b1, c1}"
  shows   "congruent_triangle a1 b1 c1 a2 b2 c2"
proof (rule congruent_triangleI_aas)
  from assms have neq: "a1 \<noteq> b1" "a2 \<noteq> b2" by auto
  show "angle b1 c1 a1 = angle b2 c2 a2"
    by (rule similar_triangle_aa) (insert assms neq, simp_all add: angle_commute)
qed fact+

lemmas congruent_triangle_asa = congruent_triangleD[OF congruent_triangleI_asa]

subsection \<open>Isosceles Triangle Theorem\<close>

text \<open>
  We now prove the Isosceles Triangle Theorem: in a triangle where two sides have
  the same length, the two angles that are adjacent to only one of the two sides
  must be equal.
\<close>
lemma isosceles_triangle:
  assumes "dist a c = dist b c"
  shows   "angle b a c = angle a b c"
  by (rule congruent_triangle_sss) (insert assms, simp_all add: dist_commute)

text \<open>
  For the non-degenerate case (i.e. the three points are not collinear), We also
  prove the converse.
\<close>
lemma isosceles_triangle_converse:
  assumes "angle a b c = angle b a c" "\<not>collinear {a,b,c}"
  shows   "dist a c = dist b c"
  by (rule congruent_triangle_asa[OF assms(1) _ _ assms(2)])
     (simp_all add: dist_commute angle_commute assms)

subsection\<open>Contributions by Lukas Bulwahn\<close>

lemma Pythagoras:
  fixes A B C :: "'a :: real_inner"
  assumes "orthogonal (A - C) (B - C)"
  shows "(dist B C) ^ 2 + (dist C A) ^ 2 = (dist A B) ^ 2"
proof -
  from assms have "cos (angle A C B) = 0"
    by (metis orthogonal_iff_angle cos_pi_half)
  from this show ?thesis
    by (simp add: cosine_law_triangle[of A B C] dist_commute)
qed

lemma isosceles_triangle_orthogonal_on_midpoint:
  fixes A B C :: "'a :: euclidean_space"
  assumes "dist C A = dist C B"
  shows "orthogonal (C - midpoint A B) (A - midpoint A B)"
proof (cases "A = B")
  assume "A \<noteq> B"
  let ?M = "midpoint A B"
  from \<open>A \<noteq> B\<close> have "angle A ?M C = pi - angle B ?M C"
    by (intro angle_inverse between_midpoint)
       (auto simp: between_midpoint eq_commute[of _ "midpoint A B" for A B])
  moreover have "angle A ?M C = angle C ?M B"
  proof -
    have congruence: "congruent_triangle C A ?M C B ?M"
    proof (rule congruent_triangleI_sss)
      show "dist C A = dist C B" using assms .
      show "dist A ?M = dist B ?M" by (simp add: dist_midpoint)
      show "dist C (midpoint A B) = dist C (midpoint A B)" ..
    qed
    from this show ?thesis by (simp add: congruent_triangle.angles(6))
  qed
  ultimately have "angle A ?M C = pi / 2" by (simp add: angle_commute)
  from this show ?thesis
    by (simp add: orthogonal_iff_angle orthogonal_commute)
next
  assume "A = B"
  from this show ?thesis
    by (simp add: orthogonal_clauses(1))
qed

end


section "N-Permutations"

theory n_Permutations
  imports
    "HOL-Combinatorics.Multiset_Permutations"
    Common_Lemmas
    "Falling_Factorial_Sum.Falling_Factorial_Sum_Combinatorics"
begin
subsection"Definition"

definition n_permutations :: "'a set \<Rightarrow> nat \<Rightarrow> 'a list set" where
  "n_permutations A n = {xs. set xs \<subseteq> A \<and> distinct xs \<and> length xs = n}"
text "Permutations with a maximum length. They are different from \<open>HOL-Combinatorics.Multiset_Permutations\<close>
because the entries must all be distinct."
text "Cardinality: \<open>'falling factorial' (card A) n\<close>"
text "Example: \<open>n_permutations {0,1,2} 2 = {[0,1], [0,2], [1,0], [1,2], [2,0], [2,1]}\<close>"

lemma "permutations_of_set A \<subseteq> n_permutations A (card A)"
  by (simp add: length_finite_permutations_of_set n_permutations_def permutations_of_setD subsetI)

subsection"Algorithm"
(*algorithm for permutations with arbitrary length exists in HOL-Combinatorics.Multiset_Permutations*)
fun n_permutation_enum :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list list" where
  "n_permutation_enum xs 0 = [[]]"
| "n_permutation_enum xs (Suc n) = [x#r . x \<leftarrow> xs, r \<leftarrow> n_permutation_enum (remove1 x xs) n]"

subsection"Verification"

subsubsection"Correctness"

lemma n_permutation_enum_subset: "ys \<in> set (n_permutation_enum xs n) \<Longrightarrow> set ys \<subseteq> set xs "
proof(induct n arbitrary: ys xs)
  case 0
  then show ?case by simp
next
  case (Suc n)
  obtain x where o1: "x\<in>set xs" and o2: " ys \<in> (#) x ` set (n_permutation_enum (remove1 x xs) n)"
    using Suc by auto

  have "y \<in> set (n_permutation_enum (remove1 x xs) n) \<Longrightarrow> set y \<subseteq> set xs" for y
    using Suc set_remove1_subset by fast

  then show ?case using o1 o2
    by fastforce
qed

lemma n_permutation_enum_length: "ys \<in> set (n_permutation_enum xs n) \<Longrightarrow> length ys = n"
  by (induct n arbitrary: ys xs) auto

lemma n_permutation_enum_elem_distinct: "distinct xs \<Longrightarrow> ys \<in> set (n_permutation_enum xs n) \<Longrightarrow> distinct ys"
proof (induct n arbitrary: ys xs)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  then obtain z zs where o: "ys = z # zs"
    by auto
  from this Suc have t: "zs \<in> set (n_permutation_enum (remove1 z xs) n)"
    by auto

  then have "distinct zs"
    using Suc distinct_remove1 by fast

  also have "z \<notin> set zs"
    using o t n_permutation_enum_subset Suc by fastforce

  ultimately show ?case
    using o by simp
qed

lemma n_permutation_enum_correct1: "distinct xs \<Longrightarrow> set (n_permutation_enum xs n) \<subseteq> n_permutations (set xs) n"
  unfolding n_permutations_def
  using n_permutation_enum_subset n_permutation_enum_elem_distinct n_permutation_enum_length
  by fast

lemma n_permutation_enum_correct2: "ys \<in> n_permutations (set xs) n \<Longrightarrow> ys \<in> set (n_permutation_enum xs n)"
proof(induct n arbitrary: xs ys)
  case 0
  then show ?case unfolding n_permutations_def by simp
next
  case (Suc n)
  show ?case proof(cases ys)
    case Nil
    then show ?thesis using Suc
      by (simp add: n_permutations_def)
  next
    case (Cons z zs)

    have z_in: "z \<in> set xs"
      using Suc Cons unfolding n_permutations_def by simp

    have 1: "set zs \<subseteq> set xs"
      using Suc Cons unfolding n_permutations_def by simp

    have 2: "length zs = n"
      using Suc Cons unfolding n_permutations_def by simp

    have 3: "distinct zs"
      using Suc Cons unfolding n_permutations_def by simp

    show ?thesis proof(cases "z \<in> set zs")
      case True
      then have "zs \<in> set (n_permutation_enum (remove1 z xs) n)"
        using Suc Cons unfolding n_permutations_def by auto
      then show ?thesis
        using True Cons z_in by auto
    next
      case False
      then have "x \<in> set zs \<Longrightarrow> x \<in> set (remove1 z xs)" for x
        using 1 by(cases "x = z") auto

      then have "zs \<in> n_permutations (set (remove1 z xs)) n"
        unfolding n_permutations_def using 2 3 by auto
      then have "zs \<in> set (n_permutation_enum (remove1 z xs) n)"
        using Suc by simp
      then have "\<exists>x\<in>set xs. z # zs \<in> (#) x ` set (n_permutation_enum (remove1 x xs) n)"
        unfolding image_def using z_in by simp
      then show ?thesis
        using False Cons by simp
    qed
  qed
qed

theorem n_permutation_enum_correct: "distinct xs \<Longrightarrow> set (n_permutation_enum xs n) = n_permutations (set xs) n"
proof standard
  show "distinct xs \<Longrightarrow> set (n_permutation_enum xs n) \<subseteq> n_permutations (set xs) n"
    by (simp add: n_permutation_enum_correct1)
next
  show "distinct xs \<Longrightarrow> n_permutations (set xs) n \<subseteq> set (n_permutation_enum xs n)"
    by (simp add: n_permutation_enum_correct2 subsetI)
qed

subsubsection"Distinctness"

theorem n_permutation_distinct: "distinct xs \<Longrightarrow> distinct (n_permutation_enum xs n)"
proof(induct n arbitrary: xs)
  case 0
  then show ?case by simp
next
  case (Suc n)
  let ?f = "\<lambda>x. (n_permutation_enum (remove1 x xs) n)"
  from Suc have "distinct (?f x)" for x
    by simp

  from this Suc show ?case
    by (auto simp: Cons_distinct_concat_map_function_distinct_on_all [of ?f xs])
qed

subsubsection"Cardinality"
thm card_lists_distinct_length_eq
theorem "finite A \<Longrightarrow> card (n_permutations A n) = ffact n (card A)"
  unfolding n_permutations_def using card_lists_distinct_length_eq
  by (metis (no_types, lifting) Collect_cong)

subsection"\<open>n_multiset\<close> extension (with remdups)"

definition n_multiset_permutations :: "'a multiset \<Rightarrow> nat \<Rightarrow> 'a list set" where
  "n_multiset_permutations A n = {xs. mset xs \<subseteq># A \<and> length xs = n}"

fun n_multiset_permutation_enum :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list list" where
  "n_multiset_permutation_enum xs n = remdups (n_permutation_enum xs n)"

lemma "distinct (n_multiset_permutation_enum xs n)"
  by auto

lemma n_multiset_permutation_enum_correct1:
  "mset ys \<subseteq># mset xs \<Longrightarrow> ys \<in> set (n_permutation_enum xs (length ys))"
proof(induct "ys" arbitrary: xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons y ys)
  then have "y \<in> set xs"
    by (simp add: insert_subset_eq_iff)
  moreover have "ys \<in> set (n_permutation_enum (remove1 y xs) (length ys))"
    using Cons by (simp add: insert_subset_eq_iff)
  ultimately show ?case
    using Cons by auto
qed

lemma n_multiset_permutation_enum_correct2:
  "ys \<in> set (n_permutation_enum xs n) \<Longrightarrow> mset ys \<subseteq># mset xs"
proof(induct "n" arbitrary: xs ys)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  then show ?case
    using insert_subset_eq_iff mset_remove1 by fastforce
qed

lemma n_multiset_permutation_enum_correct:
  "set (n_multiset_permutation_enum xs n) = n_multiset_permutations (mset xs) n"
  unfolding n_multiset_permutations_def
proof(standard)
  show "set (n_multiset_permutation_enum xs n) \<subseteq> {xsa. mset xsa \<subseteq># mset xs \<and> length xsa = n}"
    by (simp add: n_multiset_permutation_enum_correct2 n_permutation_enum_length subsetI)
next
  show "{xsa. mset xsa \<subseteq># mset xs \<and> length xsa = n} \<subseteq> set (n_multiset_permutation_enum xs n)"
    using n_multiset_permutation_enum_correct1 by auto
qed

end