(*  Title:      HOL/ex/Sudoku.thy
    Author:     Tjark Weber
    Copyright   2005-2014
*)

section {* A SAT-based Sudoku Solver *}

theory Sudoku
imports Main
begin

text {*
  See the paper ``A SAT-based Sudoku Solver'' (Tjark Weber, published at
  LPAR'05) for further explanations.  (The paper describes an older version of
  this theory that used the model finder @{text refute} to find Sudoku
  solutions.  The @{text refute} tool has since been superseded by
  @{text nitpick}, which is used below.)
*}

no_notation Groups.one_class.one ("1")

datatype digit = A ("1") | B ("2") | C ("3") | D ("4") | E ("5") | F ("6") | G ("7") | H ("8") | I ("9")

definition valid :: "digit => digit => digit => digit => digit => digit => digit => digit => digit => bool" where

  "valid x1 x2 x3 x4 x5 x6 x7 x8 x9 ==
    (x1 \<noteq> x2) \<and> (x1 \<noteq> x3) \<and> (x1 \<noteq> x4) \<and> (x1 \<noteq> x5) \<and> (x1 \<noteq> x6) \<and> (x1 \<noteq> x7) \<and> (x1 \<noteq> x8) \<and> (x1 \<noteq> x9)
    \<and> (x2 \<noteq> x3) \<and> (x2 \<noteq> x4) \<and> (x2 \<noteq> x5) \<and> (x2 \<noteq> x6) \<and> (x2 \<noteq> x7) \<and> (x2 \<noteq> x8) \<and> (x2 \<noteq> x9)
    \<and> (x3 \<noteq> x4) \<and> (x3 \<noteq> x5) \<and> (x3 \<noteq> x6) \<and> (x3 \<noteq> x7) \<and> (x3 \<noteq> x8) \<and> (x3 \<noteq> x9)
    \<and> (x4 \<noteq> x5) \<and> (x4 \<noteq> x6) \<and> (x4 \<noteq> x7) \<and> (x4 \<noteq> x8) \<and> (x4 \<noteq> x9)
    \<and> (x5 \<noteq> x6) \<and> (x5 \<noteq> x7) \<and> (x5 \<noteq> x8) \<and> (x5 \<noteq> x9)
    \<and> (x6 \<noteq> x7) \<and> (x6 \<noteq> x8) \<and> (x6 \<noteq> x9)
    \<and> (x7 \<noteq> x8) \<and> (x7 \<noteq> x9)
    \<and> (x8 \<noteq> x9)"

definition sudoku :: "digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit =>
    digit => digit => digit => digit => digit => digit => digit => digit => digit => bool" where

  "sudoku x11 x12 x13 x14 x15 x16 x17 x18 x19
          x21 x22 x23 x24 x25 x26 x27 x28 x29
          x31 x32 x33 x34 x35 x36 x37 x38 x39
          x41 x42 x43 x44 x45 x46 x47 x48 x49
          x51 x52 x53 x54 x55 x56 x57 x58 x59
          x61 x62 x63 x64 x65 x66 x67 x68 x69
          x71 x72 x73 x74 x75 x76 x77 x78 x79
          x81 x82 x83 x84 x85 x86 x87 x88 x89
          x91 x92 x93 x94 x95 x96 x97 x98 x99 ==

       valid x11 x12 x13 x14 x15 x16 x17 x18 x19
     \<and> valid x21 x22 x23 x24 x25 x26 x27 x28 x29
     \<and> valid x31 x32 x33 x34 x35 x36 x37 x38 x39
     \<and> valid x41 x42 x43 x44 x45 x46 x47 x48 x49
     \<and> valid x51 x52 x53 x54 x55 x56 x57 x58 x59
     \<and> valid x61 x62 x63 x64 x65 x66 x67 x68 x69
     \<and> valid x71 x72 x73 x74 x75 x76 x77 x78 x79
     \<and> valid x81 x82 x83 x84 x85 x86 x87 x88 x89
     \<and> valid x91 x92 x93 x94 x95 x96 x97 x98 x99

     \<and> valid x11 x21 x31 x41 x51 x61 x71 x81 x91
     \<and> valid x12 x22 x32 x42 x52 x62 x72 x82 x92
     \<and> valid x13 x23 x33 x43 x53 x63 x73 x83 x93
     \<and> valid x14 x24 x34 x44 x54 x64 x74 x84 x94
     \<and> valid x15 x25 x35 x45 x55 x65 x75 x85 x95
     \<and> valid x16 x26 x36 x46 x56 x66 x76 x86 x96
     \<and> valid x17 x27 x37 x47 x57 x67 x77 x87 x97
     \<and> valid x18 x28 x38 x48 x58 x68 x78 x88 x98
     \<and> valid x19 x29 x39 x49 x59 x69 x79 x89 x99

     \<and> valid x11 x12 x13 x21 x22 x23 x31 x32 x33
     \<and> valid x14 x15 x16 x24 x25 x26 x34 x35 x36
     \<and> valid x17 x18 x19 x27 x28 x29 x37 x38 x39
     \<and> valid x41 x42 x43 x51 x52 x53 x61 x62 x63
     \<and> valid x44 x45 x46 x54 x55 x56 x64 x65 x66
     \<and> valid x47 x48 x49 x57 x58 x59 x67 x68 x69
     \<and> valid x71 x72 x73 x81 x82 x83 x91 x92 x93
     \<and> valid x74 x75 x76 x84 x85 x86 x94 x95 x96
     \<and> valid x77 x78 x79 x87 x88 x89 x97 x98 x99"

text {*
  Just an arbitrary Sudoku grid:
*}

theorem "\<not> sudoku
    x11 x12 x13 x14 x15 x16 x17 x18 x19
    x21 x22 x23 x24 x25 x26 x27 x28 x29
    x31 x32 x33 x34 x35 x36 x37 x38 x39
    x41 x42 x43 x44 x45 x46 x47 x48 x49
    x51 x52 x53 x54 x55 x56 x57 x58 x59
    x61 x62 x63 x64 x65 x66 x67 x68 x69
    x71 x72 x73 x74 x75 x76 x77 x78 x79
    x81 x82 x83 x84 x85 x86 x87 x88 x89
    x91 x92 x93 x94 x95 x96 x97 x98 x99"
  nitpick [expect=genuine]
oops

text {*
  An ``easy'' Sudoku:
*}

theorem "\<not> sudoku
     5   3  x13 x14  7  x16 x17 x18 x19
     6  x22 x23  1   9   5  x27 x28 x29
    x31  9   8  x34 x35 x36 x37  6  x39
     8  x42 x43 x44  6  x46 x47 x48  3
     4  x52 x53  8  x55  3  x57 x58  1
     7  x62 x63 x64  2  x66 x67 x68  6
    x71  6  x73 x74 x75 x76  2   8  x79
    x81 x82 x83  4   1   9  x87 x88  5
    x91 x92 x93 x94  8  x96 x97  7   9 "
  nitpick [expect=genuine]
oops

text {*
  A ``hard'' Sudoku:
*}

theorem "\<not> sudoku
    x11  2  x13 x14 x15 x16 x17 x18 x19
    x21 x22 x23  6  x25 x26 x27 x28  3
    x31  7   4  x34  8  x36 x37 x38 x39
    x41 x42 x43 x44 x45  3  x47 x48  2
    x51  8  x53 x54  4  x56 x57  1  x59
     6  x62 x63  5  x65 x66 x67 x68 x69
    x71 x72 x73 x74  1  x76  7   8  x79
     5  x82 x83 x84 x85  9  x87 x88 x89
    x91 x92 x93 x94 x95 x96 x97  4  x99"
  nitpick [expect=genuine]
oops

text {*
  Some ``exceptionally difficult'' Sudokus, taken from
  @{url "http://en.wikipedia.org/w/index.php?title=Algorithmics_of_sudoku&oldid=254685903"}
  (accessed December~2, 2008).
*}

text {*
\begin{verbatim}
Rating Program: gsf's sudoku q1 (rating)
Rating: 99408
Poster: JPF
Label: Easter Monster
1.......2.9.4...5...6...7...5.9.3.......7.......85..4.7.....6...3...9.8...2.....1
1 . . | . . . | . . 2
. 9 . | 4 . . | . 5 .
. . 6 | . . . | 7 . .
------+-------+------
. 5 . | 9 . 3 | . . .
. . . | . 7 . | . . .
. . . | 8 5 . | . 4 .
------+-------+------
7 . . | . . . | 6 . .
. 3 . | . . 9 | . 8 .
. . 2 | . . . | . . 1
\end{verbatim}
*}

theorem "\<not> sudoku
     1  x12 x13 x14 x15 x16 x17 x18  2
    x21  9  x23  4  x25 x26 x27  5  x29
    x31 x32  6  x34 x35 x36  7  x38 x39
    x41  5  x43  9  x45  3  x47 x48 x49
    x51 x52 x53 x54  7  x56 x57 x58 x59
    x61 x62 x63  8   5  x66 x67  4  x69
     7  x72 x73 x74 x75 x76  6  x78 x79
    x81  3  x83 x84 x85  9  x87  8  x89
    x91 x92  2  x94 x95 x96 x97 x98  1 "
  nitpick [expect=genuine]
oops

text {*
\begin{verbatim}
Rating Program: gsf's sudoku q1 (Processing time)
Rating: 4m19s@2 GHz
Poster: tarek
Label: tarek071223170000-052
..1..4.......6.3.5...9.....8.....7.3.......285...7.6..3...8...6..92......4...1...
. . 1 | . . 4 | . . .
. . . | . 6 . | 3 . 5
. . . | 9 . . | . . .
------+-------+------
8 . . | . . . | 7 . 3
. . . | . . . | . 2 8
5 . . | . 7 . | 6 . .
------+-------+------
3 . . | . 8 . | . . 6
. . 9 | 2 . . | . . .
. 4 . | . . 1 | . . .
\end{verbatim}
*}

