theory Chapter2
imports Main
begin

text{*
\section*{Chapter 2}

\exercise
Use the \textbf{value} command to evaluate the following expressions:
*}

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

text{*
\endexercise

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

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

text{*
Prove that @{const add} is associative and commutative.
You will need additional lemmas.
*}

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

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

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

text{* Define a recursive function *}

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

text{* and prove that *}

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

text{*
\endexercise

\exercise
Define a function that counts the number of occurrences of
an element in a list:
*}

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

value "count ([1, 4, 4, 5, 4]::nat list) 4"

text {*
Test your definition of @{term count} on some examples.
Prove the following inequality:
*}

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

text{*
\endexercise

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

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

value "snoc ([1, 2, 3]::nat list) 4"
value "snoc ([]::nat list) 0"

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

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

value "reverse ([1,2,3]::nat list)"

text {*
Prove the following theorem. You will need an additional lemma.
*}
lemma reverse_snoc [simp]: "reverse (snoc xs a) = a # (reverse xs)"
  apply(induction xs)
  apply(auto)
  done

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

text{*
\endexercise

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

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

value "sum_upto 3"

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

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

text{*
\endexercise

\exercise
Starting from the type @{text "'a tree"} defined in the text, define
a function that collects all values in a tree in a list, in any order,
without removing duplicates.
*}
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

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

value "contents ((Node (Node (Node Tip 1 Tip) 2 Tip) 5 (Node Tip 8 Tip)):: nat tree)"

text{*
Then define a function that sums up all values in a tree of natural numbers
*}

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

value "sum_tree ((Node (Node (Node Tip 1 Tip) 2 Tip) 5 (Node Tip 8 Tip)):: nat tree)"

text{* and prove *}

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

text{*
\endexercise

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

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

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

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

value "pre_order (mirror ((Node (Node (Node Tip 1 Tip) 2 Tip) 5 (Node Tip 8 Tip)):: nat tree))"
value "post_order ((Node (Node (Node Tip 1 Tip) 2 Tip) 5 (Node Tip 8 Tip)):: nat tree)"

text{*
that traverse a tree and collect all stored values in the respective order in
a list. Prove *}

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

text{*
\endexercise

\exercise
Define a recursive function
*}

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

value "intersperse 8 [1,2,3,4]:: nat list"

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

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

text{*
\endexercise

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

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

value "itadd 4 3"

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

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

text{*
\endexercise

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

datatype tree0 = Leaf | Node tree0 tree0

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

text {*
Consider the following recursive function:
*}

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

value "nodes (explode 3 (Node Leaf Leaf))"

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

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

lemma expl_tree: "nodes(explode n t) = (2^n)*(nodes t + 1) - 1"
  apply(induct n arbitrary:t)
  apply(auto simp:algebra_simps)
  done

text{*

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

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

text{*
Define a function @{text eval} that evaluates an expression at some value:
*}

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var v = v" |
"eval (Const e) v = e" |
"eval (Add e f) v = (eval e v) + (eval f v)" |
"eval (Mult e f) v = (eval e v) * (eval f v)"

value "eval (Mult (Const 5) (Add Var (Const 1))) 4"

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

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

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

value "evalp [2,1,3] 2"
value "evalp [0,1] (-1)"

text{*
Define a function @{text coeffs} that transforms an expression into a polynomial.
This will require auxiliary functions.
*}

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

lemma evalp_add[simp]: "evalp (add_coeff xs ys) x = (evalp xs x) + (evalp ys x)"
  apply(induction xs rule:add_coeff.induct)
  apply(auto simp:algebra_simps)
  done

fun mult :: "int \<Rightarrow> int list \<Rightarrow> int list" where
"mult n [] = []" |
"mult n (x # xs) = (n * x) # (mult n xs)"

lemma evalp_mul[simp]: "evalp (mult n xs) v = n * (evalp xs v)"
  apply(induction xs)
  apply(auto simp:algebra_simps)
  done

fun mult_coeff :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"mult_coeff [] ys = []" |
"mult_coeff (x # xs) ys = add_coeff (mult x ys) (0 # (mult_coeff xs ys))"

lemma evalp_mult[simp]: "evalp (mult_coeff xs ys) x = (evalp xs x) * (evalp ys x)"
  apply(induction xs)
  apply(auto simp:algebra_simps)
  done

fun coeff :: "exp \<Rightarrow> int list" where
"coeff Var = [0,1]" |
"coeff (Const i) = [i]" |
"coeff (Add e f) = add_coeff (coeff e) (coeff f)" |
"coeff (Mult e f) = mult_coeff (coeff e) (coeff f)"

text{*
Prove that @{text coeffs} preserves the value of the expression:
*}

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

text{*
Hint: consider the hint in Exercise~\ref{exe:tree0}.
\endexercise
*}

end


(*  Title:      ZF/ex/NatSum.thy
    Author:     Tobias Nipkow & Lawrence C Paulson

A summation operator. sum(f,n+1) is the sum of all f(i), i=0...n.

Note: n is a natural number but the sum is an integer,
                            and f maps integers to integers

Summing natural numbers, squares, cubes, etc.

Originally demonstrated permutative rewriting, but add_ac is no longer needed
  thanks to new simprocs.

Thanks to Sloane's On-Line Encyclopedia of Integer Sequences,
  http://www.research.att.com/~njas/sequences/
*)

theory NatSum imports ZF begin

consts sum :: "[i=>i, i] => i"
primrec
  "sum (f,0) = #0"
  "sum (f, succ(n)) = f($#n) $+ sum(f,n)"

declare zadd_zmult_distrib [simp]  zadd_zmult_distrib2 [simp]
declare zdiff_zmult_distrib [simp] zdiff_zmult_distrib2 [simp]

(*The sum of the first n odd numbers equals n squared.*)
lemma sum_of_odds: "n \<in> nat ==> sum (%i. i $+ i $+ #1, n) = $#n $* $#n"
by (induct_tac "n", auto)

(*The sum of the first n odd squares*)
lemma sum_of_odd_squares:
     "n \<in> nat ==> #3 $* sum (%i. (i $+ i $+ #1) $* (i $+ i $+ #1), n) =
      $#n $* (#4 $* $#n $* $#n $- #1)"
by (induct_tac "n", auto)

(*The sum of the first n odd cubes*)
lemma sum_of_odd_cubes:
     "n \<in> nat
      ==> sum (%i. (i $+ i $+ #1) $* (i $+ i $+ #1) $* (i $+ i $+ #1), n) =
          $#n $* $#n $* (#2 $* $#n $* $#n $- #1)"
by (induct_tac "n", auto)

(*The sum of the first n positive integers equals n(n+1)/2.*)
lemma sum_of_naturals:
     "n \<in> nat ==> #2 $* sum(%i. i, succ(n)) = $#n $* $#succ(n)"
by (induct_tac "n", auto)

lemma sum_of_squares:
     "n \<in> nat ==> #6 $* sum (%i. i$*i, succ(n)) =
                  $#n $* ($#n $+ #1) $* (#2 $* $#n $+ #1)"
by (induct_tac "n", auto)

lemma sum_of_cubes:
     "n \<in> nat ==> #4 $* sum (%i. i$*i$*i, succ(n)) =
                  $#n $* $#n $* ($#n $+ #1) $* ($#n $+ #1)"
by (induct_tac "n", auto)

(** Sum of fourth powers **)

lemma sum_of_fourth_powers:
     "n \<in> nat ==> #30 $* sum (%i. i$*i$*i$*i, succ(n)) =
                    $#n $* ($#n $+ #1) $* (#2 $* $#n $+ #1) $*
                    (#3 $* $#n $* $#n $+ #3 $* $#n $- #1)"
by (induct_tac "n", auto)

end


section\<open>Sum of divisors function\<close>

theory Sigma
imports PerfectBasics "HOL-Library.Infinite_Set"
begin

definition divisors :: "nat \<Rightarrow> nat set" where
    "divisors m \<equiv> {n . n dvd m}"

abbreviation sigma :: "nat \<Rightarrow> nat" where
    "sigma m \<equiv> \<Sum> (divisors(m))"

lemma divisors_eq_dvd[iff]: "(a \<in> divisors(n)) \<longleftrightarrow> (a dvd n)"
  by(simp add: divisors_def)

lemma finite_divisors [simp]:
   assumes "n>0" shows "finite (divisors n)"
  by (simp add: assms divisors_def)

lemma divs_of_zero_UNIV[simp]: "divisors(0) = UNIV"
  by(auto simp add: divisors_def)

lemma sigma0[simp]: "sigma(0) = 0"
  by simp

lemma sigma1[simp]: "sigma(Suc 0) = 1"
  by (simp add: sum_eq_Suc0_iff)

lemma prime_divisors: "prime p \<longleftrightarrow> divisors p = {1,p} \<and> p>1"
  by (auto simp add: divisors_def prime_nat_iff)

lemma prime_imp_sigma: "prime (p::nat) \<Longrightarrow> sigma(p) = p+1"
proof -
  assume "prime (p::nat)"
  hence "p>1 \<and> divisors(p) = {1,p}" by (simp add: prime_divisors)
  hence "p>1 \<and> sigma(p) = \<Sum> {1,p}" by (auto simp only: divisors_def)
  thus "sigma(p) = p+1" by simp
qed

lemma sigma_third_divisor:
  assumes "1 < a" "a < n" "a dvd n"
  shows "1+a+n \<le> sigma(n)"
proof -
  from assms have "{1,a,n} \<le> divisors n"
    by auto
  hence "\<Sum> {1,a,n} \<le> sigma n"
    by (meson \<open>a < n\<close> finite_divisors order.strict_trans1 sum_mono2 zero_le)
  with assms show ?thesis by auto
qed

proposition prime_iff_sigma: "prime n \<longleftrightarrow> sigma(n) = Suc n"
proof
  assume L: "sigma(n) = Suc n"
  then have "n > 1"
    using less_linear sigma1 by fastforce
  moreover
  have "m = Suc 0" if "m dvd n" "m \<noteq> n" for m
  proof -
    have "0 < m"
      using that by auto
    then have "\<not> 1 + m + n \<le> 1 + n"
      by linarith
    then show ?thesis
      using sigma_third_divisor [of m]
      by (metis L One_nat_def Suc_lessD Suc_lessI \<open>n > 1\<close> dvd_imp_le \<open>0 < m\<close> less_le plus_1_eq_Suc that)
  qed
  then have "divisors n = {n,1}"
    by (auto simp: divisors_def)
  ultimately show "prime n"
    by (simp add: insert_commute prime_divisors)
qed (use prime_divisors in auto)

lemma dvd_prime_power_iff:
  fixes p::nat
  assumes prime: "prime p"
  shows "{d. d dvd p^n} = (\<lambda>k. p^k) ` {0..n}"
  using divides_primepow_nat prime by (auto simp add: le_imp_power_dvd)

lemma rewrite_sum_of_powers:
  assumes p: "(p::nat)>1"
  shows "\<Sum> ((^) p ` {0..n}) = (\<Sum> i = 0 .. n . p^i)" (is "?l = ?r")
  by (metis inj_on_def p power_inject_exp sum.reindex_cong)

lemma sum_of_powers_int: "(x - 1::int) * (\<Sum>i=0..n . x^i) = x ^ Suc n - 1"
  by (metis atLeast0AtMost lessThan_Suc_atMost power_diff_1_eq)

lemma sum_of_powers_nat: "(x - 1::nat) * (\<Sum>i=0..n . x^i) = x ^ Suc n - 1"
   (is "?l = ?r")
proof (cases "x = 0")
  case False
  then have "int ((x - 1) * sum ((^) x) {0..n}) = int (x ^ Suc n - 1)"
    using sum_of_powers_int [of "int x" n] by (simp add: of_nat_diff)
  then show ?thesis
    using of_nat_eq_iff by blast
qed auto

theorem sigma_primepower:
  assumes "prime p"
  shows "(p - 1) * sigma(p^e) = p^(e+1) - 1"
proof -
  have "sigma(p^e) = (\<Sum>i=0..e . p^i)"
    using assms divisors_def dvd_prime_power_iff prime_nat_iff rewrite_sum_of_powers by auto
  thus "(p - 1)*sigma(p^e) = p^(e+1) - 1"
    using sum_of_powers_nat by auto
qed

proposition sigma_prime_power_two: "sigma(2^n) = 2^(n+1) - 1"
proof -
  have "(2 - 1) * sigma(2^n) = 2^(n+1) - 1"
    by (auto simp only: sigma_primepower two_is_prime_nat)
  thus ?thesis by simp
qed

lemma div_decomp_comp:
  fixes a::nat
  shows "coprime m n \<Longrightarrow> a dvd m*n \<longleftrightarrow> (\<exists>b c. a = b * c \<and> b dvd m \<and> c dvd n)"
by (auto simp only: division_decomp mult_dvd_mono)

theorem sigma_semimultiplicative:
  assumes p: "prime p" and cop: "coprime p m"
  shows "sigma (p^n) * sigma m = sigma (p^n * m)" (is "?lhs = ?rhs")
proof -
  from cop have cop2: "coprime (p^n) m"
    by simp
  from p have "?lhs = \<Sum>((\<lambda>f. p^f) ` {0..n}) * sigma m"
    using divisors_def dvd_prime_power_iff by auto
  also from cop have "... = (\<Sum> {p^f*b| f b . f\<le>n \<and> b dvd m})"
    by (auto simp add: prodsums_eq_sumprods prime_nat_iff)
  also have "... = (\<Sum> {a*b| a b . a dvd (p^n) \<and> b dvd m})"
    by (metis (no_types, opaque_lifting) le_imp_power_dvd divides_primepow_nat p)
  also have "\<dots> = \<Sum>{c. c dvd (p^n*m)}"
    using cop2 div_decomp_comp by auto
  finally show ?thesis
    by (simp add: divisors_def)
qed

end


theory Traversal imports Main begin

text \<open> Define a datatype @{text"'a tree"} for binary trees. Both leaf and
internal nodes store information. \<close>

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

text \<open> Define the functions @{term preOrder}, @{term postOrder}, and @{term
inOrder} that traverse an @{text"'a tree"} in the respective order. \<close>

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

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

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

text \<open> Define a function @{term mirror} that returns the mirror image of an
@{text "'a tree"}. \<close>

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

text \<open> Suppose that @{term xOrder} and @{term yOrder} are tree traversal
functions chosen from @{term preOrder}, @{term postOrder}, and @{term inOrder}.
Formulate and prove all valid properties of the form \mbox{@{text "xOrder
(mirror xt) = rev (yOrder xt)"}}. \<close>

lemma "inOrder (mirror xt) = rev (inOrder xt)"
  apply (induction xt) by auto

lemma "preOrder (mirror xt) = rev (postOrder xt)"
  apply (induction xt) by auto

lemma "postOrder (mirror xt) = rev (preOrder xt)"
  apply (induction xt) by auto

text \<open> Define the functions @{term root}, @{term leftmost} and @{term
rightmost}, that return the root, leftmost, and rightmost element respectively.
\<close>

definition root :: "'a tree \<Rightarrow> 'a"
  where
"root t = (case t of
          Tip x \<Rightarrow> x |
          Node x _ _ \<Rightarrow> x)"

primrec leftmost :: "'a tree \<Rightarrow> 'a"
  where
"leftmost (Tip x) = x" |
"leftmost (Node x l r) = leftmost l"

primrec rightmost :: "'a tree \<Rightarrow> 'a"
  where
"rightmost (Tip x) = x" |
"rightmost (Node x l r) = rightmost r"

text \<open> Prove (or let Isabelle disprove) the theorems that follow.  You
may have to prove some lemmas first. \<close>

lemma inOrder_not_empty:"inOrder xs \<noteq> []"
  apply (induction xs) by auto

theorem "last (inOrder xt) = rightmost xt"
  apply (induction xt)
  by (auto simp add: inOrder_not_empty)

theorem "hd (inOrder xt) = leftmost xt"
  apply (induction xt)
  by (auto simp add: inOrder_not_empty)

theorem "hd (preOrder xt) = last (postOrder xt)"
  apply (induction xt) by auto

theorem "hd (preOrder xt) = root xt"
  apply (induction xt)
  by (auto simp add: root_def)

theorem "hd (inOrder xt) = root xt"
(*
Auto Quickcheck found a counterexample:
  xt = Node a\<^sub>1 (Tip a\<^sub>2) (Tip a\<^sub>1)
Evaluated terms:
  hd (inOrder xt) = a\<^sub>2
  root xt = a\<^sub>1
*)
(*<*) oops (*>*)

theorem "last (postOrder xt) = root xt"
  apply (induction xt) by (auto simp add: root_def)

(*<*) end (*>*)


(*  Title: HOL/ex/Birthday_Paradox.thy
    Author: Lukas Bulwahn, TU Muenchen, 2007
*)

section {* A Formulation of the Birthday Paradox *}

theory Birthday_Paradox
imports Main "~~/src/HOL/Fact" "~~/src/HOL/Library/FuncSet"
begin

section {* Cardinality *}

lemma card_product_dependent:
  assumes "finite S"
  assumes "\<forall>x \<in> S. finite (T x)"
  shows "card {(x, y). x \<in> S \<and> y \<in> T x} = (\<Sum>x \<in> S. card (T x))"
  using card_SigmaI[OF assms, symmetric] by (auto intro!: arg_cong[where f=card] simp add: Sigma_def)

lemma card_extensional_funcset_inj_on:
  assumes "finite S" "finite T" "card S \<le> card T"
  shows "card {f \<in> extensional_funcset S T. inj_on f S} = fact (card T) div (fact (card T - card S))"
using assms
proof (induct S arbitrary: T rule: finite_induct)
  case empty
  from this show ?case by (simp add: Collect_conv_if PiE_empty_domain)
next
  case (insert x S)
  { fix x
    from `finite T` have "finite (T - {x})" by auto
    from `finite S` this have "finite (extensional_funcset S (T - {x}))"
      by (rule finite_PiE)
    moreover
    have "{f : extensional_funcset S (T - {x}). inj_on f S} \<subseteq> (extensional_funcset S (T - {x}))" by auto
    ultimately have "finite {f : extensional_funcset S (T - {x}). inj_on f S}"
      by (auto intro: finite_subset)
  } note finite_delete = this
  from insert have hyps: "\<forall>y \<in> T. card ({g. g \<in> extensional_funcset S (T - {y}) \<and> inj_on g S}) = fact (card T - 1) div fact ((card T - 1) - card S)"(is "\<forall> _ \<in> T. _ = ?k") by auto
  from extensional_funcset_extend_domain_inj_on_eq[OF `x \<notin> S`]
  have "card {f. f : extensional_funcset (insert x S) T & inj_on f (insert x S)} =
    card ((%(y, g). g(x := y)) ` {(y, g). y : T & g : extensional_funcset S (T - {y}) & inj_on g S})"
    by metis
  also from extensional_funcset_extend_domain_inj_onI[OF `x \<notin> S`, of T] have "... =  card {(y, g). y : T & g : extensional_funcset S (T - {y}) & inj_on g S}"
    by (simp add: card_image)
  also have "card {(y, g). y \<in> T \<and> g \<in> extensional_funcset S (T - {y}) \<and> inj_on g S} =
    card {(y, g). y \<in> T \<and> g \<in> {f \<in> extensional_funcset S (T - {y}). inj_on f S}}" by auto
  also from `finite T` finite_delete have "... = (\<Sum>y \<in> T. card {g. g \<in> extensional_funcset S (T - {y}) \<and>  inj_on g S})"
    by (subst card_product_dependent) auto
  also from hyps have "... = (card T) * ?k"
    by auto
  also have "... = card T * fact (card T - 1) div fact (card T - card (insert x S))"
    using insert unfolding div_mult1_eq[of "card T" "fact (card T - 1)"]
    by (simp add: fact_mod)
  also have "... = fact (card T) div fact (card T - card (insert x S))"
    using insert by (simp add: fact_reduce_nat[of "card T"])
  finally show ?case .
qed

lemma card_extensional_funcset_not_inj_on:
  assumes "finite S" "finite T" "card S \<le> card T"
  shows "card {f \<in> extensional_funcset S T. \<not> inj_on f S} = (card T) ^ (card S) - (fact (card T)) div (fact (card T - card S))"
proof -
  have subset: "{f : extensional_funcset S T. inj_on f S} <= extensional_funcset S T" by auto
  from finite_subset[OF subset] assms have finite: "finite {f : extensional_funcset S T. inj_on f S}"
    by (auto intro!: finite_PiE)
  have "{f \<in> extensional_funcset S T. \<not> inj_on f S} = extensional_funcset S T - {f \<in> extensional_funcset S T. inj_on f S}" by auto
  from assms this finite subset show ?thesis
    by (simp add: card_Diff_subset card_PiE card_extensional_funcset_inj_on setprod_constant)
qed

lemma setprod_upto_nat_unfold:
  "setprod f {m..(n::nat)} = (if n < m then 1 else (if n = 0 then f 0 else f n * setprod f {m..(n - 1)}))"
  by auto (auto simp add: gr0_conv_Suc atLeastAtMostSuc_conv)

section {* Birthday paradox *}

lemma birthday_paradox:
  assumes "card S = 23" "card T = 365"
  shows "2 * card {f \<in> extensional_funcset S T. \<not> inj_on f S} \<ge> card (extensional_funcset S T)"
proof -
  from `card S = 23` `card T = 365` have "finite S" "finite T" "card S <= card T" by (auto intro: card_ge_0_finite)
  from assms show ?thesis
    using card_PiE[OF `finite S`, of "\<lambda>i. T"] `finite S`
      card_extensional_funcset_not_inj_on[OF `finite S` `finite T` `card S <= card T`]
    by (simp add: fact_div_fact setprod_upto_nat_unfold setprod_constant)
qed

end


theory Chapter3
imports "HOL-IMP.BExp"
        "HOL-IMP.ASM"
       (* "Short_Theory.thy"*)
begin

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

\exercise
To show that @{const asimp_const} really folds all subexpressions of the form
@{term "Plus (N i) (N j)"}, define a function
\<close>

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N v) = True" |
"optimal (V v) = True" |
"optimal (Plus (N i) (N j)) = False" |
"optimal (Plus i j) = ((optimal i) \<and> (optimal j))"
(* your definition/proof here *)

text\<open>
that checks that its argument does not contain a subexpression of the form
@{term "Plus (N i) (N j)"}. Then prove that the result of @{const asimp_const}
is optimal:
\<close>

lemma "optimal (asimp_const a)"
  by(induction a, auto split: aexp.split)
(* your definition/proof here *)

text\<open>
This proof needs the same @{text "split:"} directive as the correctness proof of
@{const asimp_const}. This increases the chance of nontermination
of the simplifier. Therefore @{const optimal} should be defined purely by
pattern matching on the left-hand side,
without @{text case} expressions on the right-hand side.
\endexercise

\exercise
In this exercise we verify constant folding for @{typ aexp}
where we sum up all constants, even if they are not next to each other.
For example, @{term "Plus (N 1) (Plus (V x) (N 2))"} becomes
@{term "Plus (V x) (N 3)"}. This goes beyond @{const asimp}.
Below we follow a particular solution strategy but there are many others.

First, define a function @{text sumN} that returns the sum of all
constants in an expression and a function @{text zeroN} that replaces all
constants in an expression by zeroes (they will be optimized away later):
\<close>

fun sumN :: "aexp \<Rightarrow> int" where
  "sumN (N n) = n" |
  "sumN (V v) = 0" |
  "sumN (Plus i j) = (sumN i) + (sumN j)"
(* your definition/proof here *)

fun zeroN :: "aexp \<Rightarrow> aexp" where
  "zeroN (N n) = N 0" |
  "zeroN (V v) = V v" |
  "zeroN (Plus i j) = Plus (zeroN i) (zeroN j)"
(* your definition/proof here *)

text\<open>
Next, define a function @{text sepN} that produces an arithmetic expression
that adds the results of @{const sumN} and @{const zeroN}. Prove that
@{text sepN} preserves the value of an expression.
\<close>

definition sepN :: "aexp \<Rightarrow> aexp" where
  "sepN e = Plus (N (sumN e)) (zeroN e)"
(* your definition/proof here *)

lemma aval_sepN: "aval (sepN t) s = aval t s"
  by(induction t, auto simp: sepN_def)
(* your definition/proof here *)

text\<open>
Finally, define a function @{text full_asimp} that uses @{const asimp}
to eliminate the zeroes left over by @{const sepN}.
Prove that it preserves the value of an arithmetic expression.
\<close>

definition full_asimp :: "aexp \<Rightarrow> aexp" where
  "full_asimp e = asimp (sepN e)"
(* your definition/proof here *)

lemma aval_full_asimp: "aval (full_asimp t) s = aval t s"
  by(induction t arbitrary: s, auto simp: aval_sepN full_asimp_def)
(* your definition/proof here *)

text\<open>
\endexercise

\exercise\label{exe:subst}
Substitution is the process of replacing a variable
by an expression in an expression. Define a substitution function
\<close>

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "subst v e (N n) = N n" |
  "subst v e (V n) = (if n = v then e else (V n))" |
  "subst v e (Plus i j) = Plus (subst v e i) (subst v e j)"
(* your definition/proof here *)

text\<open>
such that @{term "subst x a e"} is the result of replacing
every occurrence of variable @{text x} by @{text a} in @{text e}.
For example:
@{lemma[display] "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')" by simp}

Prove the so-called \concept{substitution lemma} that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
\<close>

lemma subst_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
  by(induction e arbitrary: x a s, auto)
(* your definition/proof here *)

text\<open>
As a consequence prove that we can substitute equal expressions by equal expressions
and obtain the same result under evaluation:
\<close>
lemma "aval a1 s = aval a2 s
  \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  by(induction e arbitrary: x s, auto)
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Take a copy of theory @{short_theory "AExp"} and modify it as follows.
Extend type @{typ aexp} with a binary constructor @{text Times} that
represents multiplication. Modify the definition of the functions @{const aval}
and @{const asimp} accordingly. You can remove @{const asimp_const}.
Function @{const asimp} should eliminate 0 and 1 from multiplications
as well as evaluate constant subterms. Update all proofs concerned.
\<close>

text\<open>
\endexercise

\exercise
Define a datatype @{text aexp2} of extended arithmetic expressions that has,
in addition to the constructors of @{typ aexp}, a constructor for
modelling a C-like post-increment operation $x{++}$, where $x$ must be a
variable. Define an evaluation function @{text "aval2 :: aexp2 \<Rightarrow> state \<Rightarrow> val \<times> state"}
that returns both the value of the expression and the new state.
The latter is required because post-increment changes the state.

Extend @{text aexp2} and @{text aval2} with a division operation. Model partiality of
division by changing the return type of @{text aval2} to
@{typ "(val \<times> state) option"}. In case of division by 0 let @{text aval2}
return @{const None}. Division on @{typ int} is the infix @{text div}.
\<close>

text\<open>
\endexercise

\exercise
The following type adds a @{text LET} construct to arithmetic expressions:
\<close>

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

text\<open>The @{const LET} constructor introduces a local variable:
the value of @{term "LET x e\<^sub>1 e\<^sub>2"} is the value of @{text e\<^sub>2}
in the state where @{text x} is bound to the value of @{text e\<^sub>1} in the original state.
Define a function @{const lval} @{text"::"} @{typ "lexp \<Rightarrow> state \<Rightarrow> int"}
that evaluates @{typ lexp} expressions. Remember @{term"s(x := i)"}.

Define a conversion @{const inline} @{text"::"} @{typ "lexp \<Rightarrow> aexp"}.
The expression \mbox{@{term "LET x e\<^sub>1 e\<^sub>2"}} is inlined by substituting
the converted form of @{text e\<^sub>1} for @{text x} in the converted form of @{text e\<^sub>2}.
See Exercise~\ref{exe:subst} for more on substitution.
Prove that @{const inline} is correct w.r.t.\ evaluation.
\endexercise

\exercise
Show that equality and less-or-equal tests on @{text aexp} are definable
\<close>

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text\<open>
and prove that they do what they are supposed to:
\<close>

lemma bval_Le: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
(* your definition/proof here *)

lemma bval_Eq: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Consider an alternative type of boolean expressions featuring a conditional:\<close>

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

text\<open>First define an evaluation function analogously to @{const bval}:\<close>

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open>Then define two translation functions\<close>

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
(* your definition/proof here *)

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text\<open>and prove their correctness:\<close>

lemma "bval (if2bexp exp) s = ifval exp s"
(* your definition/proof here *)

lemma "ifval (b2ifexp exp) s = bval exp s"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
We define a new type of purely boolean expressions without any arithmetic
\<close>

datatype pbexp =
  VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

text\<open>
where variables range over values of type @{typ bool},
as can be seen from the evaluation function:
\<close>

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x"  |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

text\<open>Define a function that checks whether a boolean exression is in NNF
(negation normal form), i.e., if @{const NOT} is only applied directly
to @{const VAR}s:\<close>

fun is_nnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open>
Now define a function that converts a @{text bexp} into NNF by pushing
@{const NOT} inwards as much as possible:
\<close>

fun nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text\<open>
Prove that @{const nnf} does what it is supposed to do:
\<close>

lemma pbval_nnf: "pbval (nnf b) s = pbval b s"
(* your definition/proof here *)

lemma is_nnf_nnf: "is_nnf (nnf b)"
(* your definition/proof here *)

text\<open>
An expression is in DNF (disjunctive normal form) if it is in NNF
and if no @{const OR} occurs below an @{const AND}. Define a corresponding
test:
\<close>

fun is_dnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open>
An NNF can be converted into a DNF in a bottom-up manner.
The critical case is the conversion of @{term (sub) "AND b1 b2"}.
Having converted @{text b\<^sub>1} and @{text b\<^sub>2}, apply distributivity of @{const AND}
over @{const OR}. If we write @{const OR} as a multi-argument function,
we can express the distributivity step as follows:
@{text "dist_AND (OR a\<^sub>1 ... a\<^sub>n) (OR b\<^sub>1 ... b\<^sub>m)"}
= @{text "OR (AND a\<^sub>1 b\<^sub>1) (AND a\<^sub>1 b\<^sub>2) ... (AND a\<^sub>n b\<^sub>m)"}. Define
\<close>

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text\<open>and prove that it behaves as follows:\<close>

lemma pbval_dist: "pbval (dist_AND b1 b2) s = pbval (AND b1 b2) s"
(* your definition/proof here *)

lemma is_dnf_dist: "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf (dist_AND b1 b2)"
(* your definition/proof here *)

text\<open>Use @{const dist_AND} to write a function that converts an NNF
  to a DNF in the above bottom-up manner.
\<close>

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text\<open>Prove the correctness of your function:\<close>

lemma "pbval (dnf_of_nnf b) s = pbval b s"
(* your definition/proof here *)

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise\label{exe:stack-underflow}
A \concept{stack underflow} occurs when executing an @{text ADD}
instruction on a stack of size less than 2. In our semantics
a term @{term "exec1 ADD s stk"} where @{prop "length stk < 2"}
is simply some unspecified value, not an error or exception --- HOL does not have those concepts.
Modify theory @{short_theory "ASM"}
such that stack underflow is modelled by @{const None}
and normal execution by @{text Some}, i.e., the execution functions
have return type @{typ "stack option"}. Modify all theorems and proofs
accordingly.
Hint: you may find @{text"split: option.split"} useful in your proofs.
\<close>

text\<open>
\endexercise

\exercise\label{exe:register-machine}
This exercise is about a register machine
and compiler for @{typ aexp}. The machine instructions are
\<close>
type_synonym reg = nat
datatype instr = LDI val reg | LD vname reg | ADD reg reg

text\<open>
where type @{text reg} is a synonym for @{typ nat}.
Instruction @{term "LDI i r"} loads @{text i} into register @{text r},
@{term "LD x r"} loads the value of @{text x} into register @{text r},
and @{term[names_short] "ADD r\<^sub>1 r\<^sub>2"} adds register @{text r\<^sub>2} to register @{text r\<^sub>1}.

Define the execution of an instruction given a state and a register state;
the result is the new register state:\<close>

type_synonym rstate = "reg \<Rightarrow> val"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(* your definition/proof here *)

text\<open>
Define the execution @{const[source] exec} of a list of instructions as for the stack machine.

The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into @{text r}. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "< r"} should be left alone.
Define the compiler and prove it correct:
\<close>

theorem "exec (comp a r) s rs r = aval a s"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise\label{exe:accumulator}
This exercise is a variation of the previous one
with a different instruction set:
\<close>

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

text\<open>
All instructions refer implicitly to register 0 as a source or target:
@{const LDI0} and @{const LD0} load a value into register 0, @{term "MV0 r"}
copies the value in register 0 into register @{text r}, and @{term "ADD0 r"}
adds the value in register @{text r} to the value in register 0;
@{term "MV0 0"} and @{term "ADD0 0"} are legal. Define the execution functions
\<close>

fun exec01 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
(* your definition/proof here *)

text\<open>
and @{const exec0} for instruction lists.

The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into register 0. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "\<le> r"} should be left alone
(with the exception of 0). Define the compiler and prove it correct:
\<close>

theorem "exec0 (comp0 a r) s rs 0 = aval a s"
(* your definition/proof here *)

text\<open>
\endexercise
\<close>

end


(*<*)
theory ABexpr imports Main begin
(*>*)

text\<open>
\index{datatypes!mutually recursive}%
Sometimes it is necessary to define two datatypes that depend on each
other. This is called \textbf{mutual recursion}. As an example consider a
language of arithmetic and boolean expressions where
\begin{itemize}
\item arithmetic expressions contain boolean expressions because there are
  conditional expressions like ``if $m<n$ then $n-m$ else $m-n$'',
  and
\item boolean expressions contain arithmetic expressions because of
  comparisons like ``$m<n$''.
\end{itemize}
In Isabelle this becomes
\<close>

datatype 'a aexp = IF   "'a bexp" "'a aexp" "'a aexp"
                 | Sum  "'a aexp" "'a aexp"
                 | Diff "'a aexp" "'a aexp"
                 | Var 'a
                 | Num nat
and      'a bexp = Less "'a aexp" "'a aexp"
                 | And  "'a bexp" "'a bexp"
                 | Neg  "'a bexp"

text\<open>\noindent
Type \<open>aexp\<close> is similar to \<open>expr\<close> in \S\ref{sec:ExprCompiler},
except that we have added an \<open>IF\<close> constructor,
fixed the values to be of type \<^typ>\<open>nat\<close> and declared the two binary
operations \<open>Sum\<close> and \<^term>\<open>Diff\<close>.  Boolean
expressions can be arithmetic comparisons, conjunctions and negations.
The semantics is given by two evaluation functions:
\<close>

primrec evala :: "'a aexp \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> nat" and
         evalb :: "'a bexp \<Rightarrow> ('a \<Rightarrow> nat) \<Rightarrow> bool" where
"evala (IF b a1 a2) env =
   (if evalb b env then evala a1 env else evala a2 env)" |
"evala (Sum a1 a2) env = evala a1 env + evala a2 env" |
"evala (Diff a1 a2) env = evala a1 env - evala a2 env" |
"evala (Var v) env = env v" |
"evala (Num n) env = n" |

"evalb (Less a1 a2) env = (evala a1 env < evala a2 env)" |
"evalb (And b1 b2) env = (evalb b1 env \<and> evalb b2 env)" |
"evalb (Neg b) env = (\<not> evalb b env)"

text\<open>\noindent

Both take an expression and an environment (a mapping from variables
\<^typ>\<open>'a\<close> to values \<^typ>\<open>nat\<close>) and return its arithmetic/boolean
value. Since the datatypes are mutually recursive, so are functions
that operate on them. Hence they need to be defined in a single
\isacommand{primrec} section. Notice the \isakeyword{and} separating
the declarations of \<^const>\<open>evala\<close> and \<^const>\<open>evalb\<close>. Their defining
equations need not be split into two groups;
the empty line is purely for readability.

In the same fashion we also define two functions that perform substitution:
\<close>

primrec substa :: "('a \<Rightarrow> 'b aexp) \<Rightarrow> 'a aexp \<Rightarrow> 'b aexp" and
         substb :: "('a \<Rightarrow> 'b aexp) \<Rightarrow> 'a bexp \<Rightarrow> 'b bexp" where
"substa s (IF b a1 a2) =
   IF (substb s b) (substa s a1) (substa s a2)" |
"substa s (Sum a1 a2) = Sum (substa s a1) (substa s a2)" |
"substa s (Diff a1 a2) = Diff (substa s a1) (substa s a2)" |
"substa s (Var v) = s v" |
"substa s (Num n) = Num n" |

"substb s (Less a1 a2) = Less (substa s a1) (substa s a2)" |
"substb s (And b1 b2) = And (substb s b1) (substb s b2)" |
"substb s (Neg b) = Neg (substb s b)"

text\<open>\noindent
Their first argument is a function mapping variables to expressions, the
substitution. It is applied to all variables in the second argument. As a
result, the type of variables in the expression may change from \<^typ>\<open>'a\<close>
to \<^typ>\<open>'b\<close>. Note that there are only arithmetic and no boolean variables.

Now we can prove a fundamental theorem about the interaction between
evaluation and substitution: applying a substitution $s$ to an expression $a$
and evaluating the result in an environment $env$ yields the same result as
evaluation $a$ in the environment that maps every variable $x$ to the value
of $s(x)$ under $env$. If you try to prove this separately for arithmetic or
boolean expressions (by induction), you find that you always need the other
theorem in the induction step. Therefore you need to state and prove both
theorems simultaneously:
\<close>

lemma "evala (substa s a) env = evala a (\<lambda>x. evala (s x) env) \<and>
        evalb (substb s b) env = evalb b (\<lambda>x. evala (s x) env)"
apply(induct_tac a and b)

txt\<open>\noindent The resulting 8 goals (one for each constructor) are proved in one fell swoop:
\<close>

apply simp_all
(*<*)done(*>*)

text\<open>
In general, given $n$ mutually recursive datatypes $\tau@1$, \dots, $\tau@n$,
an inductive proof expects a goal of the form
\[ P@1(x@1)\ \land \dots \land P@n(x@n) \]
where each variable $x@i$ is of type $\tau@i$. Induction is started by
\begin{isabelle}
\isacommand{apply}\<open>(induct_tac\<close> $x@1$ \isacommand{and} \dots\ \isacommand{and} $x@n$\<open>)\<close>
\end{isabelle}

\begin{exercise}
  Define a function \<open>norma\<close> of type \<^typ>\<open>'a aexp => 'a aexp\<close> that
  replaces \<^term>\<open>IF\<close>s with complex boolean conditions by nested
  \<^term>\<open>IF\<close>s; it should eliminate the constructors
  \<^term>\<open>And\<close> and \<^term>\<open>Neg\<close>, leaving only \<^term>\<open>Less\<close>.
  Prove that \<open>norma\<close>
  preserves the value of an expression and that the result of \<open>norma\<close>
  is really normal, i.e.\ no more \<^term>\<open>And\<close>s and \<^term>\<open>Neg\<close>s occur in
  it.  ({\em Hint:} proceed as in \S\ref{sec:boolex} and read the discussion
  of type annotations following lemma \<open>subst_id\<close> below).
\end{exercise}
\<close>
(*<*)
primrec norma :: "'a aexp \<Rightarrow> 'a aexp" and
        normb :: "'a bexp \<Rightarrow> 'a aexp \<Rightarrow> 'a aexp \<Rightarrow> 'a aexp" where
"norma (IF b t e)   = (normb b (norma t) (norma e))" |
"norma (Sum a1 a2)  = Sum (norma a1) (norma a2)" |
"norma (Diff a1 a2) = Diff (norma a1) (norma a2)" |
"norma (Var v)      = Var v" |
"norma (Num n)      = Num n" |

"normb (Less a1 a2) t e = IF (Less (norma a1) (norma a2)) t e" |
"normb (And b1 b2)  t e = normb b1 (normb b2 t e) e" |
"normb (Neg b)      t e = normb b e t"

lemma " evala (norma a) env = evala a env
      \<and> (\<forall> t e. evala (normb b t e) env = evala (IF b t e) env)"
apply (induct_tac a and b)
apply (simp_all)
done

primrec normala :: "'a aexp \<Rightarrow> bool" and
        normalb :: "'a bexp \<Rightarrow> bool" where
"normala (IF b t e)   = (normalb b \<and> normala t \<and> normala e)" |
"normala (Sum a1 a2)  = (normala a1 \<and> normala a2)" |
"normala (Diff a1 a2) = (normala a1 \<and> normala a2)" |
"normala (Var v)      = True" |
"normala (Num n)      = True" |

"normalb (Less a1 a2) = (normala a1 \<and> normala a2)" |
"normalb (And b1 b2)  = False" |
"normalb (Neg b)      = False"

lemma "normala (norma (a::'a aexp)) \<and>
       (\<forall> (t::'a aexp) e. (normala t \<and> normala e) \<longrightarrow> normala (normb b t e))"
apply (induct_tac a and b)
apply (auto)
done

end
(*>*)


theory NoDups imports Main
begin

(*
  Predicates capturing sorted and no-duplicates
  Isabelle/HOL has two ways of expressing logical statements,
  an "outer" language using \<And> quantifiers and \<Longrightarrow> implication,
  and an "inner" language using \<forall> and \<longrightarrow>
  Here I define sortedness and uniqueness predicates in the inner language,
  and then define some rules for reasoning about them at the outer-language level
  (which is convenient for structured proofs).
  I think there is a more automated way to do this conversion.
*)
definition nodups :: "int list \<Rightarrow> bool" where
"nodups l = (\<forall> x y .
  0 \<le> x \<longrightarrow> 0 \<le> y \<longrightarrow>
  x < length l \<longrightarrow> y < length l \<longrightarrow>
  List.nth l x = List.nth l y \<longrightarrow> x = y)"

lemma nodups_intro :
"(\<And> x y .
  0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow>
  x < length l \<Longrightarrow> y < length l \<Longrightarrow>
  List.nth l x = List.nth l y \<Longrightarrow> x = y) \<Longrightarrow> nodups l"
  unfolding nodups_def by auto

lemma nodups_elim :
  "nodups l \<Longrightarrow>
  0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow>
  x < length l \<Longrightarrow> y < length l \<Longrightarrow>
  List.nth l x = List.nth l y \<Longrightarrow> x = y"
  unfolding nodups_def by auto

definition sorted :: "int list \<Rightarrow> bool" where
"sorted l = (\<forall> x y  .
  0 \<le> x \<longrightarrow> x < y \<longrightarrow>
  y < length l \<longrightarrow>
  List.nth l x \<le> List.nth l y)"

lemma sorted_intro :
"(\<And> x y  .
  0 \<le> x \<Longrightarrow> x < y \<Longrightarrow>
  y < length l \<Longrightarrow>
  List.nth l x \<le> List.nth l y) \<Longrightarrow> sorted l"
  unfolding sorted_def by auto

lemma sorted_elim :
"sorted l \<Longrightarrow>
  0 \<le> x \<Longrightarrow> x < y \<Longrightarrow>
  y < length l \<Longrightarrow>
  List.nth l x \<le> List.nth l y"
  unfolding sorted_def by auto

fun removeDups :: "int list \<Rightarrow> int list" where
"removeDups [] = []"
| "removeDups [x] = [x]"
| "removeDups (h1#h2#t) =
   (if h1 = h2 then removeDups (h1 # t)
    else h1 # removeDups (h2 # t))"

(* sortedness-related lemmas
   NB the standard library contains an implementation of sorted with an associated library
   of lemmas, but I chose not to use them for the purposes of the exercise.*)
lemma sorted_tl :
  assumes H : "sorted (h#l)"
  shows "sorted l"
proof(cases l)
  case Nil
  then show ?thesis by(auto simp add:sorted_def)
next
  case (Cons a list)
  show ?thesis
  proof(rule sorted_intro)
    fix x :: nat
    fix y :: nat
    assume H1 : "0 \<le> x"
    assume H2 : "x < y"
    assume H3 : "y < length l"
    show "l ! x \<le> l ! y"
      using sorted_elim[OF H,of "1 + x" "1 + y"] H2 H3 by auto
  qed
qed

lemma sorted_tl2 :
  assumes H : "sorted (h1 # h2 #l)"
  shows "sorted (h1 # l)"
proof(cases l)
  case Nil
  then show ?thesis by(auto simp add:sorted_def)
next
  case (Cons a list)
  show ?thesis
  proof(rule sorted_intro)
    fix x :: nat
    fix y :: nat
    assume H1 : "0 \<le> x"
    assume H2 : "x < y"
    assume H3 : "y < length (h1 # l)"

    have "h1 \<le> h2" using sorted_elim[OF H,of 0 1] by auto

    show "(h1 # l) ! x \<le> (h1 # l) ! y"
    proof(cases x)
      case 0
      then show ?thesis
      proof(cases y)
        assume Z' : "y = 0"
        thus ?thesis using 0 by auto
      next
        fix y'
        assume Suc' : "y = Suc y'"
        then show ?thesis using sorted_elim[OF H, of 0 "1 + y"] 0 H3 by(auto)
      qed
    next
      case (Suc nat)
      then show ?thesis
      proof(cases y)
        assume Z' : "y = 0"
        thus ?thesis using Suc H2 by auto
      next
        fix y'
        assume Suc' : "y = Suc y'"
        then show ?thesis using sorted_elim[OF H, of "1 + x" "1 + y"] Suc H2 H3 by(auto)
      qed
    qed
  qed
qed

(* removeDups related lemmas*)
lemma removeDups_len :
  "1 \<le> length (removeDups (h#l))"
proof(induction l arbitrary: h)
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then show ?case
    by(auto)
qed

lemma removeDups_hd :
  "\<exists> l' . removeDups(h#l) = (h#l')"
proof(induction l arbitrary: h)
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then show ?case by(auto)
qed

(* sorted list remains sorted after removing duplicates*)
lemma removeDups_sort :
shows "sorted (h # l) \<Longrightarrow> sorted (removeDups (h # l))"
proof(induction l arbitrary: h)
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then show ?case
  proof(cases "h = a")
    case True

    have "sorted (a # l)" using sorted_tl[OF Cons(2)] by auto
    then show ?thesis
      using Cons True by(auto)
  next
    case False

    have St1 : "sorted (h # l)" using sorted_tl2[OF Cons(2)] by auto
    have St2 : "sorted (removeDups (h#l))"
      using Cons.IH[OF St1] by auto

    have St3 : "sorted (a # l)" using sorted_tl[OF Cons(2)] by auto
    have St4 : "sorted (removeDups (a#l))"
      using Cons.IH[OF St3] by auto

    show ?thesis
    proof(rule sorted_intro)
      fix x :: nat
      fix y :: nat
      assume H1 : "0 \<le> x"
      assume H2 : "x < y"
      assume H3 : "y < length (removeDups (h # a # l))"

      show "removeDups (h # a # l) ! x \<le> removeDups (h # a # l) ! y"
      proof(cases x)
        case 0
        then show ?thesis
        proof(cases y)
          assume Z' : "y = 0"
          then show ?thesis using 0 H2 by auto
        next
          fix y'
          assume Suc' : "y = Suc y'"

          have H_lt_a : "h \<le> a" using sorted_elim[OF Cons(2), of 0 1] by(auto)

          show ?thesis
          proof(cases y')
            assume Z'' : "y' = 0"

            have "a = removeDups (a # l) ! 0"
              using removeDups_hd[of a l] by auto

            thus ?thesis using 0 Z'' Suc' False H_lt_a by(auto)
          next
            fix y''
            assume Suc'' : "y' = Suc y''"

            have "a \<le> removeDups (a # l) ! Suc y''"
              using sorted_elim[OF St4, of 0 "Suc y''"]
                    removeDups_hd[of a l]
                    removeDups_len[of h "(a # l)"] Suc' Suc'' H3 False
              by(auto)
            then show ?thesis using 0 Suc'' Suc' False St4 H_lt_a
              by(auto)
          qed
        qed
      next
        case (Suc x')
        then show ?thesis
        proof(cases y)
          assume Z' : "y = 0"
          then show ?thesis using Suc H2 by auto
        next
          fix y'
          assume Suc' : "y = Suc y'"
          show ?thesis
            using sorted_elim[OF St4, of x' y'] Suc Suc' H2 H3 False
            by(auto)
        qed
      qed
    qed
  qed
qed

(* Main result: running RemoveDups results in a list with no duplicates *)
lemma removeDups_nodups' :
  shows "sorted (h # l) \<Longrightarrow> nodups (removeDups (h # l))"
proof(induction l arbitrary: h)
case Nil
  then show ?case apply(auto simp add:sorted_def nodups_def) done
next
  case (Cons a l)
  have Sort1 : "sorted (a # l)" using sorted_tl[OF Cons(2)] by auto

  have Sort2 : "sorted (h # l)" using sorted_tl2[OF Cons(2)] by auto

  have Leq : "h \<le> a" using sorted_elim[OF Cons(2), of 0 1] by auto

  show ?case
  proof(cases "h = a")
    case True
    then show ?thesis using Cons.IH[OF Sort1] by auto
  next
    case False
    show ?thesis
    proof(rule nodups_intro)
      fix x :: nat
      fix y :: nat
      assume Hx : "0 \<le> x"
      assume Hy : "0 \<le> y"
      assume Xlen : "x < length (removeDups (h # a # l))"
      assume Ylen : "y < length (removeDups (h # a # l))"
      assume El_eq : "removeDups (h # a # l) ! x = removeDups (h # a # l) ! y"
      show "x = y"
      proof(cases x)
        case 0
        then show ?thesis
        proof(cases y)
          assume Z' : "y = 0"
          show "x = y" using 0 Z' by auto
        next
          fix y'
          assume Suc' : "y = Suc y'"
          then have False
          proof(cases "h = a")
            case True
            then show ?thesis using El_eq
                 nodups_elim[OF Cons.IH[OF Sort1], of 0 y] 0 Suc' Xlen Ylen by(auto)
          next
            case False
            then show ?thesis
            proof(cases y')
              assume Z'' : "y' = 0"
              obtain l' where L' : "removeDups(a#l) = (a#l')"
                using removeDups_hd by auto
              then show ?thesis using El_eq 0 Cons Suc' False Z'' by(auto)
            next
              fix y''
              assume Suc'' : "y' = Suc y''"

              have St : "sorted (removeDups (a#l))"
                    using removeDups_sort[OF Sort1] by auto

              have Leq' : "a \<le> removeDups (a # l) ! Suc y''" using
                  sorted_elim[OF St, of 0 "Suc y''"]
                  removeDups_hd[of a l]
              Xlen Ylen Suc' Suc'' False
              by(auto)

            have St' : "sorted (removeDups (a # l) ! y' # a # l)"
              using El_eq 0 Cons Suc' False by(auto)
            show ?thesis using sorted_elim[OF St', of 0, of 1]
                El_eq 0 Cons Suc' False Leq' Suc''
              by(auto)
            qed
          qed
          thus ?thesis by auto
        qed
      next
        case (Suc x')
        then show ?thesis
        proof(cases y)
          assume Z' : "y = 0"
          then have False
          proof(cases "h = a")
            case True
            then show ?thesis using El_eq
                 nodups_elim[OF Cons.IH[OF Sort1], of 0 x] Suc Z' Xlen Ylen by(auto)
          next
            case False
            then show ?thesis
            proof(cases x')
              assume Z'' : "x' = 0"
              obtain l' where L' : "removeDups(a#l) = (a#l')"
                using removeDups_hd by auto
              then show ?thesis using El_eq Suc Cons Z' False Z'' by(auto)
            next
              fix x''
              assume Suc'' : "x' = Suc x''"
              have St : "sorted (removeDups (a#l))"
                    using removeDups_sort[OF Sort1] by auto

              have Leq' : "a \<le> removeDups (a # l) ! Suc x''" using
                  sorted_elim[OF St, of 0 "Suc x''"]
                  removeDups_hd[of a l]
                  removeDups_len[of a l]
              Xlen Ylen Suc Suc'' Z' False
                by(auto)
              have St' : "sorted (removeDups (a # l) ! Suc x'' # a # l)"
                using El_eq Suc Z' Cons Suc'' False by(auto)
              show ?thesis using sorted_elim[OF St', of 0, of 1]
                  El_eq Suc Z' Cons False Leq' Suc''
                by(auto)
              qed
            qed
            thus ?thesis by auto
        next
          fix y'
          assume Suc' : "y = Suc y'"
          thus ?thesis using El_eq  Suc
            nodups_elim[OF Cons.IH[OF Sort1]] Xlen Ylen
            by(auto split:if_splits)
        qed
      qed
    qed
  qed
qed

(* general version of the theorem (holds for nil lists too) *)
theorem removeDups_nodups :
  assumes H : "sorted l"
  shows "nodups (removeDups (l))"
proof(cases l)
case Nil
  then show ?thesis by (auto simp add:nodups_def)
next
  case (Cons a list)
  then show ?thesis using removeDups_nodups' H by auto
qed

end


section \<open>Efficient code for testing Mersenne primes\<close>
theory Lucas_Lehmer_Code
imports
  Lucas_Lehmer
  "HOL-Library.Code_Target_Numeral"
  "Native_Word.Code_Target_Bits_Int"
begin

subsection \<open>Efficient computation of remainders modulo a Mersenne number\<close>

text \<open>
  We have $k = k\ \text{mod}\ 2^n + k\ \text{div}\ 2^n\ \ (\text{mod}\ (2^n - 1))$,
  and $k\ \text{mod}\ 2^n = k\, \&\, (2^n - 1)$ and $k\ \text{div}\ 2^n = k \gg n$.
  Therefore, we can reduce $k$ modulo $2^n - 1$ using only bitwise operations, addition, and
  bit shifts.
\<close>
lemma cong_mersenne_number_int:
  fixes k :: int
  shows "[k mod 2 ^ n + k div 2 ^ n = k] (mod (2 ^ n - 1))"
proof -
  have "k = (2 ^ n - 1 + 1) * (k div 2 ^ n) + (k mod 2 ^ n)"
    by simp
  also have "[\<dots> = (0 + 1) * (k div 2 ^ n) + (k mod 2 ^ n)] (mod (2 ^ n - 1))"
    by (intro cong_add cong_mult cong_refl) (auto simp: cong_def)
  finally show ?thesis by (simp add: cong_sym add_ac)
qed

text \<open>
  We encapsulate a single reduction step in the following operation. Note, however,
  that the result is not, in general, the same as $k\ \text{mod}\ (2^n - 1)$. Multiple
  reductions might be required in order to reduce it below $2^n$, and a multiple of $2 ^ n - 1$
  can be reduced to $2 ^ n - 1$, which is invariant to further reduction steps.
\<close>
definition mersenne_mod :: "int \<Rightarrow> nat \<Rightarrow> int" where
  "mersenne_mod k n = k mod 2 ^ n + k div 2 ^ n"

lemma mersenne_mod_code [code]:
  "mersenne_mod k n = (k AND ((1 << n) - 1)) + (k >> n)"
  by (simp add: mersenne_mod_def shiftr_int_def shiftl_int_def AND_mod)

lemma cong_mersenne_mod: "[mersenne_mod k n = k] (mod (2 ^ n - 1))"
  unfolding mersenne_mod_def by (rule cong_mersenne_number_int)

lemma mersenne_mod_nonneg [simp]: "k \<ge> 0 \<Longrightarrow> mersenne_mod k n \<ge> 0"
  unfolding mersenne_mod_def by (intro add_nonneg_nonneg) (simp_all add: pos_imp_zdiv_nonneg_iff)

lemma mersenne_mod_less:
  assumes "k \<le> 2 ^ m" "m \<ge> n"
  shows   "mersenne_mod k n < 2 ^ n + 2 ^ (m - n)"
proof -
  have "mersenne_mod k n = k mod 2 ^ n + k div 2 ^ n"
    by (simp add: mersenne_mod_def)
  also have "k mod 2 ^ n < 2 ^ n"
    by simp
  also {
    have "k div 2 ^ n * 2 ^ n + 0 \<le> k div 2 ^ n * 2 ^ n + k mod (2 ^ n)"
      by (intro add_mono) auto
    also have "\<dots> = k"
      by (subst mult.commute) auto
    also have "\<dots> \<le> 2 ^ m"
      using assms by simp
    also have "\<dots> = 2 ^ (m - n) * 2 ^ n"
      using assms by (simp flip: power_add)
    finally have "k div 2 ^ n \<le> 2 ^ (m - n)"
      by simp
  }
  finally show ?thesis by simp
qed

lemma mersenne_mod_less':
  assumes "k \<le> 5 * 2 ^ n"
  shows   "mersenne_mod k n < 2 ^ n + 5"
proof -
  have "mersenne_mod k n = k mod 2 ^ n + k div 2 ^ n"
    by (simp add: mersenne_mod_def)
  also have "k mod 2 ^ n < 2 ^ n"
    by simp
  also {
    have "k div 2 ^ n * 2 ^ n + 0 \<le> k div 2 ^ n * 2 ^ n + k mod (2 ^ n)"
      by (intro add_mono) auto
    also have "\<dots> = k"
      by (subst mult.commute) auto
    also have "\<dots> \<le> 5 * 2 ^ n"
      using assms by simp
    finally have "k div 2 ^ n \<le> 5"
      by simp
  }
  finally show ?thesis by simp
qed

text \<open>
  It turns out that for our use case, a single reduction is not enough to reduce
  the number in question enough (or at least I was unable to prove that it is). We
  therefore perform two reduction steps, which is enough to guarantee that our numbers
  are below $2^n + 4$ before and after every step in the Lucas--Lehmer sequence.

  Whether one or two reductions are performed is not very important anyway, since the
  dominant step is the squaring anyway.
\<close>
definition mersenne_mod2 :: "int \<Rightarrow> nat \<Rightarrow> int" where
  "mersenne_mod2 k n = mersenne_mod (mersenne_mod k n) n"

lemma cong_mersenne_mod2: "[mersenne_mod2 k n = k] (mod (2 ^ n - 1))"
  unfolding mersenne_mod2_def by (rule cong_trans) (rule cong_mersenne_mod)+

lemma mersenne_mod2_nonneg [simp]: "k \<ge> 0 \<Longrightarrow> mersenne_mod2 k n \<ge> 0"
  unfolding mersenne_mod2_def by simp

lemma mersenne_mod2_less:
  assumes "n > 2" and "k \<le> 2 ^ (2 * n + 2)"
  shows   "mersenne_mod2 k n < 2 ^ n + 5"
proof -
  from assms have "2 ^ 3 \<le> (2 ^ n :: int)"
    by (intro power_increasing) auto
  hence "2 ^ n \<ge> (8 :: int)" by simp
  have "mersenne_mod k n < 2 ^ n + 2 ^ (2 * n + 2 - n)"
    by (rule mersenne_mod_less) (use assms in auto)
  also have "\<dots> \<le> 5 * 2 ^ n"
    by (simp add: power_add)
  finally have "mersenne_mod (mersenne_mod k n) n < 2 ^ n + 5"
    by (intro mersenne_mod_less') auto
  thus ?thesis by (simp add: mersenne_mod2_def)
qed

text \<open>
  Since we subtract 2 at one point, the intermediate results can become negative. This
  is not a problem since our reduction modulo $2 ^ p - 1$ happens to make them positive again
  immediately.
\<close>
lemma mersenne_mod_nonneg_strong:
  assumes "a > -(2 ^ p) + 1"
  shows   "mersenne_mod a p \<ge> 0"
proof (cases "a < 0")
  case True
  have "eucl_rel_int a (2 ^ p) (- 1, a + 2 ^ p)"
    using assms True by (auto simp: eucl_rel_int_iff)
  hence "a div 2 ^ p = -1" and "a mod 2 ^ p = a + 2 ^ p"
    by (simp_all add: div_int_unique mod_int_unique)
  hence "mersenne_mod a p = a + 2 ^ p - 1"
    by (simp add: mersenne_mod_def)
  also have "\<dots> > 0" using assms by simp
  finally show ?thesis by simp
qed auto

lemma mersenne_mod2_nonneg_strong:
  assumes "a > -(2 ^ p) + 1"
  shows   "mersenne_mod2 a p \<ge> 0"
  unfolding mersenne_mod2_def
  by (rule mersenne_mod_nonneg, rule mersenne_mod_nonneg_strong) (use assms in auto)

subsection \<open>Efficient code for the Lucas--Lehmer sequence\<close>

primrec gen_lucas_lehmer_sequence'' :: "nat \<Rightarrow> int \<Rightarrow> nat \<Rightarrow> int" where
  "gen_lucas_lehmer_sequence'' p a 0 = a"
| "gen_lucas_lehmer_sequence'' p a (Suc n) =
     gen_lucas_lehmer_sequence'' p (mersenne_mod2 (a ^ 2 - 2) p) n"

lemma gen_lucas_lehmer_sequence''_correct:
  assumes "[a = a'] (mod (2 ^ p - 1))"
  shows   "[gen_lucas_lehmer_sequence'' p a n = gen_lucas_lehmer_sequence a' n] (mod (2 ^ p - 1))"
  using assms
proof (induction n arbitrary: a a')
  case (Suc n)
  have "[mersenne_mod2 (a ^ 2 - 2) p = a ^ 2 - 2] (mod (2 ^ p - 1))"
    by (rule cong_mersenne_mod2)
  also have "[a ^ 2 - 2 = a' ^ 2 - 2] (mod (2 ^ p - 1))"
    by (intro cong_pow cong_diff Suc.prems cong_refl)
  finally have "[gen_lucas_lehmer_sequence'' p (mersenne_mod2 (a\<^sup>2 - 2) p) n =
                 gen_lucas_lehmer_sequence (a'\<^sup>2 - 2) n] (mod 2 ^ p - 1)"
    by (rule Suc.IH)
  thus ?case
    by (auto simp del: gen_lucas_lehmer_sequence.simps simp: gen_lucas_lehmer_sequence_Suc')
qed auto

lemma gen_lucas_lehmer_sequence''_bounds:
  assumes "a \<ge> 0" "a < 2 ^ p + 5" "p > 2"
  shows   "gen_lucas_lehmer_sequence'' p a n \<in> {0..<2 ^ p + 5}"
  using assms
proof (induction n arbitrary: a)
  case (Suc n)
  from Suc.prems have "a ^ 2 < (2 ^ p + 5) ^ 2"
    by (intro power_strict_mono Suc.prems) auto
  also have "\<dots> \<le> (2 ^ (p + 1)) ^ 2"
    using power_increasing[of 3 p "2 :: int"] \<open>p > 2\<close> by (intro power_mono) auto
  finally have "a ^ 2 - 2 < 2 ^ (2 * p + 2)"
    by (simp flip: power_mult mult_ac)
  moreover {
    from \<open>p > 2\<close> have "(2 ^ p) \<ge> (2 ^ 3 :: int)"
      by (intro power_increasing) auto
    hence "-(2 ^ p) + 1 < (-2 :: int)"
      by simp
    also have "-2 \<le> a ^ 2 - 2"
      by simp
    finally have "mersenne_mod2 (a ^ 2 - 2) p \<ge> 0"
      by (rule mersenne_mod2_nonneg_strong)
  }
  ultimately have "gen_lucas_lehmer_sequence'' p (mersenne_mod2 (a\<^sup>2 - 2) p) n \<in> {0..<2 ^ p + 5}"
    using \<open>p > 2\<close> by (intro Suc.IH mersenne_mod2_less) auto
  thus ?case by simp
qed auto

subsection \<open>Code for the Lucas--Lehmer test\<close>

lemmas [code del] = lucas_lehmer_test_code_arithmetic

lemma lucas_lehmer_test_code [code]:
  "lucas_lehmer_test p =
     (2 < p \<and> (let x = gen_lucas_lehmer_sequence'' p 4 (p - 2) in x = 0 \<or> x = (1 << p) - 1))"
  unfolding lucas_lehmer_test_def
proof (rule conj_cong)
  assume "p > 2"
  define x where "x = gen_lucas_lehmer_sequence'' p 4 (p - 2)"
  from \<open>p > 2\<close> have "2 ^ 3 \<le> (2 ^ p :: int)" by (intro power_increasing) auto
  hence "2 ^ p \<ge> (8 :: int)" by simp
  hence bounds: "x \<in> {0..<2 ^ p + 5}"
    unfolding x_def using \<open>p > 2\<close> by (intro gen_lucas_lehmer_sequence''_bounds) auto
  have "2 ^ p - 1 dvd gen_lucas_lehmer_sequence 4 (p - 2) \<longleftrightarrow> 2 ^ p - 1 dvd x"
    unfolding x_def by (intro cong_dvd_iff cong_sym[OF gen_lucas_lehmer_sequence''_correct]) auto
  also have "\<dots> \<longleftrightarrow> x \<in> {0, 2 ^ p - 1}"
  proof
    assume "2 ^ p - 1 dvd x"
    then obtain k where k: "x = (2 ^ p - 1) * k" by auto
    have "k \<ge> 0" using bounds \<open>2 ^ p \<ge> 8\<close>
      by (auto simp: k zero_le_mult_iff)
    moreover {
      have "x < 2 ^ p + 5" using bounds by simp
      also have "\<dots> \<le> (2 ^ p - 1) * 2"
        using \<open>2 ^ p \<ge> 8\<close> by simp
      finally have "(2 ^ p - 1) * k < (2 ^ p - 1) * 2"
        unfolding k .
      hence "k < 2"
        by (subst (asm) mult_less_cancel_left) auto
    }
    ultimately have "k = 0 \<or> k = 1" by auto
    thus "x \<in> {0, 2 ^ p - 1}"
      using k by auto
  qed auto
  finally show "(2 ^ p - 1 dvd gen_lucas_lehmer_sequence 4 (p - 2)) =
                ((let x = x in x = 0 \<or> x = (1 << p) - 1))"
    by (simp add: shiftl_int_def Let_def)
qed auto

subsection \<open>Examples\<close>

text \<open>
  Note that for some reason, the clever bit-arithmetic version of the Lucas--Lehmer test is
  actually much slower than the one using integer arithmetic when using PolyML, and even more so
  when using the built-in evaluator in Isabelle (which also uses PolyML with a slightly different
  setup).

  I do not quite know why this is the case, but it is likely because of inefficient implementations
  of bit arithmetic operations in PolyML and/or the code generator setup for it.

  When running with GHC, the bit-arithmetic version is \<^emph>\<open>much\<close> faster.
\<close>

value "filter mersenne_prime [0..<100]"

lemma "prime (2 ^ 521 - 1 :: nat)"
  by (subst lucas_lehmer_correct') eval

lemma "prime (2 ^ 4253 - 1 :: nat)"
  by (subst lucas_lehmer_correct') eval

end


(*
  Title:    Random_Permutations.thy
  Author:   Manuel Eberl, TU München

  Random permutations and folding over them.
  This provides the basic theory for the concept of doing something
  in a random order, e.g. inserting elements from a fixed set into a
  data structure in random order.
*)

section \<open>Random Permutations\<close>

theory Random_Permutations
imports
  Probability_Mass_Function
  "HOL-Library.Multiset_Permutations"
begin

text \<open>
  Choosing a set permutation (i.e. a distinct list with the same elements as the set)
  uniformly at random is the same as first choosing the first element of the list
  and then choosing the rest of the list as a permutation of the remaining set.
\<close>
lemma random_permutation_of_set:
  assumes "finite A" "A \<noteq> {}"
  shows   "pmf_of_set (permutations_of_set A) =
             do {
               x \<leftarrow> pmf_of_set A;
               xs \<leftarrow> pmf_of_set (permutations_of_set (A - {x}));
               return_pmf (x#xs)
             }" (is "?lhs = ?rhs")
proof -
  from assms have "permutations_of_set A = (\<Union>x\<in>A. (#) x ` permutations_of_set (A - {x}))"
    by (simp add: permutations_of_set_nonempty)
  also from assms have "pmf_of_set \<dots> = ?rhs"
    by (subst pmf_of_set_UN[where n = "fact (card A - 1)"])
       (auto simp: card_image disjoint_family_on_def map_pmf_def [symmetric] map_pmf_of_set_inj)
  finally show ?thesis .
qed

text \<open>
  A generic fold function that takes a function, an initial state, and a set
  and chooses a random order in which it then traverses the set in the same
  fashion as a left fold over a list.
    We first give a recursive definition.
\<close>
function fold_random_permutation :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b pmf" where
  "fold_random_permutation f x {} = return_pmf x"
| "\<not>finite A \<Longrightarrow> fold_random_permutation f x A = return_pmf x"
| "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow>
     fold_random_permutation f x A =
       pmf_of_set A \<bind> (\<lambda>a. fold_random_permutation f (f a x) (A - {a}))"
  by simp_all fastforce
termination proof (relation "Wellfounded.measure (\<lambda>(_,_,A). card A)")
  fix A :: "'a set" and f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and x :: 'b and y :: 'a
  assume A: "finite A" "A \<noteq> {}" "y \<in> set_pmf (pmf_of_set A)"
  then have "card A > 0" by (simp add: card_gt_0_iff)
  with A show "((f, f y x, A - {y}), f, x, A) \<in> Wellfounded.measure (\<lambda>(_, _, A). card A)"
    by simp
qed simp_all

text \<open>
  We can now show that the above recursive definition is equivalent to
  choosing a random set permutation and folding over it (in any direction).
\<close>
lemma fold_random_permutation_foldl:
  assumes "finite A"
  shows   "fold_random_permutation f x A =
             map_pmf (foldl (\<lambda>x y. f y x) x) (pmf_of_set (permutations_of_set A))"
using assms
proof (induction f x A rule: fold_random_permutation.induct [case_names empty infinite remove])
  case (remove A f x)
  from remove
    have "fold_random_permutation f x A =
            pmf_of_set A \<bind> (\<lambda>a. fold_random_permutation f (f a x) (A - {a}))" by simp
  also from remove
    have "\<dots> = pmf_of_set A \<bind> (\<lambda>a. map_pmf (foldl (\<lambda>x y. f y x) x)
                 (map_pmf ((#) a) (pmf_of_set (permutations_of_set (A - {a})))))"
      by (intro bind_pmf_cong) (simp_all add: pmf.map_comp o_def)
  also from remove have "\<dots> = map_pmf (foldl (\<lambda>x y. f y x) x) (pmf_of_set (permutations_of_set A))"
    by (simp_all add: random_permutation_of_set map_bind_pmf map_pmf_def [symmetric])
  finally show ?case .
qed (simp_all add: pmf_of_set_singleton)

lemma fold_random_permutation_foldr:
  assumes "finite A"
  shows   "fold_random_permutation f x A =
             map_pmf (\<lambda>xs. foldr f xs x) (pmf_of_set (permutations_of_set A))"
proof -
  have "fold_random_permutation f x A =
          map_pmf (foldl (\<lambda>x y. f y x) x \<circ> rev) (pmf_of_set (permutations_of_set A))"
    using assms by (subst fold_random_permutation_foldl [OF assms])
                   (simp_all add: pmf.map_comp [symmetric] map_pmf_of_set_inj)
  also have "foldl (\<lambda>x y. f y x) x \<circ> rev = (\<lambda>xs. foldr f xs x)"
    by (intro ext) (simp add: foldl_conv_foldr)
  finally show ?thesis .
qed

lemma fold_random_permutation_fold:
  assumes "finite A"
  shows   "fold_random_permutation f x A =
             map_pmf (\<lambda>xs. fold f xs x) (pmf_of_set (permutations_of_set A))"
  by (subst fold_random_permutation_foldl [OF assms], intro map_pmf_cong)
     (simp_all add: foldl_conv_fold)

lemma fold_random_permutation_code [code]:
  "fold_random_permutation f x (set xs) =
     map_pmf (foldl (\<lambda>x y. f y x) x) (pmf_of_set (permutations_of_set (set xs)))"
  by (simp add: fold_random_permutation_foldl)

text \<open>
  We now introduce a slightly generalised version of the above fold
  operation that does not simply return the result in the end, but applies
  a monadic bind to it.
    This may seem somewhat arbitrary, but it is a common use case, e.g.
  in the Social Decision Scheme of Random Serial Dictatorship, where
  voters narrow down a set of possible winners in a random order and
  the winner is chosen from the remaining set uniformly at random.
\<close>
function fold_bind_random_permutation
    :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c pmf) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'c pmf" where
  "fold_bind_random_permutation f g x {} = g x"
| "\<not>finite A \<Longrightarrow> fold_bind_random_permutation f g x A = g x"
| "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow>
     fold_bind_random_permutation f g x A =
       pmf_of_set A \<bind> (\<lambda>a. fold_bind_random_permutation f g (f a x) (A - {a}))"
  by simp_all fastforce
termination proof (relation "Wellfounded.measure (\<lambda>(_,_,_,A). card A)")
  fix A :: "'a set" and f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and x :: 'b
    and y :: 'a and g :: "'b \<Rightarrow> 'c pmf"
  assume A: "finite A" "A \<noteq> {}" "y \<in> set_pmf (pmf_of_set A)"
  then have "card A > 0" by (simp add: card_gt_0_iff)
  with A show "((f, g, f y x, A - {y}), f, g, x, A) \<in> Wellfounded.measure (\<lambda>(_, _, _, A). card A)"
    by simp
qed simp_all

text \<open>
  We now show that the recursive definition is equivalent to
  a random fold followed by a monadic bind.
\<close>
lemma fold_bind_random_permutation_altdef [code]:
  "fold_bind_random_permutation f g x A = fold_random_permutation f x A \<bind> g"
proof (induction f x A rule: fold_random_permutation.induct [case_names empty infinite remove])
  case (remove A f x)
  from remove have "pmf_of_set A \<bind> (\<lambda>a. fold_bind_random_permutation f g (f a x) (A - {a})) =
                      pmf_of_set A \<bind> (\<lambda>a. fold_random_permutation f (f a x) (A - {a}) \<bind> g)"
    by (intro bind_pmf_cong) simp_all
  with remove show ?case by (simp add: bind_return_pmf bind_assoc_pmf)
qed (simp_all add: bind_return_pmf)

text \<open>
  We can now derive the following nice monadic representations of the
  combined fold-and-bind:
\<close>
lemma fold_bind_random_permutation_foldl:
  assumes "finite A"
  shows   "fold_bind_random_permutation f g x A =
             do {xs \<leftarrow> pmf_of_set (permutations_of_set A); g (foldl (\<lambda>x y. f y x) x xs)}"
  using assms by (simp add: fold_bind_random_permutation_altdef bind_assoc_pmf
                            fold_random_permutation_foldl bind_return_pmf map_pmf_def)

lemma fold_bind_random_permutation_foldr:
  assumes "finite A"
  shows   "fold_bind_random_permutation f g x A =
             do {xs \<leftarrow> pmf_of_set (permutations_of_set A); g (foldr f xs x)}"
  using assms by (simp add: fold_bind_random_permutation_altdef bind_assoc_pmf
                            fold_random_permutation_foldr bind_return_pmf map_pmf_def)

lemma fold_bind_random_permutation_fold:
  assumes "finite A"
  shows   "fold_bind_random_permutation f g x A =
             do {xs \<leftarrow> pmf_of_set (permutations_of_set A); g (fold f xs x)}"
  using assms by (simp add: fold_bind_random_permutation_altdef bind_assoc_pmf
                            fold_random_permutation_fold bind_return_pmf map_pmf_def)

text \<open>
  The following useful lemma allows us to swap partitioning a set w.\,r.\,t.\ a
  predicate and drawing a random permutation of that set.
\<close>
lemma partition_random_permutations:
  assumes "finite A"
  shows   "map_pmf (partition P) (pmf_of_set (permutations_of_set A)) =
             pair_pmf (pmf_of_set (permutations_of_set {x\<in>A. P x}))
                      (pmf_of_set (permutations_of_set {x\<in>A. \<not>P x}))" (is "?lhs = ?rhs")
proof (rule pmf_eqI, clarify, goal_cases)
  case (1 xs ys)
  show ?case
  proof (cases "xs \<in> permutations_of_set {x\<in>A. P x} \<and> ys \<in> permutations_of_set {x\<in>A. \<not>P x}")
    case True
    let ?n1 = "card {x\<in>A. P x}" and ?n2 = "card {x\<in>A. \<not>P x}"
    have card_eq: "card A = ?n1 + ?n2"
    proof -
      have "?n1 + ?n2 = card ({x\<in>A. P x} \<union> {x\<in>A. \<not>P x})"
        using assms by (intro card_Un_disjoint [symmetric]) auto
      also have "{x\<in>A. P x} \<union> {x\<in>A. \<not>P x} = A" by blast
      finally show ?thesis ..
    qed

    from True have lengths [simp]: "length xs = ?n1" "length ys = ?n2"
      by (auto intro!: length_finite_permutations_of_set)
    have "pmf ?lhs (xs, ys) =
            real (card (permutations_of_set A \<inter> partition P -` {(xs, ys)})) / fact (card A)"
      using assms by (auto simp: pmf_map measure_pmf_of_set)
    also have "partition P -` {(xs, ys)} = shuffles xs ys"
      using True by (intro inv_image_partition) (auto simp: permutations_of_set_def)
    also have "permutations_of_set A \<inter> shuffles xs ys = shuffles xs ys"
      using True distinct_disjoint_shuffles[of xs ys]
      by (auto simp: permutations_of_set_def dest: set_shuffles)
    also have "card (shuffles xs ys) = length xs + length ys choose length xs"
      using True by (intro card_disjoint_shuffles) (auto simp: permutations_of_set_def)
    also have "length xs + length ys = card A" by (simp add: card_eq)
    also have "real (card A choose length xs) = fact (card A) / (fact ?n1 * fact (card A - ?n1))"
      by (subst binomial_fact) (auto intro!: card_mono assms)
    also have "\<dots> / fact (card A) = 1 / (fact ?n1 * fact ?n2)"
      by (simp add: field_split_simps card_eq)
    also have "\<dots> = pmf ?rhs (xs, ys)" using True assms by (simp add: pmf_pair)
    finally show ?thesis .
  next
    case False
    hence *: "xs \<notin> permutations_of_set {x\<in>A. P x} \<or> ys \<notin> permutations_of_set {x\<in>A. \<not>P x}" by blast
    hence eq: "permutations_of_set A \<inter> (partition P -` {(xs, ys)}) = {}"
      by (auto simp: o_def permutations_of_set_def)
    from * show ?thesis
      by (elim disjE) (insert assms eq, simp_all add: pmf_pair pmf_map measure_pmf_of_set)
  qed
qed

end


header "Arithmetic and Boolean Expressions"

theory AExp imports Main begin

subsection "Arithmetic Expressions"

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

text_raw{*\snip{AExpaexpdef}{2}{1}{% *}
datatype aexp = N int | V vname | Plus aexp aexp
text_raw{*}%endsnip*}

text_raw{*\snip{AExpavaldef}{1}{2}{% *}
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"
text_raw{*}%endsnip*}

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

text {* The same state more concisely: *}
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

text {* A little syntax magic to write larger states compactly: *}

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text {* \noindent
  We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:
*}
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text {* In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
*}
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text{* Note that this @{text"<\<dots>>"} syntax works for any function space
@{text"\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2"} where @{text "\<tau>\<^sub>2"} has a @{text 0}. *}

subsection "Constant Folding"

text{* Evaluate constant subsexpressions: *}

text_raw{*\snip{AExpasimpconstdef}{0}{2}{% *}
fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"
text_raw{*}%endsnip*}

theorem aval_asimp_const:
  "aval (asimp_const a) s = aval a s"
apply(induction a)
apply (auto split: aexp.split)
done

text{* Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors: *}

text_raw{*\snip{AExpplusdef}{0}{2}{% *}
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

text_raw{*\snip{AExpasimpdef}{2}{0}{% *}
fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

text{* Note that in @{const asimp_const} the optimized constructor was
inlined. Making it a separate function @{const plus} improves modularity of
the code and the proofs. *}

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply simp_all
done

end


(*  Title: HOL/ex/Birthday_Paradox.thy
    Author: Lukas Bulwahn, TU Muenchen, 2007
*)

section \<open>A Formulation of the Birthday Paradox\<close>

theory Birthday_Paradox
imports Main HOL.Binomial "HOL-Library.FuncSet"
begin

section \<open>Cardinality\<close>

lemma card_product_dependent:
  assumes "finite S"
  assumes "\<forall>x \<in> S. finite (T x)"
  shows "card {(x, y). x \<in> S \<and> y \<in> T x} = (\<Sum>x \<in> S. card (T x))"
  using card_SigmaI[OF assms, symmetric] by (auto intro!: arg_cong[where f=card] simp add: Sigma_def)

lemma card_extensional_funcset_inj_on:
  assumes "finite S" "finite T" "card S \<le> card T"
  shows "card {f \<in> extensional_funcset S T. inj_on f S} = fact (card T) div (fact (card T - card S))"
using assms
proof (induct S arbitrary: T rule: finite_induct)
  case empty
  from this show ?case by (simp add: Collect_conv_if PiE_empty_domain)
next
  case (insert x S)
  { fix x
    from \<open>finite T\<close> have "finite (T - {x})" by auto
    from \<open>finite S\<close> this have "finite (extensional_funcset S (T - {x}))"
      by (rule finite_PiE)
    moreover
    have "{f : extensional_funcset S (T - {x}). inj_on f S} \<subseteq> (extensional_funcset S (T - {x}))" by auto
    ultimately have "finite {f : extensional_funcset S (T - {x}). inj_on f S}"
      by (auto intro: finite_subset)
  } note finite_delete = this
  from insert have hyps: "\<forall>y \<in> T. card ({g. g \<in> extensional_funcset S (T - {y}) \<and> inj_on g S}) = fact (card T - 1) div fact ((card T - 1) - card S)"(is "\<forall> _ \<in> T. _ = ?k") by auto
  from extensional_funcset_extend_domain_inj_on_eq[OF \<open>x \<notin> S\<close>]
  have "card {f. f : extensional_funcset (insert x S) T & inj_on f (insert x S)} =
    card ((%(y, g). g(x := y)) ` {(y, g). y : T & g : extensional_funcset S (T - {y}) & inj_on g S})"
    by metis
  also from extensional_funcset_extend_domain_inj_onI[OF \<open>x \<notin> S\<close>, of T] have "... =  card {(y, g). y : T & g : extensional_funcset S (T - {y}) & inj_on g S}"
    by (simp add: card_image)
  also have "card {(y, g). y \<in> T \<and> g \<in> extensional_funcset S (T - {y}) \<and> inj_on g S} =
    card {(y, g). y \<in> T \<and> g \<in> {f \<in> extensional_funcset S (T - {y}). inj_on f S}}" by auto
  also from \<open>finite T\<close> finite_delete have "... = (\<Sum>y \<in> T. card {g. g \<in> extensional_funcset S (T - {y}) \<and>  inj_on g S})"
    by (subst card_product_dependent) auto
  also from hyps have "... = (card T) * ?k"
    by auto
  also have "... = card T * fact (card T - 1) div fact (card T - card (insert x S))"
    using insert unfolding div_mult1_eq[of "card T" "fact (card T - 1)"]
    by (simp add: fact_mod)
  also have "... = fact (card T) div fact (card T - card (insert x S))"
    using insert by (simp add: fact_reduce[of "card T"])
  finally show ?case .
qed

lemma card_extensional_funcset_not_inj_on:
  assumes "finite S" "finite T" "card S \<le> card T"
  shows "card {f \<in> extensional_funcset S T. \<not> inj_on f S} = (card T) ^ (card S) - (fact (card T)) div (fact (card T - card S))"
proof -
  have subset: "{f : extensional_funcset S T. inj_on f S} <= extensional_funcset S T" by auto
  from finite_subset[OF subset] assms have finite: "finite {f : extensional_funcset S T. inj_on f S}"
    by (auto intro!: finite_PiE)
  have "{f \<in> extensional_funcset S T. \<not> inj_on f S} = extensional_funcset S T - {f \<in> extensional_funcset S T. inj_on f S}" by auto
  from assms this finite subset show ?thesis
    by (simp add: card_Diff_subset card_PiE card_extensional_funcset_inj_on prod_constant)
qed

lemma prod_upto_nat_unfold:
  "prod f {m..(n::nat)} = (if n < m then 1 else (if n = 0 then f 0 else f n * prod f {m..(n - 1)}))"
  by auto (auto simp add: gr0_conv_Suc atLeastAtMostSuc_conv)

section \<open>Birthday paradox\<close>

lemma birthday_paradox:
  assumes "card S = 23" "card T = 365"
  shows "2 * card {f \<in> extensional_funcset S T. \<not> inj_on f S} \<ge> card (extensional_funcset S T)"
proof -
  from \<open>card S = 23\<close> \<open>card T = 365\<close> have "finite S" "finite T" "card S <= card T" by (auto intro: card_ge_0_finite)
  from assms show ?thesis
    using card_PiE[OF \<open>finite S\<close>, of "\<lambda>i. T"] \<open>finite S\<close>
      card_extensional_funcset_not_inj_on[OF \<open>finite S\<close> \<open>finite T\<close> \<open>card S <= card T\<close>]
    by (simp add: fact_div_fact prod_upto_nat_unfold prod_constant)
qed

end