theorem "\<not> sudoku
    x11 x12  1  x14 x15  4  x17 x18 x19
    x21 x22 x23 x24  6  x26  3  x28  5
    x31 x32 x33  9  x35 x36 x37 x38 x39
     8  x42 x43 x44 x45 x46  7  x48  3
    x51 x52 x53 x54 x55 x56 x57  2   8
     5  x62 x63 x64  7  x66  6  x68 x69
     3  x72 x73 x74  8  x76 x77 x78  6
    x81 x82  9   2  x85 x86 x87 x88 x89
    x91  4  x93 x94 x95  1  x97 x98 x99"
  nitpick [expect=genuine]
oops

text {*
\begin{verbatim}
Rating Program: Nicolas Juillerat's Sudoku explainer 1.2.1
Rating: 11.9
Poster: tarek
Label: golden nugget
.......39.....1..5..3.5.8....8.9...6.7...2...1..4.......9.8..5..2....6..4..7.....
. . . | . . . | . 3 9
. . . | . . 1 | . . 5
. . 3 | . 5 . | 8 . .
------+-------+------
. . 8 | . 9 . | . . 6
. 7 . | . . 2 | . . .
1 . . | 4 . . | . . .
------+-------+------
. . 9 | . 8 . | . 5 .
. 2 . | . . . | 6 . .
4 . . | 7 . . | . . .
\end{verbatim}
*}

theorem "\<not> sudoku
    x11 x12 x13 x14 x15 x16 x17  3   9
    x21 x22 x23 x24 x25  1  x27 x28  5
    x31 x32  3  x34  5  x36  8  x38 x39
    x41 x42  8  x44  9  x46 x47 x48  6
    x51  7  x53 x54 x55  2  x57 x58 x59
     1  x62 x63  4  x65 x66 x67 x68 x69
    x71 x72  9  x74  8  x76 x77  5  x79
    x81  2  x83 x84 x85 x86  6  x88 x89
     4  x92 x93  7  x95 x96 x97 x98 x99"
  nitpick [expect=genuine]
oops

text {*
\begin{verbatim}
Rating Program: dukuso's suexrat9
Rating: 4483
Poster: coloin
Label: col-02-08-071
.2.4.37.........32........4.4.2...7.8...5.........1...5.....9...3.9....7..1..86..
. 2 . | 4 . 3 | 7 . .
. . . | . . . | . 3 2
. . . | . . . | . . 4
------+-------+------
. 4 . | 2 . . | . 7 .
8 . . | . 5 . | . . .
. . . | . . 1 | . . .
------+-------+------
5 . . | . . . | 9 . .
. 3 . | 9 . . | . . 7
. . 1 | . . 8 | 6 . .
\end{verbatim}
*}

theorem "\<not> sudoku
    x11  2  x13  4  x15  3   7  x18 x19
    x21 x22 x23 x24 x25 x26 x27  3   2
    x31 x32 x33 x34 x35 x36 x37 x38  4
    x41  4  x43  2  x45 x46 x47  7  x49
     8  x52 x53 x54  5  x56 x57 x58 x59
    x61 x62 x63 x64 x65  1  x67 x68 x69
     5  x72 x73 x74 x75 x76  9  x78 x79
    x81  3  x83  9  x85 x86 x87 x88  7
    x91 x92  1  x94 x95  8   6  x98 x99"
  nitpick [expect=genuine]
oops

text {*
\begin{verbatim}
Rating Program: dukuso's suexratt (10000 2 option)
Rating: 2141
Poster: tarek
Label: golden nugget
.......39.....1..5..3.5.8....8.9...6.7...2...1..4.......9.8..5..2....6..4..7.....
. . . | . . . | . 3 9
. . . | . . 1 | . . 5
. . 3 | . 5 . | 8 . .
------+-------+------
. . 8 | . 9 . | . . 6
. 7 . | . . 2 | . . .
1 . . | 4 . . | . . .
------+-------+------
. . 9 | . 8 . | . 5 .
. 2 . | . . . | 6 . .
4 . . | 7 . . | . . .
\end{verbatim}
*}

theorem "\<not> sudoku
    x11 x12 x13 x14 x15 x16 x17  3   9
    x21 x22 x23 x24 x25  1  x27 x28  5
    x31 x32  3  x34  5  x36  8  x38 x39
    x41 x42  8  x44  9  x46 x47 x48  6
    x51  7  x53 x54 x55  2  x57 x58 x59
     1  x62 x63  4  x65 x66 x67 x68 x69
    x71 x72  9  x74  8  x76 x77  5  x79
    x81  2  x83 x84 x85 x86  6  x88 x89
     4  x92 x93  7  x95 x96 x97 x98 x99"
  nitpick [expect=genuine]
oops

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Chinese Remainder Theorem for Polynomials\<close>

text \<open>We prove the Chinese Remainder Theorem, and strengthen it by showing uniqueness\<close>

theory Chinese_Remainder_Poly
imports
  "HOL-Number_Theory.Residues"
  Polynomial_Factorization.Polynomial_Divisibility
  Polynomial_Interpolation.Missing_Polynomial
begin

lemma cong_add_poly:
  "[(a::'b::{field_gcd} poly) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a + c = b + d] (mod m)"
  by (fact cong_add)

lemma cong_mult_poly:
  "[(a::'b::{field_gcd} poly) = b] (mod m) \<Longrightarrow> [c = d] (mod m) \<Longrightarrow> [a * c = b * d] (mod m)"
  by (fact cong_mult)

lemma cong_mult_self_poly: "[(a::'b::{field_gcd} poly) * m = 0] (mod m)"
  by (fact cong_mult_self_right)

lemma cong_scalar2_poly: "[(a::'b::{field_gcd} poly)= b] (mod m) \<Longrightarrow> [k * a = k * b] (mod m)"
  by (fact cong_scalar_left)

lemma cong_sum_poly:
    "(\<And>x. x \<in> A \<Longrightarrow> [((f x)::'b::{field_gcd} poly) = g x] (mod m)) \<Longrightarrow>
      [(\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. g x)] (mod m)"
  by (rule cong_sum)

lemma cong_iff_lin_poly: "([(a::'b::{field_gcd} poly) = b] (mod m)) = (\<exists>k. b = a + m * k)"
  using cong_diff_iff_cong_0 [of b a m] by (auto simp add: cong_0_iff dvd_def algebra_simps dest: cong_sym)

lemma cong_solve_poly: "(a::'b::{field_gcd} poly) \<noteq> 0 \<Longrightarrow> \<exists>x. [a * x = gcd a n] (mod n)"
proof (cases "n = 0")
  case True
  note n0=True
  show ?thesis
  proof (cases "monic a")
    case True
    have n: "normalize a = a" by (rule normalize_monic[OF True])
    show ?thesis
    by (rule exI[of _ 1], auto simp add: n0 n cong_def)
  next
    case False
    show ?thesis
      by (auto simp add: True cong_def normalize_poly_old_def map_div_is_smult_inverse)
         (metis mult.right_neutral mult_smult_right)
  qed
next
 case False
 note n_not_0 = False
 show ?thesis
   using bezout_coefficients_fst_snd [of a n, symmetric]
   by (auto simp add: cong_iff_lin_poly mult.commute [of a] mult.commute [of n])
qed

lemma cong_solve_coprime_poly:
assumes coprime_an:"coprime (a::'b::{field_gcd} poly) n"
shows "\<exists>x. [a * x = 1] (mod n)"
proof (cases "a = 0")
  case True
  show ?thesis unfolding cong_def
    using True coprime_an by auto
next
  case False
  show ?thesis
    using coprime_an cong_solve_poly[OF False, of n]
    unfolding cong_def
    by presburger
qed

lemma cong_dvd_modulus_poly:
  "[x = y] (mod m) \<Longrightarrow> n dvd m \<Longrightarrow> [x = y] (mod n)" for x y :: "'b::{field_gcd} poly"
  by (auto simp add: cong_iff_lin_poly elim!: dvdE)

lemma chinese_remainder_aux_poly:
  fixes A :: "'a set"
    and m :: "'a \<Rightarrow> 'b::{field_gcd} poly"
  assumes fin: "finite A"
    and cop: "\<forall>i \<in> A. (\<forall>j \<in> A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
  shows "\<exists>b. (\<forall>i \<in> A. [b i = 1] (mod m i) \<and> [b i = 0] (mod (\<Prod>j \<in> A - {i}. m j)))"
proof (rule finite_set_choice, rule fin, rule ballI)
  fix i
  assume "i : A"
  with cop have "coprime (\<Prod>j \<in> A - {i}. m j) (m i)"
    by (auto intro: prod_coprime_left)
  then have "\<exists>x. [(\<Prod>j \<in> A - {i}. m j) * x = 1] (mod m i)"
    by (elim cong_solve_coprime_poly)
  then obtain x where "[(\<Prod>j \<in> A - {i}. m j) * x = 1] (mod m i)"
    by auto
  moreover have "[(\<Prod>j \<in> A - {i}. m j) * x = 0]
    (mod (\<Prod>j \<in> A - {i}. m j))"
    by (subst mult.commute, rule cong_mult_self_poly)
  ultimately show "\<exists>a. [a = 1] (mod m i) \<and> [a = 0]
      (mod prod m (A - {i}))"
    by blast
qed

(*The Chinese Remainder Theorem for polynomials: *)
lemma chinese_remainder_poly:
  fixes A :: "'a set"
    and m :: "'a \<Rightarrow> 'b::{field_gcd} poly"
    and u :: "'a \<Rightarrow> 'b poly"
  assumes fin: "finite A"
    and cop: "\<forall>i\<in>A. (\<forall>j\<in>A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
  shows "\<exists>x. (\<forall>i\<in>A. [x = u i] (mod m i))"
proof -
  from chinese_remainder_aux_poly [OF fin cop] obtain b where
    bprop: "\<forall>i\<in>A. [b i = 1] (mod m i) \<and>
      [b i = 0] (mod (\<Prod>j \<in> A - {i}. m j))"
    by blast
  let ?x = "\<Sum>i\<in>A. (u i) * (b i)"
  show "?thesis"
  proof (rule exI, clarify)
    fix i
    assume a: "i : A"
    show "[?x = u i] (mod m i)"
    proof -
      from fin a have "?x = (\<Sum>j \<in> {i}. u j * b j) +
          (\<Sum>j \<in> A - {i}. u j * b j)"
        by (subst sum.union_disjoint [symmetric], auto intro: sum.cong)
      then have "[?x = u i * b i + (\<Sum>j \<in> A - {i}. u j * b j)] (mod m i)"
        unfolding cong_def
        by auto
      also have "[u i * b i + (\<Sum>j \<in> A - {i}. u j * b j) =
                  u i * 1 + (\<Sum>j \<in> A - {i}. u j * 0)] (mod m i)"
        apply (rule cong_add_poly)
        apply (rule cong_scalar2_poly)
        using bprop a apply blast
        apply (rule cong_sum)
        apply (rule cong_scalar2_poly)
        using bprop apply auto
        apply (rule cong_dvd_modulus_poly)
        apply (drule (1) bspec)
        apply (erule conjE)
        apply assumption
        apply rule
        using fin a apply auto
        done
       thus ?thesis
       by (metis (no_types, lifting) a add.right_neutral fin mult_cancel_left1 mult_cancel_right1
         sum.not_neutral_contains_not_neutral sum.remove)
    qed
  qed
qed

(*********************** Now we try to prove the uniqueness **********************)

lemma cong_trans_poly:
    "[(a::'b::{field_gcd} poly) = b] (mod m) \<Longrightarrow> [b = c] (mod m) \<Longrightarrow> [a = c] (mod m)"
  by (fact cong_trans)

lemma cong_mod_poly: "(n::'b::{field_gcd} poly) ~= 0 \<Longrightarrow> [a mod n = a] (mod n)"
  by auto

lemma cong_sym_poly: "[(a::'b::{field_gcd} poly) = b] (mod m) \<Longrightarrow> [b = a] (mod m)"
  by (fact cong_sym)

lemma cong_1_poly: "[(a::'b::{field_gcd} poly) = b] (mod 1)"
  by (fact cong_1)

lemma coprime_cong_mult_poly:
  assumes "[(a::'b::{field_gcd} poly) = b] (mod m)" and "[a = b] (mod n)" and "coprime m n"
  shows "[a = b] (mod m * n)"
  using divides_mult assms
  by (metis (no_types, hide_lams) cong_dvd_modulus_poly cong_iff_lin_poly dvd_mult2 dvd_refl minus_add_cancel mult.right_neutral)

lemma coprime_cong_prod_poly:
    "(\<forall>i\<in>A. (\<forall>j\<in>A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))) \<Longrightarrow>
      (\<forall>i\<in>A. [(x::'b::{field_gcd} poly) = y] (mod m i)) \<Longrightarrow>
         [x = y] (mod (\<Prod>i\<in>A. m i))"
  apply (induct A rule: infinite_finite_induct)
    apply auto
  apply (metis coprime_cong_mult_poly prod_coprime_right)
  done

lemma cong_less_modulus_unique_poly:
    "[(x::'b::{field_gcd} poly) = y] (mod m) \<Longrightarrow> degree x < degree m \<Longrightarrow> degree y < degree m \<Longrightarrow> x = y"
    by (simp add: cong_def mod_poly_less)

lemma chinese_remainder_unique_poly:
  fixes A :: "'a set"
    and m :: "'a \<Rightarrow> 'b::{field_gcd} poly"
    and u :: "'a \<Rightarrow> 'b poly"
  assumes nz: "\<forall>i\<in>A. (m i) \<noteq> 0"
    and cop: "\<forall>i\<in>A. (\<forall>j\<in>A. i \<noteq> j \<longrightarrow> coprime (m i) (m j))"
    (*The following assumption should not be necessary, but I need it since in Isabelle
      degree 0 is 0 instead of -\<infinity>*)
    and not_constant: "0 < degree (prod m A)"
  shows "\<exists>!x. degree x < (\<Sum>i\<in>A. degree (m i)) \<and> (\<forall>i\<in>A. [x = u i] (mod m i))"
proof -
  from not_constant have fin: "finite A"
    by (metis degree_1 gr_implies_not0 prod.infinite)
  from chinese_remainder_poly [OF fin cop]
  obtain y where one: "(\<forall>i\<in>A. [y = u i] (mod m i))"
    by blast
  let ?x = "y mod (\<Prod>i\<in>A. m i)"
  have degree_prod_sum: "degree (prod m A) = (\<Sum>i\<in>A. degree (m i))"
    by (rule degree_prod_eq_sum_degree[OF nz])
  from fin nz have prodnz: "(\<Prod>i\<in>A. (m i)) \<noteq> 0"
     by auto
  (*This would hold without the premise not_constant if degree 0 = -\<infinity>*)
  have less: "degree ?x < (\<Sum>i\<in>A. degree (m i))"
    unfolding degree_prod_sum[symmetric]
    using degree_mod_less[OF prodnz, of y]
    using not_constant
    by auto
  have cong: "\<forall>i\<in>A. [?x = u i] (mod m i)"
    apply auto
    apply (rule cong_trans_poly)
    prefer 2
    using one apply auto
    apply (rule cong_dvd_modulus_poly)
    apply (rule cong_mod_poly)
    using prodnz apply auto
    apply rule
    apply (rule fin)
    apply assumption
    done
  have unique: "\<forall>z. degree z < (\<Sum>i\<in>A. degree (m i)) \<and>
      (\<forall>i\<in>A. [z = u i] (mod m i)) \<longrightarrow> z = ?x"
  proof (clarify)
    fix z::"'b poly"
    assume zless: "degree z < (\<Sum>i\<in>A. degree (m i))"
    assume zcong: "(\<forall>i\<in>A. [z = u i] (mod m i))"
    have deg1: "degree z < degree (prod m A)"
      using degree_prod_sum zless by simp
    have deg2: "degree ?x < degree (prod m A)"
      by (metis deg1 degree_0 degree_mod_less gr0I gr_implies_not0)
    have "\<forall>i\<in>A. [?x = z] (mod m i)"
      apply clarify
      apply (rule cong_trans_poly)
      using cong apply (erule bspec)
      apply (rule cong_sym_poly)
      using zcong by auto
    with fin cop have "[?x = z] (mod (\<Prod>i\<in>A. m i))"
      by (intro coprime_cong_prod_poly) auto
    with zless  show "z = ?x"
      apply (intro cong_less_modulus_unique_poly)
      apply (erule cong_sym_poly)
      apply (auto simp add:  deg1 deg2)
      done
  qed
  from less cong unique show ?thesis by blast
qed

end


section\<open>Combinatorics problems\<close>

subsection \<open>IMO 2017 SL - C1\<close>

theory IMO_2017_SL_C1
  imports Complex_Main
begin

type_synonym square = "nat \<times> nat"

(*
fun green :: "square \<Rightarrow> bool" where
  "green (x, y) \<longleftrightarrow> (x + y) mod 2 = 0"

fun yellow :: "square \<Rightarrow> bool" where
  "yellow (x, y) \<longleftrightarrow> (x + y) mod 2 \<noteq> 0"
*)

text \<open>A rectangle with vertices [x1, x2) and [y1, y2) is given by a quadruple (x1, x2, y1, y2).\<close>
type_synonym rect = "nat \<times> nat \<times> nat \<times> nat"

fun valid_rect :: "rect \<Rightarrow> bool" where
  "valid_rect (x1, x2, y1, y2) \<longleftrightarrow> x1 < x2 \<and> y1 < y2"

text \<open>All squares in a rectangle\<close>
fun squares :: "rect \<Rightarrow> square set" where
  "squares (x1, x2, y1, y2) = {x1..<x2} \<times> {y1..<y2}"

(*
text \<open>One rectangle is inside another one\<close>
definition inside :: "rect \<Rightarrow> rect \<Rightarrow> bool" where
  "inside ri ro \<longleftrightarrow> squares ri \<subseteq> squares ro"
*)

text \<open>Two rectangles overlap inside another one\<close>
definition overlap :: "rect \<Rightarrow> rect \<Rightarrow> bool" where
  "overlap r1 r2 \<longleftrightarrow> squares r1 \<inter> squares r2 \<noteq> {}"

text \<open>There are no two overlapping rectangles in a set\<close>
definition non_overlapping :: "rect set \<Rightarrow> bool" where
  "non_overlapping rs \<longleftrightarrow> (\<forall> r1 \<in> rs. \<forall> r2 \<in> rs. r1 \<noteq> r2 \<longrightarrow> \<not> overlap r1 r2)"

text \<open>A set of rectangles covers a given rectangle\<close>
definition cover :: "rect set \<Rightarrow> rect \<Rightarrow> bool" where
  "cover rs r \<longleftrightarrow> (\<Union> (squares ` rs)) = squares r"

text \<open>A rectangle is tiled by a set of non-overlapping, smaller rectangles\<close>
definition tiles :: "rect set \<Rightarrow> rect \<Rightarrow> bool" where
  "tiles rs r \<longleftrightarrow> cover rs r \<and> non_overlapping rs"

(*
text \<open>All green squares in a rectangle\<close>
definition green_squares where
  "green_squares r = {(x, y) \<in> squares r. green (x, y)}"

text \<open>All yellow squares in a rectangle\<close>
definition yellow_squares where
  "yellow_squares r = {(x, y) \<in> squares r. yellow (x, y)}"

text \<open>Corner squares of a rectangle\<close>
fun corners :: "rect \<Rightarrow> (nat \<times> nat) set" where
  "corners (x1, x2, y1, y2) = {(x1, y1), (x1, y2-1), (x2-1, y1), (x2-1, y2-1)}"

definition green_rect :: "rect \<Rightarrow> bool" where
  "green_rect r \<longleftrightarrow> (\<forall> c \<in> corners r. green c)"

definition yellow_rect :: "rect \<Rightarrow> bool" where
  "yellow_rect r \<longleftrightarrow> (\<forall> c \<in> corners r. yellow c)"

definition mixed_rect ::  "rect \<Rightarrow> bool" where
  "mixed_rect r \<longleftrightarrow> \<not> green_rect r \<and> \<not> yellow_rect r"

lemma finite_squares [simp]:
  shows "finite (squares r)"
  sorry

lemma finite_green_squares [simp]:
  shows "finite (green_squares r)"
  using finite_subset[of "green_squares r" "squares r"]
  sorry

lemma finite_yellow_squares [simp]:
  shows "finite (yellow_squares r)"
  using finite_subset[of "yellow_squares r" "squares r"]
  sorry

lemma card_green_squares_row:
  assumes "x1 < x2"
  shows "card {(x, y). x1 \<le> x \<and> x < x2 \<and> y = y0 \<and> green (x, y)} =
         (if yellow (x1, y0) then (x2 - x1) div 2 else (x2 - x1 + 1) div 2)"
  sorry

lemma card_squares:
  shows "card (squares (x1, x2, y1, y2)) = (x2 - x1) * (y2 - y1)"
  sorry

lemma card_green_squares_start_yellow:
  assumes "yellow (x1, y1)" "valid_rect (x1, x2, y1, y2)"
  shows "card (green_squares (x1, x2, y1, y2)) = (x2 - x1) * (y2 - y1) div 2"
  sorry

lemma card_yellow_squares_start_yellow:
  assumes "yellow (x1, y1)" "valid_rect (x1, x2, y1, y2)"
  shows "card (yellow_squares (x1, x2, y1, y2)) = ((x2 - x1) * (y2 - y1) + 1) div 2"
  sorry

lemma card_yellow_squares_start_green:
  assumes "green (x1, y1)" "valid_rect (x1, x2, y1, y2)"
  shows "card (yellow_squares (x1, x2, y1, y2)) = (x2 - x1) * (y2 - y1) div 2"
  sorry

lemma card_green_squares_start_green:
  assumes "green (x1, y1)" "valid_rect (x1, x2, y1, y2)"
  shows "card (green_squares (x1, x2, y1, y2)) = ((x2 - x1) * (y2 - y1) + 1) div 2"
  sorry

lemma mixed_rect:
  assumes "valid_rect (x1, x2, y1, y2)" "mixed_rect (x1, x2, y1, y2)"
        shows "card (green_squares (x1, x2, y1, y2)) = card (yellow_squares (x1, x2, y1, y2))"
  sorry

lemma green_rect:
  assumes "valid_rect (x1, x2, y1, y2)"  "green_rect (x1, x2, y1, y2)"
  shows "card (green_squares (x1, x2, y1, y2)) = card (yellow_squares (x1, x2, y1, y2)) + 1"
  sorry

lemma yellow_rect:
  assumes "valid_rect (x1, x2, y1, y2)" "yellow_rect (x1, x2, y1, y2)"
  shows "card (green_squares (x1, x2, y1, y2)) + 1 = card (yellow_squares (x1, x2, y1, y2))"
  sorry

lemma tiles_inside:
  assumes "tiles rs (x1, x2, y1, y2)" "r \<in> rs"
  shows "inside r (x1, x2, y1, y2)"
  sorry

lemma finite_tiles:
  assumes "tiles rs (x1, x2, y1, y2)" "\<forall> r \<in> rs. valid_rect r"
  shows "finite rs"
  sorry

lemma green_tile:
  assumes "green_rect (0, a, 0, b)" "a > 0" "b > 0"
          "tiles rs (0, a, 0, b)" "\<forall> r \<in> rs. valid_rect r"
  shows "\<exists> r \<in> rs. green_rect r"
  sorry
*)

theorem IMO_2017_SL_C1:
  fixes a b :: nat
  assumes "odd a" "odd b" "tiles rs (0, a, 0, b)" "\<forall> r \<in> rs. valid_rect r"
        shows "\<exists> (x1, x2, y1, y2) \<in> rs.
                  let ds = {x1 - 0, a - x2, y1 - 0, b - y2}
                   in (\<forall> d \<in> ds. even d) \<or> (\<forall> d \<in> ds. odd d)"
  sorry

end


theory fol_example
  imports Main
begin

lemma ex1:
shows "(\<exists> x::int. \<forall> y::int. x \<le> y) \<longrightarrow>(\<forall> x::int. \<exists> y::int. y \<le> x)"
  apply (rule impI)
  apply (rule allI)
  apply (rule exE)
  apply assumption
  thm exI
  apply (rule_tac x = "xa" in exI)
  apply (rule_tac x = "x" in allE)
   apply assumption
  apply assumption
  done

lemma ex2:
  shows "(\<forall> x::int. \<exists> y::int. y \<le> x) \<longrightarrow> (\<exists> x::int. \<forall> y::int. x \<le> y)"
  apply (rule impI)
  apply (rule exI)
  apply (rule allI)
  apply (rule_tac x = "y" in allE)
  apply assumption
  apply (rule exE)
   apply assumption
  apply assumption
  oops

end


theory T144
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


(* Author: Tobias Nipkow *)

section \<open>2-3 Tree Implementation of Sets\<close>

theory Tree23_Set
imports
  Tree23
  Cmp
  Set_by_Ordered
begin

fun isin :: "'a::linorder tree23 \<Rightarrow> 'a \<Rightarrow> bool" where
"isin Leaf x = False" |
"isin (Node2 l a r) x =
  (case cmp x a of
     LT \<Rightarrow> isin l x |
     EQ \<Rightarrow> True |
     GT \<Rightarrow> isin r x)" |
"isin (Node3 l a m b r) x =
  (case cmp x a of
     LT \<Rightarrow> isin l x |
     EQ \<Rightarrow> True |
     GT \<Rightarrow>
       (case cmp x b of
          LT \<Rightarrow> isin m x |
          EQ \<Rightarrow> True |
          GT \<Rightarrow> isin r x))"

datatype 'a up\<^sub>i = T\<^sub>i "'a tree23" | Up\<^sub>i "'a tree23" 'a "'a tree23"

fun tree\<^sub>i :: "'a up\<^sub>i \<Rightarrow> 'a tree23" where
"tree\<^sub>i (T\<^sub>i t) = t" |
"tree\<^sub>i (Up\<^sub>i l a r) = Node2 l a r"

fun ins :: "'a::linorder \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>i" where
"ins x Leaf = Up\<^sub>i Leaf x Leaf" |
"ins x (Node2 l a r) =
   (case cmp x a of
      LT \<Rightarrow>
        (case ins x l of
           T\<^sub>i l' => T\<^sub>i (Node2 l' a r) |
           Up\<^sub>i l1 b l2 => T\<^sub>i (Node3 l1 b l2 a r)) |
      EQ \<Rightarrow> T\<^sub>i (Node2 l x r) |
      GT \<Rightarrow>
        (case ins x r of
           T\<^sub>i r' => T\<^sub>i (Node2 l a r') |
           Up\<^sub>i r1 b r2 => T\<^sub>i (Node3 l a r1 b r2)))" |
"ins x (Node3 l a m b r) =
   (case cmp x a of
      LT \<Rightarrow>
        (case ins x l of
           T\<^sub>i l' => T\<^sub>i (Node3 l' a m b r) |
           Up\<^sub>i l1 c l2 => Up\<^sub>i (Node2 l1 c l2) a (Node2 m b r)) |
      EQ \<Rightarrow> T\<^sub>i (Node3 l a m b r) |
      GT \<Rightarrow>
        (case cmp x b of
           GT \<Rightarrow>
             (case ins x r of
                T\<^sub>i r' => T\<^sub>i (Node3 l a m b r') |
                Up\<^sub>i r1 c r2 => Up\<^sub>i (Node2 l a m) b (Node2 r1 c r2)) |
           EQ \<Rightarrow> T\<^sub>i (Node3 l a m b r) |
           LT \<Rightarrow>
             (case ins x m of
                T\<^sub>i m' => T\<^sub>i (Node3 l a m' b r) |
                Up\<^sub>i m1 c m2 => Up\<^sub>i (Node2 l a m1) c (Node2 m2 b r))))"

hide_const insert

definition insert :: "'a::linorder \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
"insert x t = tree\<^sub>i(ins x t)"

datatype 'a up\<^sub>d = T\<^sub>d "'a tree23" | Up\<^sub>d "'a tree23"

fun tree\<^sub>d :: "'a up\<^sub>d \<Rightarrow> 'a tree23" where
"tree\<^sub>d (T\<^sub>d t) = t" |
"tree\<^sub>d (Up\<^sub>d t) = t"

(* Variation: return None to signal no-change *)

fun node21 :: "'a up\<^sub>d \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>d" where
"node21 (T\<^sub>d t1) a t2 = T\<^sub>d(Node2 t1 a t2)" |
"node21 (Up\<^sub>d t1) a (Node2 t2 b t3) = Up\<^sub>d(Node3 t1 a t2 b t3)" |
"node21 (Up\<^sub>d t1) a (Node3 t2 b t3 c t4) = T\<^sub>d(Node2 (Node2 t1 a t2) b (Node2 t3 c t4))"

fun node22 :: "'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a up\<^sub>d \<Rightarrow> 'a up\<^sub>d" where
"node22 t1 a (T\<^sub>d t2) = T\<^sub>d(Node2 t1 a t2)" |
"node22 (Node2 t1 b t2) a (Up\<^sub>d t3) = Up\<^sub>d(Node3 t1 b t2 a t3)" |
"node22 (Node3 t1 b t2 c t3) a (Up\<^sub>d t4) = T\<^sub>d(Node2 (Node2 t1 b t2) c (Node2 t3 a t4))"

fun node31 :: "'a up\<^sub>d \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>d" where
"node31 (T\<^sub>d t1) a t2 b t3 = T\<^sub>d(Node3 t1 a t2 b t3)" |
"node31 (Up\<^sub>d t1) a (Node2 t2 b t3) c t4 = T\<^sub>d(Node2 (Node3 t1 a t2 b t3) c t4)" |
"node31 (Up\<^sub>d t1) a (Node3 t2 b t3 c t4) d t5 = T\<^sub>d(Node3 (Node2 t1 a t2) b (Node2 t3 c t4) d t5)"

fun node32 :: "'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a up\<^sub>d \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>d" where
"node32 t1 a (T\<^sub>d t2) b t3 = T\<^sub>d(Node3 t1 a t2 b t3)" |
"node32 t1 a (Up\<^sub>d t2) b (Node2 t3 c t4) = T\<^sub>d(Node2 t1 a (Node3 t2 b t3 c t4))" |
"node32 t1 a (Up\<^sub>d t2) b (Node3 t3 c t4 d t5) = T\<^sub>d(Node3 t1 a (Node2 t2 b t3) c (Node2 t4 d t5))"

fun node33 :: "'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a \<Rightarrow> 'a up\<^sub>d \<Rightarrow> 'a up\<^sub>d" where
"node33 l a m b (T\<^sub>d r) = T\<^sub>d(Node3 l a m b r)" |
"node33 t1 a (Node2 t2 b t3) c (Up\<^sub>d t4) = T\<^sub>d(Node2 t1 a (Node3 t2 b t3 c t4))" |
"node33 t1 a (Node3 t2 b t3 c t4) d (Up\<^sub>d t5) = T\<^sub>d(Node3 t1 a (Node2 t2 b t3) c (Node2 t4 d t5))"

fun del_min :: "'a tree23 \<Rightarrow> 'a * 'a up\<^sub>d" where
"del_min (Node2 Leaf a Leaf) = (a, Up\<^sub>d Leaf)" |
"del_min (Node3 Leaf a Leaf b Leaf) = (a, T\<^sub>d(Node2 Leaf b Leaf))" |
"del_min (Node2 l a r) = (let (x,l') = del_min l in (x, node21 l' a r))" |
"del_min (Node3 l a m b r) = (let (x,l') = del_min l in (x, node31 l' a m b r))"

fun del :: "'a::linorder \<Rightarrow> 'a tree23 \<Rightarrow> 'a up\<^sub>d" where
"del x Leaf = T\<^sub>d Leaf" |
"del x (Node2 Leaf a Leaf) =
  (if x = a then Up\<^sub>d Leaf else T\<^sub>d(Node2 Leaf a Leaf))" |
"del x (Node3 Leaf a Leaf b Leaf) =
  T\<^sub>d(if x = a then Node2 Leaf b Leaf else
     if x = b then Node2 Leaf a Leaf
     else Node3 Leaf a Leaf b Leaf)" |
"del x (Node2 l a r) =
  (case cmp x a of
     LT \<Rightarrow> node21 (del x l) a r |
     GT \<Rightarrow> node22 l a (del x r) |
     EQ \<Rightarrow> let (a',t) = del_min r in node22 l a' t)" |
"del x (Node3 l a m b r) =
  (case cmp x a of
     LT \<Rightarrow> node31 (del x l) a m b r |
     EQ \<Rightarrow> let (a',m') = del_min m in node32 l a' m' b r |
     GT \<Rightarrow>
       (case cmp x b of
          LT \<Rightarrow> node32 l a (del x m) b r |
          EQ \<Rightarrow> let (b',r') = del_min r in node33 l a m b' r' |
          GT \<Rightarrow> node33 l a m b (del x r)))"

definition delete :: "'a::linorder \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
"delete x t = tree\<^sub>d(del x t)"

subsection "Functional Correctness"

subsubsection "Proofs for isin"

lemma "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> elems (inorder t))"
by (induction t) (auto simp: elems_simps1 ball_Un)

lemma isin_set: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> elems (inorder t))"
by (induction t) (auto simp: elems_simps2)

subsubsection "Proofs for insert"

lemma inorder_ins:
  "sorted(inorder t) \<Longrightarrow> inorder(tree\<^sub>i(ins x t)) = ins_list x (inorder t)"
by(induction t) (auto simp: ins_list_simps split: up\<^sub>i.splits)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert a t) = ins_list a (inorder t)"
by(simp add: insert_def inorder_ins)

subsubsection "Proofs for delete"

lemma inorder_node21: "height r > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node21 l' a r)) = inorder (tree\<^sub>d l') @ a # inorder r"
by(induct l' a r rule: node21.induct) auto

lemma inorder_node22: "height l > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node22 l a r')) = inorder l @ a # inorder (tree\<^sub>d r')"
by(induct l a r' rule: node22.induct) auto

lemma inorder_node31: "height m > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node31 l' a m b r)) = inorder (tree\<^sub>d l') @ a # inorder m @ b # inorder r"
by(induct l' a m b r rule: node31.induct) auto

lemma inorder_node32: "height r > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node32 l a m' b r)) = inorder l @ a # inorder (tree\<^sub>d m') @ b # inorder r"
by(induct l a m' b r rule: node32.induct) auto

lemma inorder_node33: "height m > 0 \<Longrightarrow>
  inorder (tree\<^sub>d (node33 l a m b r')) = inorder l @ a # inorder m @ b # inorder (tree\<^sub>d r')"
by(induct l a m b r' rule: node33.induct) auto

lemmas inorder_nodes = inorder_node21 inorder_node22
  inorder_node31 inorder_node32 inorder_node33

lemma del_minD:
  "del_min t = (x,t') \<Longrightarrow> bal t \<Longrightarrow> height t > 0 \<Longrightarrow>
  x # inorder(tree\<^sub>d t') = inorder t"
by(induction t arbitrary: t' rule: del_min.induct)
  (auto simp: inorder_nodes split: prod.splits)

lemma inorder_del: "\<lbrakk> bal t ; sorted(inorder t) \<rbrakk> \<Longrightarrow>
  inorder(tree\<^sub>d (del x t)) = del_list x (inorder t)"
by(induction t rule: del.induct)
  (auto simp: del_list_simps inorder_nodes del_minD split!: if_split prod.splits)

lemma inorder_delete: "\<lbrakk> bal t ; sorted(inorder t) \<rbrakk> \<Longrightarrow>
  inorder(delete x t) = del_list x (inorder t)"
by(simp add: delete_def inorder_del)

subsection \<open>Balancedness\<close>

subsubsection "Proofs for insert"

text{* First a standard proof that @{const ins} preserves @{const bal}. *}

instantiation up\<^sub>i :: (type)height
begin

fun height_up\<^sub>i :: "'a up\<^sub>i \<Rightarrow> nat" where
"height (T\<^sub>i t) = height t" |
"height (Up\<^sub>i l a r) = height l"

instance ..

end

lemma bal_ins: "bal t \<Longrightarrow> bal (tree\<^sub>i(ins a t)) \<and> height(ins a t) = height t"
by (induct t) (auto split!: if_split up\<^sub>i.split) (* 15 secs in 2015 *)

text{* Now an alternative proof (by Brian Huffman) that runs faster because
two properties (balance and height) are combined in one predicate. *}

inductive full :: "nat \<Rightarrow> 'a tree23 \<Rightarrow> bool" where
"full 0 Leaf" |
"\<lbrakk>full n l; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Node2 l p r)" |
"\<lbrakk>full n l; full n m; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Node3 l p m q r)"

inductive_cases full_elims:
  "full n Leaf"
  "full n (Node2 l p r)"
  "full n (Node3 l p m q r)"

inductive_cases full_0_elim: "full 0 t"
inductive_cases full_Suc_elim: "full (Suc n) t"

lemma full_0_iff [simp]: "full 0 t \<longleftrightarrow> t = Leaf"
  by (auto elim: full_0_elim intro: full.intros)

lemma full_Leaf_iff [simp]: "full n Leaf \<longleftrightarrow> n = 0"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Node2_iff [simp]:
  "full (Suc n) (Node2 l p r) \<longleftrightarrow> full n l \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Node3_iff [simp]:
  "full (Suc n) (Node3 l p m q r) \<longleftrightarrow> full n l \<and> full n m \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

lemma full_imp_height: "full n t \<Longrightarrow> height t = n"
  by (induct set: full, simp_all)

lemma full_imp_bal: "full n t \<Longrightarrow> bal t"
  by (induct set: full, auto dest: full_imp_height)

lemma bal_imp_full: "bal t \<Longrightarrow> full (height t) t"
  by (induct t, simp_all)

lemma bal_iff_full: "bal t \<longleftrightarrow> (\<exists>n. full n t)"
  by (auto elim!: bal_imp_full full_imp_bal)

text {* The @{const "insert"} function either preserves the height of the
tree, or increases it by one. The constructor returned by the @{term
"insert"} function determines which: A return value of the form @{term
"T\<^sub>i t"} indicates that the height will be the same. A value of the
form @{term "Up\<^sub>i l p r"} indicates an increase in height. *}

fun full\<^sub>i :: "nat \<Rightarrow> 'a up\<^sub>i \<Rightarrow> bool" where
"full\<^sub>i n (T\<^sub>i t) \<longleftrightarrow> full n t" |
"full\<^sub>i n (Up\<^sub>i l p r) \<longleftrightarrow> full n l \<and> full n r"

lemma full\<^sub>i_ins: "full n t \<Longrightarrow> full\<^sub>i n (ins a t)"
by (induct rule: full.induct) (auto split: up\<^sub>i.split)

text {* The @{const insert} operation preserves balance. *}

lemma bal_insert: "bal t \<Longrightarrow> bal (insert a t)"
unfolding bal_iff_full insert_def
apply (erule exE)
apply (drule full\<^sub>i_ins [of _ _ a])
apply (cases "ins a t")
apply (auto intro: full.intros)
done

subsection "Proofs for delete"

instantiation up\<^sub>d :: (type)height
begin

fun height_up\<^sub>d :: "'a up\<^sub>d \<Rightarrow> nat" where
"height (T\<^sub>d t) = height t" |
"height (Up\<^sub>d t) = height t + 1"

instance ..

end

lemma bal_tree\<^sub>d_node21:
  "\<lbrakk>bal r; bal (tree\<^sub>d l'); height r = height l' \<rbrakk> \<Longrightarrow> bal (tree\<^sub>d (node21 l' a r))"
by(induct l' a r rule: node21.induct) auto

lemma bal_tree\<^sub>d_node22:
  "\<lbrakk>bal(tree\<^sub>d r'); bal l; height r' = height l \<rbrakk> \<Longrightarrow> bal (tree\<^sub>d (node22 l a r'))"
by(induct l a r' rule: node22.induct) auto

lemma bal_tree\<^sub>d_node31:
  "\<lbrakk> bal (tree\<^sub>d l'); bal m; bal r; height l' = height r; height m = height r \<rbrakk>
  \<Longrightarrow> bal (tree\<^sub>d (node31 l' a m b r))"
by(induct l' a m b r rule: node31.induct) auto

lemma bal_tree\<^sub>d_node32:
  "\<lbrakk> bal l; bal (tree\<^sub>d m'); bal r; height l = height r; height m' = height r \<rbrakk>
  \<Longrightarrow> bal (tree\<^sub>d (node32 l a m' b r))"
by(induct l a m' b r rule: node32.induct) auto

lemma bal_tree\<^sub>d_node33:
  "\<lbrakk> bal l; bal m; bal(tree\<^sub>d r'); height l = height r'; height m = height r' \<rbrakk>
  \<Longrightarrow> bal (tree\<^sub>d (node33 l a m b r'))"
by(induct l a m b r' rule: node33.induct) auto

lemmas bals = bal_tree\<^sub>d_node21 bal_tree\<^sub>d_node22
  bal_tree\<^sub>d_node31 bal_tree\<^sub>d_node32 bal_tree\<^sub>d_node33

lemma height'_node21:
   "height r > 0 \<Longrightarrow> height(node21 l' a r) = max (height l') (height r) + 1"
by(induct l' a r rule: node21.induct)(simp_all)

lemma height'_node22:
   "height l > 0 \<Longrightarrow> height(node22 l a r') = max (height l) (height r') + 1"
by(induct l a r' rule: node22.induct)(simp_all)

lemma height'_node31:
  "height m > 0 \<Longrightarrow> height(node31 l a m b r) =
   max (height l) (max (height m) (height r)) + 1"
by(induct l a m b r rule: node31.induct)(simp_all add: max_def)

lemma height'_node32:
  "height r > 0 \<Longrightarrow> height(node32 l a m b r) =
   max (height l) (max (height m) (height r)) + 1"
by(induct l a m b r rule: node32.induct)(simp_all add: max_def)

lemma height'_node33:
  "height m > 0 \<Longrightarrow> height(node33 l a m b r) =
   max (height l) (max (height m) (height r)) + 1"
by(induct l a m b r rule: node33.induct)(simp_all add: max_def)

lemmas heights = height'_node21 height'_node22
  height'_node31 height'_node32 height'_node33

lemma height_del_min:
  "del_min t = (x, t') \<Longrightarrow> height t > 0 \<Longrightarrow> bal t \<Longrightarrow> height t' = height t"
by(induct t arbitrary: x t' rule: del_min.induct)
  (auto simp: heights split: prod.splits)

lemma height_del: "bal t \<Longrightarrow> height(del x t) = height t"
by(induction x t rule: del.induct)
  (auto simp: heights max_def height_del_min split: prod.splits)

lemma bal_del_min:
  "\<lbrakk> del_min t = (x, t'); bal t; height t > 0 \<rbrakk> \<Longrightarrow> bal (tree\<^sub>d t')"
by(induct t arbitrary: x t' rule: del_min.induct)
  (auto simp: heights height_del_min bals split: prod.splits)

lemma bal_tree\<^sub>d_del: "bal t \<Longrightarrow> bal(tree\<^sub>d(del x t))"
by(induction x t rule: del.induct)
  (auto simp: bals bal_del_min height_del height_del_min split: prod.splits)

corollary bal_delete: "bal t \<Longrightarrow> bal(delete x t)"
by(simp add: delete_def bal_tree\<^sub>d_del)

subsection \<open>Overall Correctness\<close>

interpretation Set_by_Ordered
where empty = Leaf and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = bal
proof (standard, goal_cases)
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 6 thus ?case by(simp add: bal_insert)
next
  case 7 thus ?case by(simp add: bal_delete)
qed simp+

end


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

datatype 'a list = nil2 | cons2 "'a" "'a list"
print_theorems
datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "((S (count n xs)) = (count n (cons2 n xs)))"
  apply(induct xs)
   apply clarsimp
   apply(induct n)
    apply fastforce+
  done

theorem property0' :
  "((S (count n xs)) = (count n (cons2 n xs)))"
  apply(induct xs arbitrary:n)
   apply clarsimp
   apply(induct_tac n)(*because n is quantified by "\<And>"*)
    apply fastforce+
  apply clarsimp
  apply presburger
  done

theorem property0 :
  "((S (count n xs)) = (count n (cons2 n xs)))"
  apply(induct rule:count.induct)
  nitpick
  oops
end


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

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

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

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

(*fun did not finish the proof*)
function twoThirds :: "int => int" where
  "twoThirds y =
   (if (y = 2) then 1 else
      (if (y = 1) then 1 else
         (if (y = 0) then 0 else 2 + (twoThirds (y - 3)))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "int list => int list"
  and nstoogesort2 :: "int list => int list"
  and nstooge2sort1 :: "int list => int list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

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

theorem property0 :
  "((count y (nstoogesort2 xs)) = (count y xs))"
  oops


theory
  Examples
  imports
  "Kruskal/Kruskal_Time"
  "BinarySearch"
  "FloydWarshall/FW_Code"
  "Remdups"
  "EdmondsKarp_Maxflow/EdmondsKarp_Time"
begin

section \<open>Remdups\<close>

term remdups_spec    \<comment> \<open>The specification for remdups\<close>
term rd_impl1         \<comment> \<open>The abstract algorithm in the NREST monad\<close>
thm rd_impl1_correct  \<comment> \<open>The correctness theorem\<close>

term remdups_impl    \<comment> \<open>The synthesised Imperative/HOL program\<close>

lemma "<$ (remdups_time (length as))>
          remdups_impl as
        <\<lambda>r. \<exists>\<^sub>Ara. da_assn id_assn ra r * \<up> (set as = set ra \<and> distinct ra)>\<^sub>t"
  by(rule remdups_rule)

lemma "remdups_time \<in> \<Theta>(\<lambda>n. n * ln n)"
  by(fact remdups_time_nln)

section \<open>Binary Search\<close>

term binarysearch_SPEC    \<comment> \<open>The specification for binary search\<close>
term binarysearch         \<comment> \<open>The abstract algorithm in the NREST monad\<close>
thm binarysearch_correct  \<comment> \<open>The correctness theorem\<close>

term binarysearch_impl    \<comment> \<open>The synthesised Imperative/HOL program\<close>

lemma binary_search_correct:
  assumes "sorted xs"  "l \<le> r" "r \<le> length xs"
  shows
    "<array_assn xs p * $(binarysearch_time (r - l))>
        binarysearch_impl l r x p
     <\<lambda>ra.   array_assn xs p * \<up> (ra \<longleftrightarrow> (\<exists>i\<ge>l. i < r \<and> xs ! i = x))>\<^sub>t"
  using assms binary_search_correct by blast

lemma binary_search_time_ln: "binarysearch_time \<in> \<Theta>(\<lambda>n. ln (real n))"
  by(fact binary_search_time_ln)

section \<open>Floyd Warshall\<close>

term fw_spec              \<comment> \<open>The specification for FloydWarshall\<close>
term fw'                  \<comment> \<open>The abstract algorithm in the NREST monad\<close>
thm fw'_spec              \<comment> \<open>The correctness theorem\<close>

term fw_impl    \<comment> \<open>The synthesised Imperative/HOL program\<close>

corollary
  shows
    "<mtx_curry_assn n M Mi * $(fw_time n)>
        fw_impl n Mi
     <\<lambda> Mi'. \<exists>\<^sub>A M'. mtx_curry_assn n M' Mi'
           * \<up>(if (\<exists> i \<le> n. M' i i < 0) then \<not> cyc_free M n
                else \<forall>i \<le> n. \<forall>j \<le> n. M' i j = D M i j n \<and> cyc_free M n)>\<^sub>t"
  by(fact fw_correct)

lemma "fw_time \<in> \<Theta>(\<lambda>n. n*n*n)"
  by (fact fw_time_n_cube)

section \<open>Kruskal\<close>

definition "kruskal getEdges_impl = Kruskal_intermediate_Impl.kruskal getEdges_impl uf_init uf_cmp uf_union sortEdges'"

lemma "kruskal getedges = Gr"
  unfolding kruskal_def apply(subst Kruskal_intermediate_Impl.kruskal_def) oops

lemma
  fixes connected path and E :: "nat uprod set"
  assumes "Kruskal_intermediate E forest connected path"
    \<comment> \<open>If we have a set of edges E for a Graph representation that provides
        predicates for forest, connected and path,...\<close>
    and  "E \<noteq>{}"
    and getEdges_impl_refines:
    "(uncurry0 getEdges_impl, uncurry0 (getEdges' weight E (enat (getEdges_time (card E))))) \<in> unit_assn\<^sup>k
                   \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
    \<comment> \<open>... and an implementation @{term getEdges_impl}, that gives a list of the edges of the Graph
          in time @{term getEdges_time}, ...  \<close>
    and getEdges_linear: "getEdges_time \<in> \<Theta>(\<lambda>n. n)"
    \<comment> \<open>... and the time bound @{term getEdges_time} is linear, then we can show ...  \<close>
  shows
    \<comment> \<open>... that kruskal (using the @{term getEdges_impl} subprogram) calculates
          a minimum spanning forest for the graph and ...  \<close>
    kruskal_correct:
      "<timeCredit_assn (kruskal_time getEdges_time (card E, Max (Kruskal_intermediate_defs.V E)))>
        kruskal getEdges_impl
       <\<lambda>r. \<exists>\<^sub>Ara. hr_comp (da_assn id_assn) (lst_graph_rel' weight) ra r * \<up> (minWeightBasis.minBasis E forest weight ra)>\<^sub>t"
  and
    \<comment> \<open> ... takes time in O( E * ln E + M + E * ln M ), where cE is the cardinality
          of the set of edges E, and M is the maximal node in the graph. \<close>
    kruska_time_bound:
      "kruskal_time getEdges_time \<in> \<Theta>\<^sub>2(\<lambda>(cE::nat,M::nat). cE * ln cE + M + cE * ln M )"
  subgoal
    unfolding kruskal_def
    apply(rule Kruskal_final.k_c)
    using assms unfolding Kruskal_final_def Kruskal_final_axioms_def by auto
  subgoal
    apply(rule kruskal_time_plus_linear) by fact
  done

section \<open>Edmonds Karp\<close>

context Network_Impl \<comment> \<open>given a Network c s t\<close>
begin

term Edka_Impl.edka5          \<comment> \<open>The abstract algorithm in the NREST monad\<close>
thm Edka_Impl.edka5_correct'  \<comment> \<open>The correctness theorem\<close>

term edka_imp    \<comment> \<open>The synthesised Imperative/HOL program\<close>

theorem edka_imp_correct:
      assumes VN: "Graph.V c = {0..<N}" and "s < N" and "t < N"
      assumes ABS_PS: "is_adj_map am"
      shows "<$(edka_cost (card V, card E))>
          edka_imp c s t N am
        <\<lambda>fi. \<exists>\<^sub>Af. is_rflow N f fi * \<up>(isMaxFlow f)>\<^sub>t"
  apply (rule edka_imp_correct) by fact+

lemma "edka_cost \<in> \<Theta>\<^sub>2(\<lambda>(V::nat,E::nat). (V * E) * (V + E) )"
  by(fact final_running_time)

end

thy_deps (Sepref_Basic|Akra_Bazzi_Method|NREST|SLTC)

end


(*<*)
theory Hilbert
  imports Main (* "HOL-Eisbach.Eisbach" *)

abbrevs
 not="\<^bold>\<not>" and disj="\<^bold>\<or>" and conj="\<^bold>\<and>" and impl="\<^bold>\<rightarrow>" and equiv="\<^bold>\<leftrightarrow>"
 and true="\<^bold>\<top>" and false="\<^bold>\<bottom>"
 and ob="\<^bold>\<circle>" and perm="\<^bold>P" and forb="\<^bold>F"

 and derivable="\<turnstile>"

begin
(*>*)

section \<open>Proving first theorems\<close>

subsection \<open>Hilbert Calculus for Classical Logic\<close>
text \<open>Technical remark at the beginning: In order to distinguish our connectives
from the usual logical connectives of the Isabelle/HOL system, we use @{text "\<^bold>b\<^bold>o\<^bold>l\<^bold>d"}-face written
versions of them. You may use the abbreviations at the top of the document (in the theory file)
to write things down, e.g. if you start writing "dis..." (the abbreviation is "disj"),
Isabelle should suggest the autocompletion for @{text "\<^bold>\<or>"}, etc.\<close>

typedecl \<sigma> \<comment> \<open>Introduce new type for syntactical formulae (propositions).\<close>

declare [[show_types]]

text \<open>
For our classical propositional language, we introduce two primitive symbols:
Implication and negation. The others can be defined in terms of these two.
\<close>
consts PLimpl :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "\<^bold>\<rightarrow>" 49)
       PLnot :: "\<sigma> \<Rightarrow> \<sigma>" ("\<^bold>\<not>_" [52]53)

consts PLatomicProp :: "\<sigma>" ("p")

definition PLdisj :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "\<^bold>\<or>" 50) where "a \<^bold>\<or> b \<equiv> \<^bold>\<not>a \<^bold>\<rightarrow> b"
definition PLconj :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "\<^bold>\<and>" 51) where "a \<^bold>\<and> b \<equiv> \<^bold>\<not>(\<^bold>\<not>a \<^bold>\<or> \<^bold>\<not>b)"
definition PLequi :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infix "\<^bold>\<leftrightarrow>" 48) where "a \<^bold>\<leftrightarrow> b \<equiv> (a \<^bold>\<rightarrow> b) \<^bold>\<and> (b \<^bold>\<rightarrow> a)"
definition PLtop :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> p \<^bold>\<or> \<^bold>\<not>p"
definition PLbot :: "\<sigma>" ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<^bold>\<not>\<^bold>\<top>"

text \<open>Next we define the notion of syntactical derivability and consequence: \<close>

consts derivable :: "\<sigma> \<Rightarrow> bool" ("\<turnstile> _" 40)
definition consequence :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> bool" ("_ \<turnstile> _" 40) where "A \<turnstile> B \<equiv> \<turnstile> (A \<^bold>\<rightarrow> B)"

text \<open>We can now axiomatize the derivability relation using a Hilbert-style system:\<close>

axiomatization where
  A2:  "\<turnstile> A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)" and (* Three Hilbert-style axioms *)
  A3:  "\<turnstile> (A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> C)) \<^bold>\<rightarrow> ((A \<^bold>\<rightarrow> B) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> C))" and
  A4:  "\<turnstile> (\<^bold>\<not>A \<^bold>\<rightarrow> \<^bold>\<not>B) \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)" and
  MP:  "\<turnstile> (A \<^bold>\<rightarrow> B) \<Longrightarrow> \<turnstile> A \<Longrightarrow> \<turnstile> B" (* One inference rule: Modus ponens *)

paragraph \<open>Proof example.\<close>
text \<open>Now we are ready to proof first simple theorems:\<close>

lemma "\<turnstile> A \<^bold>\<rightarrow> A"
proof -
  have 1: "\<turnstile> (A \<^bold>\<rightarrow> ((B \<^bold>\<rightarrow> A) \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> ((A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> A))" using A3 by force
  have 2: "\<turnstile> A \<^bold>\<rightarrow> ((B \<^bold>\<rightarrow> A) \<^bold>\<rightarrow> A)" by (simp add: A2)
  from 1 2 have 3: "\<turnstile> (A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> A)" by (rule MP)
  have 4: "\<turnstile> A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)" by (rule A2[of _ _])
  from 3 4 have "\<turnstile> A \<^bold>\<rightarrow> A" by (rule MP)
  then show ?thesis .
qed

text \<open>The same proof a little bit nicer with syntactic sugar:\<close>
lemma "\<turnstile> A \<^bold>\<rightarrow> A"
proof -
  have "\<turnstile> (A \<^bold>\<rightarrow> ((B \<^bold>\<rightarrow> A) \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> ((A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> A))" by (rule A3[of _ "B \<^bold>\<rightarrow> A" "A"])
  moreover have "\<turnstile> A \<^bold>\<rightarrow> ((B \<^bold>\<rightarrow> A) \<^bold>\<rightarrow> A)" by (rule A2[of _ "B \<^bold>\<rightarrow> A"])
  ultimately have "\<turnstile> (A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> A)" by (rule MP)
  moreover have "\<turnstile> A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)" by (rule A2[of _ _])
  ultimately show "\<turnstile> A \<^bold>\<rightarrow> A" by (rule MP)
qed

subsection \<open>Exercises\<close>
paragraph \<open>Exercise 2.\<close>
text \<open>Prove one of the following statements by giving an explicit proof within
the given Hilbert calculus. Please make sure that every inference step in your
proof is fine-grained and annotated with the respective calculus rule name.

Hint: Find a proof first by pen-and-paper work and then formalize it within Isabelle.\<close>

text \<open>
  \<^item> @{prop "\<turnstile> \<^bold>\<not>(F \<^bold>\<rightarrow> F) \<^bold>\<rightarrow> G"}
  \<^item> @{prop "\<turnstile> \<^bold>\<not>\<^bold>\<not>F \<^bold>\<rightarrow> F"}
\<close>

text "We will later see that many proofs can in fact be done almost automatically by Isabelle,
see e.g. the example from further above:"

lemma PL1: "\<turnstile> A \<^bold>\<rightarrow> A" using A2 A3 MP by blast
lemma PL2: "\<turnstile> \<^bold>\<not>(F \<^bold>\<rightarrow> F) \<^bold>\<rightarrow> G" by (metis A2 A3 A4 MP)
lemma PL3: "\<turnstile> \<^bold>\<not>\<^bold>\<not>F \<^bold>\<rightarrow> F" by (metis A2 A3 A4 MP)

text \<open>Also, to make things look a bit nicer, we define a compound strategy @{text "PL"}
(for "Propositional Logic") that applies an internal automated theorem prover with the
respective axioms for propositional logic (A2, A3, A4 and MP)\<close>
(*<*)
named_theorems add \<comment> \<open>Needed for technical reasons\<close>
(*>*)
(* method PL declares add = (metis A2 A3 A4 MP add) *)

text \<open>In the following, we can simply use @{text "by PL"} for proving propositional
tautologies. However, as proofs can be arbitrarily complicated, this method may fail
for difficult formulas.\<close>

section \<open>Hilbert proofs for MDL\<close>

text "We augment the language PL with the new connectives of MDL:"

consts ob :: "\<sigma> \<Rightarrow> \<sigma>" ("\<^bold>\<circle>_" [52]53) \<comment> \<open>New atomic connective for obligation\<close>

text \<open>The other new deontic logic connective can be defined as usual:\<close>

definition perm :: "\<sigma> \<Rightarrow> \<sigma>" ("\<^bold>P_" [52]53) where "\<^bold>P a \<equiv> \<^bold>\<not>(\<^bold>\<circle>(\<^bold>\<not>a))"
definition forbidden :: "\<sigma> \<Rightarrow> \<sigma>" ("\<^bold>F_" [52]53) where "\<^bold>F a \<equiv> \<^bold>\<circle>(\<^bold>\<not>a)"

text \<open>Next, we additionally augment the axiomatization of our proof system for PL
with the rules of the system D for MDL:\<close>

axiomatization where
  K:   "\<turnstile> \<^bold>\<circle>(A \<^bold>\<rightarrow> B) \<^bold>\<rightarrow> (\<^bold>\<circle>A \<^bold>\<rightarrow> \<^bold>\<circle>B)" and
  D:   "\<turnstile> \<^bold>\<circle>A \<^bold>\<rightarrow> \<^bold>PA" and
  NEC: "\<turnstile> A \<Longrightarrow> \<turnstile> (\<^bold>\<circle>A)"

subsection \<open>MDL Proof Examples\<close>

lemma "\<turnstile> \<^bold>\<circle>(p \<^bold>\<and> q) \<^bold>\<rightarrow> \<^bold>\<circle>p"
proof -
  have 1: "\<turnstile> (p \<^bold>\<and> q) \<^bold>\<rightarrow> p" by (metis A2 A3 A4 MP PL3 PLconj_def PLdisj_def) (* by (PL add: PLconj_def PLdisj_def) *)
  from 1 have 2: "\<turnstile> \<^bold>\<circle>((p \<^bold>\<and> q) \<^bold>\<rightarrow> p)" by (rule NEC)
  have 3: "\<turnstile> \<^bold>\<circle>((p \<^bold>\<and> q) \<^bold>\<rightarrow> p) \<^bold>\<rightarrow> \<^bold>\<circle>(p \<^bold>\<and> q) \<^bold>\<rightarrow> \<^bold>\<circle>p" by (rule K)
  from 3 2 show "\<turnstile> \<^bold>\<circle>(p \<^bold>\<and> q) \<^bold>\<rightarrow> \<^bold>\<circle>p" by (rule MP)
qed

text \<open>Note that, although we have the necessitation rule @{thm "NEC"} , the formula
@{term "A \<^bold>\<rightarrow> \<^bold>\<circle>A"} is not generally valid:\<close>

lemma "\<turnstile> a \<^bold>\<rightarrow> \<^bold>\<circle>a" nitpick[user_axioms,expect=genuine] oops

subsection \<open>Exercises\<close>
paragraph \<open>Exercise 2.\<close>
text \<open>Prove the following statement by giving an explicit proof within
the given Hilbert calculus. Please make sure that every inference step in your
proof is fine-grained and annotated with the respective calculus rule name. You may use
the general {method "PL"} method for inferring propositional tautologies.

Hint: Reuse your proof from the previous exercise sheet and formalize it within Isabelle.\<close>

text \<open>
  \<^item> @{prop "\<turnstile> \<^bold>\<not>\<^bold>\<circle>\<^bold>\<bottom>"}
\<close>

lemma "\<turnstile> \<^bold>\<not>\<^bold>\<circle>\<^bold>\<bottom>" sledgehammer oops

(*<*)
end
(*>*)


(*  Title:      Containers/List_Proper_Interval.thy
    Author:     Andreas Lochbihler, ETH Zurich *)

theory List_Proper_Interval imports
  "~~/src/HOL/Library/List_lexord"
  Collection_Order
begin

section {* Instantiate @{class proper_interval} of for @{typ "'a list"} *}

lemma Nil_less_conv_neq_Nil: "[] < xs \<longleftrightarrow> xs \<noteq> []"
by(cases xs) simp_all

lemma less_append_same_iff:
  fixes xs :: "'a :: preorder list"
  shows "xs < xs @ ys \<longleftrightarrow> [] < ys"
by(induct xs) simp_all

lemma less_append_same2_iff:
  fixes xs :: "'a :: preorder list"
  shows "xs @ ys < xs @ zs \<longleftrightarrow> ys < zs"
by(induct xs) simp_all

lemma Cons_less_iff:
  fixes x :: "'a :: preorder" shows
  "x # xs < ys \<longleftrightarrow> (\<exists>y ys'. ys = y # ys' \<and> (x < y \<or> x = y \<and> xs < ys'))"
by(cases ys) auto

instantiation list :: ("{proper_interval, order}") proper_interval begin

definition proper_interval_list_aux :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where proper_interval_list_aux_correct:
  "proper_interval_list_aux xs ys \<longleftrightarrow> (\<exists>zs. xs < zs \<and> zs < ys)"

lemma proper_interval_list_aux_simps [code]:
  "proper_interval_list_aux xs [] \<longleftrightarrow> False"
  "proper_interval_list_aux [] (y # ys) \<longleftrightarrow> ys \<noteq> [] \<or> proper_interval None (Some y)"
  "proper_interval_list_aux (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> x = y \<and> proper_interval_list_aux xs ys"
apply(simp_all add: proper_interval_list_aux_correct proper_interval_simps Nil_less_conv_neq_Nil)
 apply(fastforce simp add: neq_Nil_conv)
apply(rule iffI)
 apply(fastforce simp add: Cons_less_iff intro: less_trans)
apply(erule disjE)
 apply(rule exI[where x="x # xs @ [undefined]"])
 apply(simp add: less_append_same_iff)
apply(auto 4 3 simp add: Cons_less_iff)
done

fun proper_interval_list :: "'a list option \<Rightarrow> 'a list option \<Rightarrow> bool" where
  "proper_interval_list None None \<longleftrightarrow> True"
| "proper_interval_list None (Some xs) \<longleftrightarrow> (xs \<noteq> [])"
| "proper_interval_list (Some xs) None \<longleftrightarrow> True"
| "proper_interval_list (Some xs) (Some ys) \<longleftrightarrow> proper_interval_list_aux xs ys"
instance
proof(intro_classes)
  fix xs ys :: "'a list"
  show "proper_interval None (Some ys) \<longleftrightarrow> (\<exists>zs. zs < ys)"
    by(auto simp add: Nil_less_conv_neq_Nil intro: exI[where x="[]"])
  show "proper_interval (Some xs) None \<longleftrightarrow> (\<exists>zs. xs < zs)"
    by(simp add: exI[where x="xs @ [undefined]"] less_append_same_iff)
  show "proper_interval (Some xs) (Some ys) \<longleftrightarrow> (\<exists>zs. xs < zs \<and> zs < ys)"
    by(simp add: proper_interval_list_aux_correct)
qed simp
end

end


theory Chapter5
imports Main
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter_0: "iter r 0 x x" |
iter_Suc: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

text{*
\section*{Chapter 5}

\exercise
Give a readable, structured proof of the following lemma:
*}
lemma assumes T: "\<forall>x y. T x y \<or> T y x"
  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
(* your definition/proof here *)

text{*
Each step should use at most one of the assumptions @{text T}, @{text A}
or @{text TA}.
\endexercise

\exercise
Give a readable, structured proof of the following lemma:
*}
lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs)
      \<or> (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
(* your definition/proof here *)

text{*
Hint: There are predefined functions @{const take} and {const drop} of type
@{typ "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"} such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"}
and @{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
the relevant @{const take} and @{const drop} lemmas for you.
\endexercise

\exercise
Give a structured proof by rule inversion:
*}
inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"
lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
(* your definition/proof here *)

text{*
\exercise
Give a structured proof by rule inversions:
*}

lemma "\<not> ev(Suc(Suc(Suc 0)))"
(* your definition/proof here *)

text{*
If there are no cases to be proved you can close
a proof immediateley with \isacom{qed}.
\endexercise

\exercise
Recall predicate @{const star} from Section 4.5 and @{const iter}
from Exercise~\ref{exe:iter}.
*}

lemma "iter r n x y \<Longrightarrow> star r x y"
(* your definition/proof here *)

text{*
Prove this lemma in a structured style, do not just sledgehammer each case of the
required induction.
\endexercise

\exercise
Define a recursive function
*}

fun elems :: "'a list \<Rightarrow> 'a set" where
(* your definition/proof here *)

text{* that collects all elements of a list into a set. Prove *}

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Extend Exercise~\ref{exe:cfg} with a function that checks if some
\mbox{@{text "alpha list"}} is a balanced
string of parentheses. More precisely, define a recursive function *}
(* your definition/proof here *)
fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

text{* such that @{term"balanced n w"}
is true iff (informally) @{text"a\<^sup>n @ w \<in> S"}. Formally, prove *}

corollary "balanced n w \<longleftrightarrow> S (replicate n a @ w)"

text{* where @{const replicate} @{text"::"} @{typ"nat \<Rightarrow> 'a \<Rightarrow> 'a list"} is predefined
and @{term"replicate n x"} yields the list @{text"[x, \<dots>, x]"} of length @{text n}.
*}

end