theory Chapter2Guisen
imports Main
begin

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

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

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

text\<open>
\endexercise

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

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

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

(*<*)
done
(*>*)

lemma add_comm [simp]: "add m n = add n m"
(* your definition/proof here *)
apply(induction m)
apply(auto)

(*<*)
oops
(*>*)

lemma add_zero [simp]: "add n 0 = n"
apply(induction n)
apply(auto)
done
(*<*)
(*>*)

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

lemma add_comm [simp]: "add m n = add n m"
(* your definition/proof here *)
apply(induction m)
apply(auto)

text\<open> Define a recursive function \<close>
(*<*)
done
(*>*)
fun double :: "nat \<Rightarrow> nat" where
(* your definition/proof here *)
"double 0 = 0" |
"double (Suc n) = Suc (Suc (double n))"

text\<open> test \<close>
value  "double 2"
text\<open> and prove that \<close>

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

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

fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
"count Nil x = 0" |
"count (Cons x xs) z = (if x=z then Suc(count xs z) else count xs z)"

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

theorem "count xs x \<le> length xs"
(* your definition/proof here *)
apply(induction xs)
apply(auto)
done
text\<open>
\endexercise

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

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
(* your definition/proof here *)
"snoc Nil z = Cons z Nil"|
"snoc (Cons x xs) z = Cons x (snoc xs z)"
text \<open>
Convince yourself on some test cases that your definition
of @{term snoc} behaves as expected.
With the help of @{text snoc} define a recursive function @{text reverse}
that reverses a list. Do not use the predefined function @{const rev}.
\<close>

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse Nil = Nil"|
"reverse (Cons x xs) =snoc (reverse xs) x"
(* your definition/proof here *)

text \<open>
Prove the following theorem. You will need an additional lemma.
\<close>
theorem "reverse (reverse xs) = xs"
(* your definition/proof here *)
apply(induction xs)
apply(auto)
(*<*)oops(*>*)
lemma reverse_snoc[simp]: "reverse (snoc xs x)=Cons x (reverse xs)"
apply(induction xs)
apply(auto)
(*<*)done(*>*)
theorem "reverse (reverse xs) = xs"
(* your definition/proof here *)
apply(induction xs)
apply(auto)
(*<*)oops(*>*)
text\<open>
\endexercise

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

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

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

lemma "sum_upto n = n * (n+1) div 2"
(* your definition/proof here *)
apply(induction n)
apply(auto)
(*<*)done(*>*)
text\<open>
\endexercise

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

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = Nil"|
"contents (Node l a r) = (contents l) @ (Cons a (contents r))"
(* your definition/proof here *)

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

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

text\<open> and prove \<close>

lemma "sum_tree t = sum_list(contents t)"
(* your definition/proof here *)
apply(induction t)
apply(auto)
(*<*)done(*>*)
text\<open>
\endexercise

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

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

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

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

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
(* your definition/proof here *)
"post_order (Tip x) = Cons x Nil"|
"post_order (Node l a r) = (post_order l) @ (post_order r) @ (Cons a Nil)"
text\<open>
that traverse a tree and collect all stored values in the respective order in
a list. Prove \<close>

lemma "pre_order (mirror t) = rev (post_order t)"
(* your definition/proof here *)
apply(induction t)
apply(auto)
(*<*)done(*>*)
text\<open>
\endexercise

\exercise
Define a recursive function
\<close>

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

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

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
(* your definition/proof here *)
apply(induction xs)
apply(auto)
(*<*)done(*>*)
text\<open>
\endexercise

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

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

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

lemma "itadd m n = add m n"
(* your definition/proof here *)
apply(induction m arbitrary:n)
apply(auto)
(*<*)done(*>*)
text\<open>
\endexercise

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

(*<*)
datatype tree0 = Tip | Node tree0 tree0
(*>*)

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

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

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

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

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

text\<open>test\<close>
value  "nodes (explode 2 Tip )"

lemma num_ex: "nodes (explode n t ) = ((nodes t) * (2^n))+(2^(n)-1)"

apply(induction n arbitrary:t)
apply(auto simp add:algebra_simps)
(*<*)done(*>*)
text\<open>

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

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

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

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var x = x"|
"eval (Const y) x = y"|
"eval (Add z w) x = (eval z x) + (eval w x)"|
"eval (Mult u v) x = (eval u x) * (eval v x)"
(* your definition/proof here *)

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

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

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalp Nil z = 0"|
"evalp (Cons x xs) z = x + (evalp xs z)*z"
(* your definition/proof here *)

text\<open>
Define a function @{text coeffs} that transforms an expression into a polynomial.
This will require auxiliary functions.
\<close>
text\<open>test\<close>
value "eval (Add (Mult (Const 2) Var) (Const 3)) i"

fun addp :: "int list \<Rightarrow>int list \<Rightarrow>int list " where
"addp Nil xs = xs"|
"addp xs Nil = xs"|
"addp (Cons x xs) (Cons z zw)= Cons (x + z) (addp xs zw)"

fun multpre ::  "int list \<Rightarrow>int \<Rightarrow>int list " where
"multpre Nil z = Nil"|
"multpre  (Cons x xs) z= Cons (x*z) (multpre xs z) "
fun multp :: "int list \<Rightarrow>int list \<Rightarrow>int list " where
"multp zw Nil = Nil"|
"multp  zw (Cons x xs) = (if zw=Nil then Nil else (addp(multpre zw x) (Cons 0 (multp zw xs))))"

fun coeffs :: "exp \<Rightarrow> int list" where
(* your definition/proof here *)
"coeffs Var = Cons 0 (Cons 1 Nil)"|
"coeffs (Const y) = Cons y Nil"|
"coeffs (Add z w) = (addp (coeffs z) (coeffs w))"|
"coeffs (Mult u v) = (multp (coeffs u) (coeffs v))"
text\<open>
Prove that @{text coeffs} preserves the value of the expression:
\<close>

value "coeffs (Add (Mult (Const 2) Var) (Const 3))"

theorem evalp_coeffs: "evalp (coeffs e) x = eval e x"
(* your definition/proof here *)
  apply(induction e)
apply(auto simp add:algebra_simps split:exp.split)
(*<*)oops(*>*)
lemma addp[simp]: "evalp (addp z w) x =(evalp z x) + (evalp w x)"
apply(induction w  rule:addp.induct)
    apply(auto simp add:algebra_simps)
(*<*)done(*>*)
lemma multpre[simp]: "evalp (multpre z a) x = a * evalp z x"
apply(induction z a rule:multpre.induct)
apply(auto simp add:algebra_simps)
(*<*)done(*>*)
lemma multp[simp]: "evalp (multp z w) x =(evalp z x) * (evalp w x)"
apply(induction w arbitrary:x z)
apply(auto simp add:algebra_simps)
(*<*)done(*>*)
theorem evalp_coeffs: "evalp (coeffs e) x = eval e x"
(* your definition/proof here *)
  apply(induction e)
apply(auto simp add:algebra_simps split:exp.split)
(*<*)done(*>*)
text\<open>
Hint: consider the hint in Exercise~\ref{exe:tree0}.
\endexercise
\<close>

end


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)"
value "[a,b] @ [c,d]"

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_zero[simp]: "add m 0 = m"
  apply(induction m)
  apply simp
  apply simp
done

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

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

text{* Define a recursive function *}

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

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 [] m = 0" |
"count (n#ns) m = (if n = m then Suc (count ns m) else count ns m)"

value "count [1, 2, 3] (1::nat)"
value "count [] (1::nat)"
value "count [3, 1, 2, 1, 0] (1::nat)"

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 [] m = [m]" |
"snoc (n#ns) m = n # (snoc ns m)"

value "snoc [3, 1, 2, 1, 0] (4::int)"
value "snoc [a, b] c"

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 (n#ns) = snoc (reverse ns) n"

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

theorem "reverse (reverse xs) = xs"
  apply(induction xs)
  apply(auto simp add: reverse_snoc)
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 n = 0 + ... + n"}:
*}

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

value "sum 0"
value "sum 2"
value "sum 4"

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 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 m n) = m # ((contents l) @ (contents n))"

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

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

text{* and prove *}

lemma "treesum t = listsum(contents t)"
apply(induction t)
by auto

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 *}

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

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

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

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

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 m [] = []" |
"intersperse m (n#ns) = n # m # (intersperse m ns)"

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

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 simp
  apply simp
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:
*}

fun nodes :: "tree0 \<Rightarrow> nat" where
(* your definition/proof here *)

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

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
*}

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
(* your definition/proof here *)

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
(* your definition/proof here *)

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

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

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

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

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

end


(*  Title:      HOL/Number_Theory/Fib.thy
    Author:     Lawrence C. Paulson
    Author:     Jeremy Avigad

Defines the fibonacci function.

The original "Fib" is due to Lawrence C. Paulson, and was adapted by
Jeremy Avigad.
*)

section {* Fib *}

theory Fib
imports Binomial
begin

subsection {* Main definitions *}

fun fib :: "nat \<Rightarrow> nat"
where
    fib0: "fib 0 = 0"
  | fib1: "fib (Suc 0) = 1"
  | fib2: "fib (Suc (Suc n)) = fib (Suc n) + fib n"

subsection {* Fibonacci numbers *}

lemma fib_1 [simp]: "fib (1::nat) = 1"
  by (metis One_nat_def fib1)

lemma fib_2 [simp]: "fib (2::nat) = 1"
  using fib.simps(3) [of 0]
  by (simp add: numeral_2_eq_2)

lemma fib_plus_2: "fib (n + 2) = fib (n + 1) + fib n"
  by (metis Suc_eq_plus1 add_2_eq_Suc' fib.simps(3))

lemma fib_add: "fib (Suc (n+k)) = fib (Suc k) * fib (Suc n) + fib k * fib n"
  by (induct n rule: fib.induct) (auto simp add: field_simps)

lemma fib_neq_0_nat: "n > 0 \<Longrightarrow> fib n > 0"
  by (induct n rule: fib.induct) (auto simp add: )

text {*
  \medskip Concrete Mathematics, page 278: Cassini's identity.  The proof is
  much easier using integers, not natural numbers!
*}

lemma fib_Cassini_int: "int (fib (Suc (Suc n)) * fib n) - int((fib (Suc n))\<^sup>2) = - ((-1)^n)"
  by (induction n rule: fib.induct)  (auto simp add: field_simps power2_eq_square power_add)

lemma fib_Cassini_nat:
    "fib (Suc (Suc n)) * fib n =
       (if even n then (fib (Suc n))\<^sup>2 - 1 else (fib (Suc n))\<^sup>2 + 1)"
using fib_Cassini_int [of n] by auto

text {* \medskip Toward Law 6.111 of Concrete Mathematics *}

lemma coprime_fib_Suc_nat: "coprime (fib (n::nat)) (fib (Suc n))"
  apply (induct n rule: fib.induct)
  apply auto
  apply (metis gcd_add1_nat add.commute)
  done

lemma gcd_fib_add: "gcd (fib m) (fib (n + m)) = gcd (fib m) (fib n)"
  apply (simp add: gcd_commute_nat [of "fib m"])
  apply (cases m)
  apply (auto simp add: fib_add)
  apply (subst gcd_commute_nat)
  apply (subst mult.commute)
  apply (metis coprime_fib_Suc_nat gcd_add_mult_nat gcd_mult_cancel_nat gcd_nat.commute)
  done

lemma gcd_fib_diff: "m \<le> n \<Longrightarrow>
    gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)"
  by (simp add: gcd_fib_add [symmetric, of _ "n-m"])

lemma gcd_fib_mod: "0 < m \<Longrightarrow>
    gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
proof (induct n rule: less_induct)
  case (less n)
  from less.prems have pos_m: "0 < m" .
  show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
  proof (cases "m < n")
    case True
    then have "m \<le> n" by auto
    with pos_m have pos_n: "0 < n" by auto
    with pos_m `m < n` have diff: "n - m < n" by auto
    have "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib ((n - m) mod m))"
      by (simp add: mod_if [of n]) (insert `m < n`, auto)
    also have "\<dots> = gcd (fib m)  (fib (n - m))"
      by (simp add: less.hyps diff pos_m)
    also have "\<dots> = gcd (fib m) (fib n)"
      by (simp add: gcd_fib_diff `m \<le> n`)
    finally show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)" .
  next
    case False
    then show "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
      by (cases "m = n") auto
  qed
qed

lemma fib_gcd: "fib (gcd m n) = gcd (fib m) (fib n)"
    -- {* Law 6.111 *}
  by (induct m n rule: gcd_nat_induct) (simp_all add: gcd_non_0_nat gcd_commute_nat gcd_fib_mod)

theorem fib_mult_eq_setsum_nat:
    "fib (Suc n) * fib n = (\<Sum>k \<in> {..n}. fib k * fib k)"
  by (induct n rule: nat.induct) (auto simp add:  field_simps)

end


(*  Title:  HOL/ex/NatSum.thy
    Author: Tobias Nipkow
*)

section \<open>Summing natural numbers\<close>

theory NatSum imports Main begin

text \<open>
  Summing natural numbers, squares, cubes, etc.

  Thanks to Sloane's On-Line Encyclopedia of Integer Sequences,
  \<^url>\<open>http://www.research.att.com/~njas/sequences\<close>.
\<close>

lemmas [simp] =
  ring_distribs
  diff_mult_distrib diff_mult_distrib2 \<comment>\<open>for type nat\<close>

text \<open>
  \medskip The sum of the first \<open>n\<close> odd numbers equals \<open>n\<close>
  squared.
\<close>

lemma sum_of_odds: "(\<Sum>i=0..<n. Suc (i + i)) = n * n"
  by (induct n) auto

text \<open>
  \medskip The sum of the first \<open>n\<close> odd squares.
\<close>

lemma sum_of_odd_squares:
  "3 * (\<Sum>i=0..<n. Suc(2*i) * Suc(2*i)) = n * (4 * n * n - 1)"
  by (induct n) auto

text \<open>
  \medskip The sum of the first \<open>n\<close> odd cubes
\<close>

lemma sum_of_odd_cubes:
  "(\<Sum>i=0..<n. Suc (2*i) * Suc (2*i) * Suc (2*i)) =
    n * n * (2 * n * n - 1)"
  by (induct n) auto

text \<open>
  \medskip The sum of the first \<open>n\<close> positive integers equals
  \<open>n (n + 1) / 2\<close>.\<close>

lemma sum_of_naturals:
    "2 * (\<Sum>i=0..n. i) = n * Suc n"
  by (induct n) auto

lemma sum_of_squares:
    "6 * (\<Sum>i=0..n. i * i) = n * Suc n * Suc (2 * n)"
  by (induct n) auto

lemma sum_of_cubes:
    "4 * (\<Sum>i=0..n. i * i * i) = n * n * Suc n * Suc n"
  by (induct n) auto

text\<open>\medskip A cute identity:\<close>

lemma sum_squared: "(\<Sum>i=0..n. i)^2 = (\<Sum>i=0..n::nat. i^3)"
proof(induct n)
  case 0 show ?case by simp
next
  case (Suc n)
  have "(\<Sum>i = 0..Suc n. i)^2 =
        (\<Sum>i = 0..n. i^3) + (2*(\<Sum>i = 0..n. i)*(n+1) + (n+1)^2)"
    (is "_ = ?A + ?B")
    using Suc by(simp add:eval_nat_numeral)
  also have "?B = (n+1)^3"
    using sum_of_naturals by(simp add:eval_nat_numeral)
  also have "?A + (n+1)^3 = (\<Sum>i=0..Suc n. i^3)" by simp
  finally show ?case .
qed

text \<open>
  \medskip Sum of fourth powers: three versions.
\<close>

lemma sum_of_fourth_powers:
  "30 * (\<Sum>i=0..n. i * i * i * i) =
    n * Suc n * Suc (2 * n) * (3 * n * n + 3 * n - 1)"
  apply (induct n)
   apply simp_all
  apply (case_tac n)  \<comment> \<open>eliminates the subtraction\<close>
   apply (simp_all (no_asm_simp))
  done

text \<open>
  Two alternative proofs, with a change of variables and much more
  subtraction, performed using the integers.\<close>

lemma int_sum_of_fourth_powers:
  "30 * int (\<Sum>i=0..<m. i * i * i * i) =
    int m * (int m - 1) * (int(2 * m) - 1) *
    (int(3 * m * m) - int(3 * m) - 1)"
  by (induct m) (simp_all add: of_nat_mult)

lemma of_nat_sum_of_fourth_powers:
  "30 * of_nat (\<Sum>i=0..<m. i * i * i * i) =
    of_nat m * (of_nat m - 1) * (of_nat (2 * m) - 1) *
    (of_nat (3 * m * m) - of_nat (3 * m) - (1::int))"
  by (induct m) (simp_all add: of_nat_mult)

text \<open>
  \medskip Sums of geometric series: \<open>2\<close>, \<open>3\<close> and the
  general case.
\<close>

lemma sum_of_2_powers: "(\<Sum>i=0..<n. 2^i) = 2^n - (1::nat)"
  by (induct n) (auto split: nat_diff_split)

lemma sum_of_3_powers: "2 * (\<Sum>i=0..<n. 3^i) = 3^n - (1::nat)"
  by (induct n) auto

lemma sum_of_powers: "0 < k ==> (k - 1) * (\<Sum>i=0..<n. k^i) = k^n - (1::nat)"
  by (induct n) auto

end


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

  The unique decomposition of a natural number into a squarefree part and a square.
*)

section \<open>Squarefree decomposition of natural numbers\<close>
theory Squarefree_Nat
imports
  Main
  "HOL-Number_Theory.Number_Theory"
  Prime_Harmonic_Misc
begin

text \<open>
  The squarefree part of a natural number is the set of all prime factors that appear
  with odd multiplicity. The square part, correspondingly, is what remains after dividing
  by the squarefree part.
\<close>
definition squarefree_part :: "nat \<Rightarrow> nat set" where
  "squarefree_part n = {p\<in>prime_factors n. odd (multiplicity p n)}"

definition square_part :: "nat \<Rightarrow> nat" where
  "square_part n = (if n = 0 then 0 else (\<Prod>p\<in>prime_factors n. p ^ (multiplicity p n div 2)))"

lemma squarefree_part_0 [simp]: "squarefree_part 0 = {}"
  by (simp add: squarefree_part_def)

lemma square_part_0 [simp]: "square_part 0 = 0"
  by (simp add: square_part_def)

lemma squarefree_decompose: "\<Prod>(squarefree_part n) * square_part n ^ 2 = n"
proof (cases "n = 0")
  case False
  define A s where "A = squarefree_part n" and "s = square_part n"
  have "(\<Prod>A) = (\<Prod>p\<in>A. p ^ (multiplicity p n mod 2))"
    by (intro prod.cong) (auto simp: A_def squarefree_part_def elim!: oddE)
  also have "\<dots> = (\<Prod>p\<in>prime_factors n. p ^ (multiplicity p n mod 2))"
    by (intro prod.mono_neutral_left) (auto simp: A_def  squarefree_part_def)
  also from False have "\<dots> * s^2 = n"
    by (simp add: s_def square_part_def prod.distrib [symmetric] power_add [symmetric]
                  power_mult [symmetric] prime_factorization_nat [symmetric] algebra_simps
                  prod_power_distrib)
  finally show "\<Prod>A * s^2 = n" .
qed simp

lemma squarefree_part_pos [simp]: "\<Prod>(squarefree_part n) > 0"
  using prime_gt_0_nat unfolding squarefree_part_def by auto

lemma squarefree_part_ge_Suc_0 [simp]: "\<Prod>(squarefree_part n) \<ge> Suc 0"
  using squarefree_part_pos[of n] by presburger

lemma squarefree_part_subset [intro]: "squarefree_part n \<subseteq> prime_factors n"
  unfolding squarefree_part_def by auto

lemma squarefree_part_finite [simp]: "finite (squarefree_part n)"
  by (rule finite_subset[OF squarefree_part_subset]) simp

lemma squarefree_part_dvd [simp]: "\<Prod>(squarefree_part n) dvd n"
  by (subst (2) squarefree_decompose [of n, symmetric]) simp

lemma squarefree_part_dvd' [simp]: "p \<in> squarefree_part n \<Longrightarrow> p dvd n"
  by (rule dvd_prodD[OF _ squarefree_part_dvd]) simp_all

lemma square_part_dvd [simp]: "square_part n ^ 2 dvd n"
  by (subst (2) squarefree_decompose [of n, symmetric]) simp

lemma square_part_dvd' [simp]: "square_part n dvd n"
  by (subst (2) squarefree_decompose [of n, symmetric]) simp

lemma squarefree_part_le: "p \<in> squarefree_part n \<Longrightarrow> p \<le> n"
  by (cases "n = 0") (simp_all add: dvd_imp_le)

lemma square_part_le: "square_part n \<le> n"
  by (cases "n = 0") (simp_all add: dvd_imp_le)

lemma square_part_le_sqrt: "square_part n \<le> nat \<lfloor>sqrt (real n)\<rfloor>"
proof -
  have "1 * square_part n ^ 2 \<le> \<Prod>(squarefree_part n) * square_part n ^ 2"
    by (intro mult_right_mono) simp_all
  also have "\<dots> = n" by (rule squarefree_decompose)
  finally have "real (square_part n ^ 2) \<le> real n" by (subst of_nat_le_iff) simp
  hence "sqrt (real (square_part n ^ 2)) \<le> sqrt (real n)"
    by (subst real_sqrt_le_iff) simp_all
  also have "sqrt (real (square_part n ^ 2)) = real (square_part n)" by simp
  finally show ?thesis by linarith
qed

lemma square_part_pos [simp]: "n > 0 \<Longrightarrow> square_part n > 0"
  unfolding square_part_def using prime_gt_0_nat by auto

lemma square_part_ge_Suc_0 [simp]: "n > 0 \<Longrightarrow> square_part n \<ge> Suc 0"
  using square_part_pos[of n] by presburger

lemma zero_not_in_squarefree_part [simp]: "0 \<notin> squarefree_part n"
  unfolding squarefree_part_def by auto

lemma multiplicity_squarefree_part:
  "prime p \<Longrightarrow> multiplicity p (\<Prod>(squarefree_part n)) = (if p \<in> squarefree_part n then 1 else 0)"
  using squarefree_part_subset[of n]
  by (intro multiplicity_prod_prime_powers_nat') auto

text \<open>
  The squarefree part really is square, its only square divisor is 1.
\<close>
lemma square_dvd_squarefree_part_iff:
  "x^2 dvd \<Prod>(squarefree_part n) \<longleftrightarrow> x = 1"
proof (rule iffI, rule multiplicity_eq_nat)
  assume dvd: "x^2 dvd \<Prod>(squarefree_part n)"
  hence "x \<noteq> 0" using squarefree_part_subset[of n] prime_gt_0_nat by (intro notI) auto
  thus x: "x > 0" by simp

  fix p :: nat assume p: "prime p"
  from p x have "2 * multiplicity p x = multiplicity p (x^2)"
    by (simp add: multiplicity_power_nat)
  also from dvd have "\<dots> \<le> multiplicity p (\<Prod>(squarefree_part n))"
    by (intro dvd_imp_multiplicity_le) simp_all
  also have "\<dots> \<le> 1" using multiplicity_squarefree_part[of p n] p by simp
  finally show "multiplicity p x = multiplicity p 1" by simp
qed simp_all

lemma squarefree_decomposition_unique1:
  assumes "squarefree_part m = squarefree_part n"
  assumes "square_part m = square_part n"
  shows   "m = n"
  by (subst (1 2) squarefree_decompose [symmetric]) (simp add: assms)

lemma squarefree_decomposition_unique2:
  assumes n: "n > 0"
  assumes decomp: "n = (\<Prod>A2 * s2^2)"
  assumes prime: "\<And>x. x \<in> A2 \<Longrightarrow> prime x"
  assumes fin: "finite A2"
  assumes s2_nonneg: "s2 \<ge> 0"
  shows "A2 = squarefree_part n" and "s2 = square_part n"
proof -
  define A1 s1 where "A1 = squarefree_part n" and "s1 = square_part n"
  have "finite A1" unfolding A1_def by simp
  note fin = \<open>finite A1\<close> \<open>finite A2\<close>

  have "A1 \<subseteq> prime_factors n" unfolding A1_def using squarefree_part_subset .
  note subset = this prime

  have "\<Prod>A1 > 0" "\<Prod>A2 > 0" using subset(1)  prime_gt_0_nat
    by (auto intro!: prod_pos dest: prime)
  from n have "s1 > 0" unfolding s1_def by simp
  from assms have "s2 \<noteq> 0" by (intro notI) simp
  hence "s2 > 0" by simp
  note pos = \<open>\<Prod>A1 > 0\<close> \<open>\<Prod>A2 > 0\<close> \<open>s1 > 0\<close> \<open>s2 > 0\<close>

  have eq': "multiplicity p s1 = multiplicity p s2"
            "multiplicity p (\<Prod>A1) = multiplicity p (\<Prod>A2)"
    if   p: "prime p" for p
  proof -
    define m where "m = multiplicity p"
    from decomp have "m (\<Prod>A1 * s1^2) = m (\<Prod>A2 * s2^2)" unfolding A1_def s1_def
      by (simp add: A1_def s1_def squarefree_decompose)
    with p pos have eq: "m (\<Prod>A1) + 2 * m s1 = m (\<Prod>A2) + 2 * m s2"
      by (simp add: m_def prime_elem_multiplicity_mult_distrib multiplicity_power_nat)
    moreover from fin subset p have "m (\<Prod>A1) \<le> 1" "m (\<Prod>A2) \<le> 1" unfolding m_def
      by ((subst multiplicity_prod_prime_powers_nat', auto)[])+
    ultimately show "m s1 = m s2" by linarith
    with eq show "m (\<Prod>A1) = m (\<Prod>A2)" by simp
  qed

  show "s2 = square_part n"
    by (rule multiplicity_eq_nat) (insert pos eq'(1), auto simp: s1_def)
  have "\<Prod>A2 = \<Prod>(squarefree_part n)"
    by (rule multiplicity_eq_nat) (insert pos eq'(2), auto simp: A1_def)
  with fin subset show "A2 = squarefree_part n" unfolding A1_def
    by (intro prod_prime_eq) auto
qed

lemma squarefree_decomposition_unique2':
  assumes decomp: "(\<Prod>A1 * s1^2) = (\<Prod>A2 * s2^2 :: nat)"
  assumes fin: "finite A1" "finite A2"
  assumes subset: "\<And>x. x \<in> A1 \<Longrightarrow> prime x" "\<And>x. x \<in> A2 \<Longrightarrow> prime x"
  assumes pos: "s1 > 0" "s2 > 0"
  defines "n \<equiv> \<Prod>A1 * s1^2"
  shows "A1 = A2" "s1 = s2"
proof -
  from pos have n: "n > 0" using prime_gt_0_nat
    by (auto simp: n_def intro!: prod_pos dest: subset)
  have "A1 = squarefree_part n" "s1 = square_part n"
    by ((rule squarefree_decomposition_unique2[of n A1 s1], insert assms n, simp_all)[])+
  moreover have "A2 = squarefree_part n" "s2 = square_part n"
    by ((rule squarefree_decomposition_unique2[of n A2 s2], insert assms n, simp_all)[])+
  ultimately show "A1 = A2" "s1 = s2" by simp_all
qed

text \<open>
  The following is a nice and simple lower bound on the number of prime numbers less than
  a given number due to Erd\H{o}s. In particular, it implies that there are infinitely many primes.
\<close>
lemma primes_lower_bound:
  fixes n :: nat
  assumes "n > 0"
  defines "\<pi> \<equiv> \<lambda>n. card {p. prime p \<and> p \<le> n}"
  shows   "real (\<pi> n) \<ge> ln (real n) / ln 4"
proof -
  have "real n = real (card {1..n})" by simp
  also have "{1..n} = (\<lambda>(A, b). \<Prod>A * b^2) ` (\<lambda>n. (squarefree_part n, square_part n)) ` {1..n}"
    unfolding image_comp o_def squarefree_decompose case_prod_unfold fst_conv snd_conv by simp
  also have "card \<dots> \<le> card ((\<lambda>n. (squarefree_part n, square_part n)) ` {1..n})"
    by (rule card_image_le) simp_all
  also have "\<dots> \<le> card (squarefree_part ` {1..n} \<times> square_part ` {1..n})"
    by (rule card_mono) auto
  also have "real \<dots> = real (card (squarefree_part ` {1..n})) * real (card (square_part ` {1..n}))"
    by simp
  also have "\<dots> \<le> 2 ^ \<pi> n * sqrt (real n)"
  proof (rule mult_mono)
    have "card (squarefree_part ` {1..n}) \<le> card (Pow {p. prime p \<and> p \<le> n})"
      using squarefree_part_subset squarefree_part_le by (intro card_mono) force+
    also have "real \<dots> = 2 ^ \<pi> n" by (simp add: \<pi>_def card_Pow)
    finally show "real (card (squarefree_part ` {1..n})) \<le> 2 ^ \<pi> n" by - simp_all
  next
    have "square_part k \<le> nat \<lfloor>sqrt n\<rfloor>" if "k \<le> n" for k
      by (rule order.trans[OF square_part_le_sqrt])
         (insert that, auto intro!: nat_mono floor_mono)
    hence "card (square_part ` {1..n}) \<le> card {1..nat \<lfloor>sqrt n\<rfloor>}"
      by (intro card_mono) (auto intro: order.trans[OF square_part_le_sqrt])
    also have "\<dots> = nat \<lfloor>sqrt n\<rfloor>" by simp
    also have "real \<dots> \<le> sqrt n" by simp
    finally show "real (card (square_part ` {1..n})) \<le> sqrt (real n)" by - simp_all
  qed simp_all
  finally have "real n \<le> 2 ^ \<pi> n * sqrt (real n)" by - simp_all
  with \<open>n > 0\<close> have "ln (real n) \<le> ln (2 ^ \<pi> n * sqrt (real n))"
    by (subst ln_le_cancel_iff) simp_all
  moreover have "ln (4 :: real) = real 2 * ln 2" by (subst ln_realpow [symmetric]) simp_all
  ultimately show ?thesis using \<open>n > 0\<close>
    by (simp add: ln_mult ln_realpow[of _ "\<pi> n"] ln_sqrt field_simps)
qed

end


chapter {* R3: Razonamiento sobre programas *}

theory R3_Razonamiento_sobre_programas
imports Main
begin

text {* ---------------------------------------------------------------
  Ejercicio 1.1. Definir la función
     sumaImpares :: nat \<Rightarrow> nat
  tal que (sumaImpares n) es la suma de los n primeros números
  impares. Por ejemplo,
     sumaImpares 5  =  25
  ------------------------------------------------------------------ *}

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

text {* ---------------------------------------------------------------
  Ejercicio 1.2. Escribir la demostración detallada de
     sumaImpares n = n*n
  ------------------------------------------------------------------- *}

-- "La demostración detallada es"
lemma "sumaImpares n = n*n"
proof (induct n)
  show "sumaImpares 0 = 0 * 0" by simp
next
  fix n
  assume HI: "sumaImpares n = n * n"
  have "sumaImpares (Suc n) = sumaImpares n + (2*n+1)" by simp
  also have "... = n*n + (2*n+1)" using HI by simp
  also have "... = Suc n * Suc n" by simp
  finally show "sumaImpares (Suc n) = Suc n * Suc n" by simp
qed

text {* ---------------------------------------------------------------
  Ejercicio 2.1. Definir la función
     sumaPotenciasDeDosMasUno :: nat \<Rightarrow> nat
  tal que
     (sumaPotenciasDeDosMasUno n) = 1 + 2^0 + 2^1 + 2^2 + ... + 2^n.
  Por ejemplo,
     sumaPotenciasDeDosMasUno 3  =  16
  ------------------------------------------------------------------ *}

fun sumaPotenciasDeDosMasUno :: "nat \<Rightarrow> nat" where
  "sumaPotenciasDeDosMasUno 0 = 2"
| "sumaPotenciasDeDosMasUno (Suc n) =
      sumaPotenciasDeDosMasUno n + 2^(n+1)"

text {* ---------------------------------------------------------------
  Ejercicio 2.2. Escribir la demostración detallada de
     sumaPotenciasDeDosMasUno n = 2^(n+1)
  ------------------------------------------------------------------- *}

lemma "sumaPotenciasDeDosMasUno n = 2^(n+1)"
proof (induct n)
  show "sumaPotenciasDeDosMasUno 0 = 2^(0 + 1)" by simp
next
  fix n
  assume HI: "sumaPotenciasDeDosMasUno n = 2^(n + 1)"
  have "sumaPotenciasDeDosMasUno (Suc n) = sumaPotenciasDeDosMasUno n + 2^(n + 1)" by simp
  also have "... = 2 ^ (n + 1) + 2 ^ (n + 1)" using HI by simp
  also have "... = 2 ^ ((Suc n) + 1)" by simp
  finally show "sumaPotenciasDeDosMasUno (Suc n) = 2 ^ (Suc n + 1)" by simp
qed

text {* ---------------------------------------------------------------
  Ejercicio 3.1. Definir la función
     copia :: nat \<Rightarrow> 'a \<Rightarrow> 'a list
  tal que (copia n x) es la lista formado por n copias del elemento
  x. Por ejemplo,
     copia 3 x = [x,x,x]
  ------------------------------------------------------------------ *}

fun copia :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "copia 0 x       = []"
| "copia (Suc n) x = x # copia n x"

text {* ---------------------------------------------------------------
  Ejercicio 3.2. Definir la función
     todos :: ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool
  tal que (todos p xs) se verifica si todos los elementos de xs cumplen
  la propiedad p. Por ejemplo,
     todos (\<lambda>x. x>(1::nat)) [2,6,4] = True
     todos (\<lambda>x. x>(2::nat)) [2,6,4] = False
  ------------------------------------------------------------------ *}

fun todos :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "todos p []     = True"
| "todos p (x#xs) = (p x \<and> todos p xs)"

text {* ---------------------------------------------------------------
  Ejercicio 3.2. Demostrar detalladamente que todos los elementos de
  (copia n x) son iguales a x.
  ------------------------------------------------------------------- *}

lemma "todos (\<lambda>y. y=x) (copia n x)"
proof (induct n)
  show "todos (\<lambda>y. y=x) (copia 0 x)" by simp
next
  fix n
  assume HI: "todos (\<lambda>y. y=x) (copia n x)"
  have "todos (\<lambda>y. y=x) (copia (Suc n) x) = todos (\<lambda>y. y=x) (x # (copia n x))" by simp
  also have "... = ((x = x) \<and> (todos (\<lambda>y. y = x) (copia n x)))" by simp
  also have "... = True" using HI by simp
  finally show "todos (\<lambda>y. y = x) (copia (Suc n) x)" by simp
qed

text {* ---------------------------------------------------------------
  Ejercicio 4.1. Definir la función
    factR :: nat \<Rightarrow> nat
  tal que (factR n) es el factorial de n. Por ejemplo,
    factR 4 = 24
  ------------------------------------------------------------------ *}

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

text {* ---------------------------------------------------------------
  Ejercicio 4.2. Se considera la siguiente definición iterativa de la
  función factorial
     factI :: "nat \<Rightarrow> nat" where
     factI n = factI' n 1

     factI' :: nat \<Rightarrow> nat \<Rightarrow> nat" where
     factI' 0       x = x
     factI' (Suc n) x = factI' n (Suc n)*x
  Demostrar que, para todo n y todo x, se tiene
     factI' n x = x * factR n
  Indicación: La propiedad mult_Suc es
     (Suc m) * n = n + m * n
  Puede que se necesite desactivarla en un paso con
     (simp del: mult_Suc)
  ------------------------------------------------------------------- *}

fun factI' :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "factI' 0       x = x"
| "factI' (Suc n) x = factI' n (x * Suc n)"

fun factI :: "nat \<Rightarrow> nat" where
  "factI n = factI' n 1"

lemma fact: "factI' n x = x * factR n"
proof (induct n)
  show "factI' 0 x = x * factR 0" by simp
next
  fix n
  assume H1 :  "factI' n x = x * factR n"
  have  "factI' (Suc n) x =  factI' n (x * Suc n)" by (simp only:factI'.simps(2))
  also have "... = (x * Suc n) * factR n" using H1 by simp
  also have "... = x * factR (Suc n)" by (simp del: mult_Suc)
  finally show "factI' (Suc n) x = x * factR (Suc n)" by simp
qed

text {* ---------------------------------------------------------------
  Ejercicio 4.3. Escribir la demostración detallada de
     factI n = factR n
  ------------------------------------------------------------------- *}

corollary "factI n = factR n"
proof -
  have "factI n = factI' n 1" by simp
  also have "... = 1 * factR n" by (simp add: fact)
  finally show "factI n = factR n" by simp
qed

text {* ---------------------------------------------------------------
  Ejercicio 5.1. Definir, recursivamente y sin usar (@), la función
     amplia :: 'a list \<Rightarrow> 'a \<Rightarrow> 'a list
  tal que (amplia xs y) es la lista obtenida añadiendo el elemento y al
  final de la lista xs. Por ejemplo,
     amplia [d,a] t = [d,a,t]
  ------------------------------------------------------------------ *}

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

text {* ---------------------------------------------------------------
  Ejercicio 5.2. Escribir la demostración detallada de
     amplia xs y = xs @ [y]
  ------------------------------------------------------------------- *}

lemma "amplia xs y = xs @ [y]"
proof (induct xs)
  show "amplia [] y = [] @ [y]" by simp
next
  fix x xs
  assume HI: "amplia xs y = xs @ [y]"
  have "amplia (x # xs) y = x # (amplia xs y)" by simp
  also have "... = x # (xs @ [y])" using HI by simp
  also have "... = (x # xs) @ [y]" by simp
  finally show "amplia (x # xs) y = (x # xs) @ [y]" by simp
qed

end


theory Exercise4p1
imports Main
begin

(*

Exercise 4.1. Start from the data type of binary trees defined earlier:

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

Define a function

  set :: 'a tree \<Rightarrow> 'a set

that returns the elements in a tree and a function

  ord :: int tree \<Rightarrow> bool

that tests if an int tree is ordered.
Define a function ins that inserts an element into an ordered int tree while maintaining the
order of the tree. If the element is already in the tree, the same tree should be returned.
Prove correctness of ins:

  set (ins x t) = {x} \<union> set t

and

  ord t \<Longrightarrow> ord (ins i t).
*)

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

fun set :: "'a tree \<Rightarrow> 'a set" where
    "set Tip = {}"
  | "set (Node t1 i t2) = set t1 \<union> {i} \<union> set t2"

fun ord :: "int tree \<Rightarrow> bool" where
    "ord Tip = True"
  | "ord (Node t1 i t2) = (ord t1 \<and> ord t2 \<and> (\<forall>x \<in> set t1. x < i) \<and> (\<forall>x \<in> set t2. i \<le> x))"

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
    "ins x Tip = Node Tip x Tip"
  | "ins x (Node t1 i t2) = (if x < i then Node (ins x t1) i t2 else Node t1 i (ins x t2))"

value "ins 3 (Node (Node Tip 2 Tip) 3 Tip)"
value "ord (ins 3 (Node (Node Tip 2 Tip) 3 Tip))"

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

lemma set_ins: "set (ins x t) = {x} \<union> set t"
  by (induction t, auto)

(*

I'm presenting my first solution here since it took me quite a while to get.
I was satisfied with the theorems ord_helper1 and ord_helper2 as they were
understandable and seemed to get me where I wanted to go.

However, I had to use rule_tac in order to get the right schematic variables to
unify. This was deeply unsatisfying partly because the book concreate semantics
does not cover rule_tac at all. (I learned its use during my seL4 days.)

More information can be found here:
https://svhol.pbmichel.de/reference/rule_method

*)

lemma ord_helper1: "(\<forall>x \<in> set t. x < y) \<Longrightarrow> i < y \<Longrightarrow> x \<in> set (ins i t) \<Longrightarrow> x < y"
  apply (induction t)
   apply (auto split: if_splits)
  done

lemma ord_helper2: "(\<forall>x \<in> set t. y \<le> x) \<Longrightarrow> y \<le> i \<Longrightarrow> x \<in> set (ins i t) \<Longrightarrow> y \<le> x"
  apply (induction t)
   apply (auto split: if_splits)
    done

lemma "ord t \<Longrightarrow> ord (ins i t)"
  apply (induction t, auto)
   apply (rule_tac y="x2" in ord_helper1, simp_all)
  apply (rule_tac y="x2" in ord_helper2, simp_all)
  done

(* The correct solution is to use set_ins above as part of your simp set *)
lemma "ord t \<Longrightarrow> ord (ins i t)"
  apply (induction t, auto simp: set_ins)
    done

end


theory HSV_tasks_2020_solutions imports Complex_Main begin

section \<open>Task 1: proving that "3 / sqrt 2" is irrational.\<close>

(* The following theorem is copied from Chapter 3 of the worksheet *)
theorem sqrt2_irrational: "sqrt 2 \<notin> \<rat>"
proof auto
  assume "sqrt 2 \<in> \<rat>"
  then obtain m n where
    "n \<noteq> 0" and "\<bar>sqrt 2\<bar> = real m / real n" and "coprime m n"
    by (rule Rats_abs_nat_div_natE)
  hence "\<bar>sqrt 2\<bar>^2 = (real m / real n)^2" by auto
  hence "2 = (real m / real n)^2" by simp
  hence "2 = (real m)^2 / (real n)^2" unfolding power_divide by auto
  hence "2 * (real n)^2 = (real m)^2"
    by (simp add: nonzero_eq_divide_eq `n \<noteq> 0`)
  hence "real (2 * n^2) = (real m)^2" by auto
  hence *: "2 * n^2 = m^2"
    using of_nat_power_eq_of_nat_cancel_iff by blast
  hence "even (m^2)" by presburger
  hence "even m" by simp
  then obtain m' where "m = 2 * m'" by auto
  with * have "2 * n^2 = (2 * m')^2" by auto
  hence "2 * n^2 = 4 * m'^2" by simp
  hence "n^2 = 2 * m'^2" by simp
  hence "even (n^2)" by presburger
  hence "even n" by simp
  with `even m` and `coprime m n` show False by auto
qed

theorem "3 / sqrt 2 \<notin> \<rat>"
proof auto
  assume *: "3 / sqrt 2 \<in> \<rat>"

  (* establish that 3 / sqrt 2 = 3 * sqrt 2 / 2 *)
  have "3 / sqrt 2 = (3 / sqrt 2) * (sqrt 2 / sqrt 2)" by auto
  also have "... = 3 * sqrt 2 / (sqrt 2 * sqrt 2)" by argo
  also have "... = 3 * sqrt 2 / 2" by simp
  finally have "3 / sqrt 2 = 3 * sqrt 2 / 2" by assumption

  (* so 3 * sqrt 2 / 2 is rational ... *)
  with * have "3 * sqrt 2 / 2 \<in> \<rat>" by auto

  (* ... and 2/3 is also rational ... *)
  moreover have "2 / 3 \<in> \<rat>" by simp

  (* ... so their product is also rational ... *)
  ultimately have "(3 * sqrt 2 / 2) * (2 / 3) \<in> \<rat>"
    using Rats_mult by blast

  (* ... which means sqrt 2 is rational ... *)
  hence "sqrt 2 \<in> \<rat>" by simp

  (* ... which contradicts the previous theorem! *)
  with sqrt2_irrational show False by simp
qed

section \<open>Task 2: Centred pentagonal numbers.\<close>

fun pent :: "nat \<Rightarrow> nat" where
  "pent n = (if n = 0 then 1 else 5 * n + pent (n - 1))"

value "pent 0" (* should be 1 *)
value "pent 1" (* should be 6 *)
value "pent 2" (* should be 16 *)
value "pent 3" (* should be 31 *)

theorem "pent n = (5 * n^2 + 5 * n + 2) div 2"
proof (induct n)
  case 0
  thus ?case by auto
next
  case (Suc n)
  have "pent (Suc n) = 5 * (n + 1) + pent n" by simp
  also have "... = 5 * n + 5 + (5 * n^2 + 5 * n + 2) div 2" using Suc by simp
  also have "... = (5 * (n^2 + 2 * n + 1) + 5 * (n + 1) + 2) div 2" by simp
  also have "... = (5 * (n + 1)^2 + 5 * (n + 1) + 2) div 2"
    by (smt add.commute add_Suc mult_2 one_add_one plus_1_eq_Suc power2_sum power_one)
  also have "... = (5 * (Suc n)^2 + 5 * Suc n + 2) div 2" by simp
  finally show ?case by assumption
qed

section \<open>Task 3: Lucas numbers.\<close>

fun luc :: "nat \<Rightarrow> nat" where
  "luc n = (if n = 0 then 2 else if n = 1 then 1 else luc (n - 1) + luc (n - 2))"

value "luc 0" (* should be 2 *)
value "luc 1" (* should be 1 *)
value "luc 2" (* should be 3 *)
value "luc 3" (* should be 4 *)

fun fib :: "nat \<Rightarrow> nat" where
  "fib n = (if n = 0 then 0 else if n = 1 then 1 else fib (n - 1) + fib (n - 2))"

value "fib 0" (* should be 0 *)
value "fib 1" (* should be 1 *)
value "fib 2" (* should be 1 *)
value "fib 3" (* should be 2 *)

thm fib.induct (* rule induction theorem for fib *)

theorem "luc n \<ge> fib n"
  apply (rule fib.induct[of "\<lambda>n. luc n \<ge> fib n"])
  apply (case_tac "n < 2")
  apply auto
  done

theorem "luc (n + 1) = fib n + fib (n + 2)"
proof (rule fib.induct[of "\<lambda>n. luc (n + 1) = fib n + fib (n + 2)"])
  fix n
  assume IH1: "n \<noteq> 0 \<Longrightarrow> n \<noteq> 1 \<Longrightarrow> luc (n - 1 + 1) = fib (n - 1) + fib (n - 1 + 2)"
  assume IH2: "n \<noteq> 0 \<Longrightarrow> n \<noteq> 1 \<Longrightarrow> luc (n - 2 + 1) = fib (n - 2) + fib (n - 2 + 2)"

  (* First deal with the easy case where n \<le> 1 *)
  {
    assume "n \<le> 1" (* local assumption *)
    hence "luc (n + 1) = fib n + fib (n + 2)" by simp
  }
  moreover (* Now deal with the trickier case where n > 1 *)
  {
    assume "n > 1"

    (* Simplify the induction hypotheses *)
    from IH1 have *: "luc n = fib (n - 1) + fib (n + 1)" using `n > 1` by auto
    from IH2 have
      "luc (n - 2 + 1) = fib (n - 2) + fib (n - 2 + 2)" using `n > 1` by fastforce
    hence **: "luc (n - 1) = fib (n - 2) + fib n"
      by (metis Nat.add_diff_assoc2 Suc_leI add.commute add_diff_cancel_right'
          diff_Suc_Suc one_add_one plus_1_eq_Suc `n > 1`)

    (* Some equational reasoning using the definitions of luc and fib to finish the job *)
    have "luc (n + 1) = luc n + luc (n - 1)" using `n > 1` by simp
    also have "... = fib (n - 1) + fib (n + 1) + fib (n - 2) + fib n" using * and ** by simp
    also have "... = fib n + fib (n + 2)" using `n > 1` by simp
    finally have "luc (n + 1) = fib n + fib (n + 2)" by simp
  }
  ultimately show "luc (n + 1) = fib n + fib (n + 2)" by simp
qed

section \<open>Task 4: Balancing circuits.\<close>

datatype "circuit" =
  NOT "circuit"
| AND "circuit" "circuit"
| OR "circuit" "circuit"
| TRUE
| FALSE
| INPUT "int"

text \<open>Simulates a circuit given a valuation for each input wire\<close>

fun simulate where
  "simulate (AND c1 c2) \<rho> = ((simulate c1 \<rho>) \<and> (simulate c2 \<rho>))"
| "simulate (OR c1 c2) \<rho> = ((simulate c1 \<rho>) \<or> (simulate c2 \<rho>))"
| "simulate (NOT c) \<rho> = (\<not> (simulate c \<rho>))"
| "simulate TRUE \<rho> = True"
| "simulate FALSE \<rho> = False"
| "simulate (INPUT i) \<rho> = \<rho> i"

fun circuits_equiv (infix "\<sim>" 50) (* the "50" indicates the operator precedence *) where
  "c1 \<sim> c2 = (\<forall>\<rho>. simulate c1 \<rho> = simulate c2 \<rho>)"

text \<open>Delay (assuming all gates have a delay of 1)\<close>

fun delay :: "circuit \<Rightarrow> nat" where
  "delay (NOT c) = 1 + delay c"
| "delay (AND c1 c2) = 1 + max (delay c1) (delay c2)"
| "delay (OR c1 c2) = 1 + max (delay c1) (delay c2)"
| "delay _ = 0"

fun is_balanced where
  "is_balanced (NOT c) = is_balanced c"
| "is_balanced (AND c1 c2) = (is_balanced c1 \<and> is_balanced c2 \<and> delay c1 = delay c2)"
| "is_balanced (OR c1 c2) = (is_balanced c1 \<and> is_balanced c2 \<and> delay c1 = delay c2)"
| "is_balanced _ = True"

value "is_balanced (AND TRUE TRUE)" (* should be True *)
value "is_balanced (AND (NOT TRUE) TRUE)" (* should be False *)
value "is_balanced (AND (NOT TRUE) (OR TRUE (INPUT 1)))" (* should be True *)

(* produce a balanced tree of OR gates whose leaves are all TRUE *)
fun tree_TRUE where
  "tree_TRUE 0 = TRUE"
| "tree_TRUE (Suc n) = OR (tree_TRUE n) (tree_TRUE n)"

value "tree_TRUE 2" (* should be "OR (OR TRUE TRUE) (OR TRUE TRUE)" *)

lemma tree_TRUE_equiv_TRUE:
  "tree_TRUE n \<sim> TRUE"
  by (induct n, auto)

lemma is_balanced_tree_TRUE: "is_balanced (tree_TRUE n)"
  by (induct n, auto)

lemma delay_tree_TRUE: "delay (tree_TRUE n) = n"
  by (induct n, auto)

(* "pad n c" adds a delay of n to circuit c. It does so by AND-ing with TRUE n times.
  The TRUE is actually produced by a tree of OR-gates of whatever depth is necessary
  to preserve balance. *)
fun pad where
  "pad 0 c = c"
| "pad (Suc n) c = pad n (AND c (tree_TRUE (delay c)))"

value "pad 2 (INPUT 1)" (* should be "AND (AND (INPUT 1) TRUE) (OR TRUE TRUE)" *)

(* Padding does not change a circuit's behaviour *)
lemma padding_is_sound:
  "pad n c \<sim> c"
  apply (induct n arbitrary: c)
  using tree_TRUE_equiv_TRUE by auto

(* Padding does not unbalance a circuit *)
lemma padding_preserves_balance: "is_balanced c \<Longrightarrow> is_balanced (pad n c)"
proof (induct n arbitrary: c)
  case 0
  thus "is_balanced (pad 0 c)" by simp
next
  case (Suc n)
  thus "is_balanced (pad (Suc n) c)"
    using is_balanced_tree_TRUE and delay_tree_TRUE by simp
qed

(* Padding by n adds a delay of n *)
lemma padding_adds_delay: "delay (pad n c) = n + delay c"
  apply (induct n arbitrary: c)
   apply (auto simp add: delay_tree_TRUE)
  done

(* add padding to whichever of c1 and c2 is shorter, then call continuation k *)
fun pad_operands where
  "pad_operands k c1 c2 = (let d1 = delay c1; d2 = delay c2 in
                       if d1 > d2 then k c1 (pad (d1 - d2) c2) else k (pad (d2 - d1) c1) c2)"

lemma padding_AND_is_sound:
  "pad_operands AND c1 c2 \<sim> AND c1 c2"
  apply (cases "delay c1 > delay c2")
  using padding_is_sound by auto

lemma padding_OR_is_sound:
  "pad_operands OR c1 c2 \<sim> OR c1 c2"
  apply (cases "delay c1 > delay c2")
  using padding_is_sound by auto

theorem padding_AND_preserves_balance:
  "is_balanced c1 \<Longrightarrow> is_balanced c2 \<Longrightarrow> is_balanced (pad_operands AND c1 c2)"
  apply (cases "delay c1 > delay c2")
  apply (auto simp add: padding_adds_delay padding_preserves_balance)
  done

theorem padding_OR_preserves_balance:
  "is_balanced c1 \<Longrightarrow> is_balanced c2 \<Longrightarrow> is_balanced (pad_operands OR c1 c2)"
  apply (cases "delay c1 > delay c2")
  apply (auto simp add: padding_adds_delay padding_preserves_balance)
  done

fun balance where
  "balance (NOT c) = NOT (balance c)"
| "balance (AND c1 c2) = pad_operands AND (balance c1) (balance c2)"
| "balance (OR c1 c2) = pad_operands OR (balance c1) (balance c2)"
| "balance TRUE = TRUE"
| "balance FALSE = FALSE"
| "balance (INPUT i) = INPUT i"

value "balance (AND TRUE TRUE)" (* unchanged *)
value "balance (AND (NOT TRUE) TRUE)" (* should be AND (NOT TRUE) (OR TRUE TRUE) *)
value "balance (AND TRUE (NOT TRUE))" (* should be AND (OR TRUE TRUE) (NOT TRUE) *)
value "balance (AND (NOT TRUE) (OR TRUE FALSE))" (* unchanged *)

(* balancing a circuit doesn't change its behaviour *)
theorem balance_is_sound: "balance c \<sim> c"
proof (induct c)
  case (AND c1 c2)
  then show ?case using padding_AND_is_sound by auto
next
  case (OR c1 c2)
  then show ?case using padding_OR_is_sound by auto
qed (simp+)

(* balancing a circuit does indeed result in a balanced circuit *)
theorem balance_is_complete: "is_balanced (balance c)"
proof (induct c)
  case (AND c1 c2)
  hence "is_balanced (balance c1)" and "is_balanced (balance c2)" by auto
  hence "is_balanced (pad_operands AND (balance c1) (balance c2))"
    by (rule padding_AND_preserves_balance)
  thus "is_balanced (balance (AND c1 c2))" by simp
next
  case (OR c1 c2)
  hence "is_balanced (balance c1)" and "is_balanced (balance c2)" by auto
  hence "is_balanced (pad_operands OR (balance c1) (balance c2))"
    by (rule padding_OR_preserves_balance)
  thus "is_balanced (balance (OR c1 c2))" by simp
qed (simp+)

section \<open>Task 5: Extending with NAND gates.\<close>

datatype "circuit'" =
  NOT "circuit'"
| AND "circuit'" "circuit'"
| OR "circuit'" "circuit'"
| TRUE
| FALSE
| INPUT "int"
| NAND "circuit'" "circuit'"

fun fake_NOT where
  "fake_NOT c = NAND c TRUE"

fun transform_to_NAND where
  "transform_to_NAND (NOT c) = fake_NOT (transform_to_NAND c)"
| "transform_to_NAND (AND c1 c2) = fake_NOT (NAND (transform_to_NAND c1) (transform_to_NAND c2))"
| "transform_to_NAND (OR c1 c2) = NAND (fake_NOT (transform_to_NAND c1)) (fake_NOT (transform_to_NAND c2))"
| "transform_to_NAND TRUE = TRUE"
| "transform_to_NAND FALSE = fake_NOT TRUE"
| "transform_to_NAND (INPUT i) = INPUT i"
| "transform_to_NAND (NAND c1 c2) = NAND (transform_to_NAND c1) (transform_to_NAND c2)"

text \<open>Simulates a circuit given a valuation for each input wire\<close>

fun simulate' where
  "simulate' (AND c1 c2) \<rho> = ((simulate' c1 \<rho>) \<and> (simulate' c2 \<rho>))"
| "simulate' (OR c1 c2) \<rho> = ((simulate' c1 \<rho>) \<or> (simulate' c2 \<rho>))"
| "simulate' (NOT c) \<rho> = (\<not> (simulate' c \<rho>))"
| "simulate' TRUE \<rho> = True"
| "simulate' FALSE \<rho> = False"
| "simulate' (INPUT i) \<rho> = \<rho> i"
| "simulate' (NAND c1 c2) \<rho> = (\<not> ((simulate' c1 \<rho>) \<and> (simulate' c2 \<rho>)))"

definition circuits_equiv' where
  "circuits_equiv' c1 c2 \<equiv> \<forall>\<rho>. simulate' c1 \<rho> = simulate' c2 \<rho>"

fun only_NANDs :: "circuit' \<Rightarrow> bool" where
  "only_NANDs (AND _ _) = False"
| "only_NANDs (OR _ _) = False"
| "only_NANDs (NOT _) = False"
| "only_NANDs TRUE = True"
| "only_NANDs FALSE = False"
| "only_NANDs (INPUT _) = True"
| "only_NANDs (NAND c1 c2) = (only_NANDs c1 \<and> only_NANDs c2)"

lemma transform_to_NAND_sound: "circuits_equiv' c (transform_to_NAND c)"
  apply (simp add: circuits_equiv'_def)
  apply (induct c)
  apply auto
  done

lemma transform_to_NAND_complete: "only_NANDs (transform_to_NAND c)"
  apply (induct c)
  apply auto
  done

theorem "\<forall>c. \<exists>c'. circuits_equiv' c c' \<and> only_NANDs c'"
  apply clarsimp
  apply (rule_tac x="transform_to_NAND c" in exI)
  apply (intro conjI)
  apply (simp add: transform_to_NAND_sound)
  apply (simp add: transform_to_NAND_complete)
  done

section \<open>Task 6: Showing that the transformation to NAND gates can increase delay.\<close>

text \<open>Delay (assuming all gates have a delay of 1)\<close>

fun delay' :: "circuit' \<Rightarrow> nat" where
  "delay' (NOT c) = 1 + delay' c"
| "delay' (AND c1 c2) = 1 + max (delay' c1) (delay' c2)"
| "delay' (OR c1 c2) = 1 + max (delay' c1) (delay' c2)"
| "delay' (NAND c1 c2) = 1 + max (delay' c1) (delay' c2)"
| "delay' _ = 0"

theorem transform_to_NAND_increases_delay: "delay' (transform_to_NAND c) \<le> 2 * delay' c + 1"
  apply (induct c)
  apply auto
  done

end


theory Concrete_Semantics_2_2_ex2
imports Main
begin
fun add:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

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

(* Prove that add is associative and commutative *)

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

lemma succ_add_com[simp]: "Suc (add n m) = add n (Suc m)"
apply(induction n) (* to use `m` needs difficult proof structure *)
apply(auto)
done

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

(* Define a recursive function double *)
fun double :: "nat \<Rightarrow> nat" where
"double 0 = 0" |
"double m = 2 + double(m - 1)"

(* prove double m = add m m. *)

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

end


theory Chapter4
  imports Main Chapter2
begin

(* Exercise 4.1 *)

lemma
  assumes T: "ALL x y. T x y \<or> T y x"
and
A: "ALL x y. A x y \<and> A y x \<longrightarrow> x = y"
and
TA: "ALL x y. T x y \<longrightarrow> A x y"
and
"A x y"
shows "T x y"
proof -
  from assms show  "T x y" by blast
qed

(* Exercise 4.2 *)

lemma "EX ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
proof -
  consider (odd) "odd (length xs)" | (even) "even (length xs)" by auto
  then show ?thesis
  proof cases
    case odd
    let ?l1 =  " take ((length xs + 1) div 2) xs"
    let ?l2 = " drop ((length xs + 1) div 2) xs"
    have 1: "xs = ?l1 @ ?l2" by auto
    have 2: " length ?l1 = length ?l2 + 1"
    by (smt "1" add.commute add_diff_cancel_right' diff_diff_left dvd_mult_div_cancel length_append
length_drop mult_2 odd odd_even_add odd_one odd_succ_div_two)
    from 1 have "xs = ?l1 @ ?l2 \<and> ( length ?l1 = length ?l2 + 1)" using 2 by auto
    thus ?thesis by blast
  next
    case even
    let ?l1 =  " take ((length xs) div 2) xs"
    let ?l2 = " drop ((length xs) div 2) xs"
    have 1: "xs = ?l1 @ ?l2" by auto
    have 2: " length ?l1 = length ?l2"
    using even by auto
  from 1 have "xs = ?l1 @ ?l2 \<and> ( length ?l1 = length ?l2)" using 2 by auto
  thus ?thesis by blast
qed
qed

(* Exercise 4.3 *)

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(n+2)"

lemma
  assumes a: "ev(Suc(Suc n))"
  shows "ev n"
proof -
  from a show ?thesis
  proof cases
    case ev0
  next
    case (evSS n)
    then show ?thesis by auto
  qed
qed

(* Exercise 4.4 *)

lemma " \<not> ev (Suc (Suc (Suc 0))) "
proof
  assume a: " ev (Suc (Suc (Suc 0)))"
  thus "False"
  proof cases
    case ev0
next
  case (evSS n)
  hence "n = (Suc 0) " by arith
  hence "ev (Suc 0)" using evSS by auto
  thus "False"
  using ev.cases by auto
qed
qed

(* Exercise 4.5 *)

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
 iter0: "iter r 0 x x"
| iter1: "r x y \<Longrightarrow>  iter r (Suc 0) x y"
| iter_step: "iter r n x y \<Longrightarrow> iter r m y z \<Longrightarrow> iter r (n + m) x z"

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
    proof(induction rule: star.induct)
      case (refl x)
      then show ?case by auto
    next
      case (step x y z)
      then show ?case by (metis star.step)
    qed

lemma "iter r n x y \<Longrightarrow> star r x y "
proof(induction rule: iter.induct)
case (iter0 x)
  then show ?case by (simp add: star.refl)
next
case (iter1 x y)
  then show ?case
  proof
    show "star r y y" by (simp add: star.refl)
  qed
next
  case (iter_step n x y m z)
  from iter_step(3-4) show ?case using star_trans by fastforce
qed

(* Exercise 4.6 *)

fun elems :: " 'a list \<Rightarrow> 'a set " where
"elems Nil = {}"
| "elems (Cons x xs) = {x} Un (elems xs)"

lemma "x : elems xs \<Longrightarrow> EX ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys "
proof(induction xs)
case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case
  proof (cases "x = a")
    case True
    then show ?thesis by fastforce
  next
    case False
    hence "x : elems xs"
    using Cons.prems by auto
  hence " \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys" using Cons by auto
  then obtain ys zs where " xs = ys @ x # zs \<and> x \<notin> elems ys" by blast
  hence "a # xs = a # ys @ x # zs \<and> x \<notin> elems (a # ys)" using False by auto
  thus ?thesis
  by (metis append_Cons)
  qed
qed

(* Exercise 4.7 *)

datatype alpha = a | b

type_synonym word = "alpha list"

inductive S :: "word  \<Rightarrow> bool" where
Sempty : "S Nil"
| Sconj : " S w \<Longrightarrow> S ( a # w @ [b]) "
| Sdouble : " S w \<Longrightarrow> S u  \<Longrightarrow> S (w @ u)"

fun balanced :: "nat \<Rightarrow> word \<Rightarrow> bool" where
"balanced 0 Nil = True"
| "balanced n (Cons a w) = balanced (Suc n) w"
| "balanced (Suc n) (Cons b w) = balanced n w"
| "balanced _ _ = False"

lemma replicate_prop1 : "replicate (Suc n) a @ b # w = (replicate n a) @ a # b # w"
proof -
  show ?thesis
  by (simp add: replicate_app_Cons_same)
qed

lemma Insert_ab:
  assumes u: "S u"
  shows "\<And> v w. u = v @ w \<Longrightarrow> S (v @ (a # (b # w))) "
using u
proof(induct)
case (Sempty) thus ?case
  using S.Sempty Sconj by fastforce
next
case (Sconj u)
have uS: "S u"
and IH: "\<And> v w. u = v @ w \<Longrightarrow> S (v @ a # b # w) " by fact+
  have asm: "a # u @ [b] = v @ w" using Sconj by blast
show "S(v @ a # b # w)"
proof (cases v)
case Nil
hence "w = a # u @ [b]" using asm
  using Sconj.prems by simp
hence "S w" using uS
  using S.Sconj by auto
hence "S ([a,b] @ w)"
  using S.Sconj Sdouble Sempty by force
thus ?thesis using Nil by simp
next
case (Cons x v')
show ?thesis
proof (cases w rule:rev_cases)
case Nil
from uS have "S((a # u @ [b]) @ [a,b])"
  by (metis S.Sconj Sdouble Sempty append_Nil)
thus ?thesis using Nil Cons asm by auto
next
case (snoc w' y)
hence u: "u = v' @ w'" and [simp]: "x = a & y = b"
  using Cons asm by auto
have "S(v' @ a # b # w')" using Sconj.hyps and u
hence "S(a # (v' @ a # b # w') @ [b])" using Sconj.prems by blast
thus ?thesis using Sconj.prems
  by (metis S.simps \<open>x = a \<and> y = b\<close> append.assoc append_Cons local.Cons snoc)
qed
qed
next
case (Sdouble v' w')
have v'S: "S v'" and w'S: "S w'"
and IHv: "\<And> v w. v' = v @ w \<Longrightarrow> S(v @ a # b # w)"
and IHw: "\<And> v w. w' = v @ w \<Longrightarrow> S(v @ a # b # w)" by fact+
have asm: "v' @ w' = v @ w" using Sdouble by blast
then obtain r where "v' = v @ r \<and> r @ w' = w \<or> v' @ r = v \<and> w' = r @ w" (is "?A \<or> ?B")
by (auto simp:append_eq_append_conv2)
thus "S(v @ a # b # w)"
proof
assume A: ?A
hence "S(v @ a # b # r)" using IHv using Sdouble.prems by blast
hence "S((v @ a # b # r) @ w')" using w'S S.Sdouble S.intros(3) by blast
thus ?thesis using A by auto
next
assume B: ?B
  hence "S(r @ a # b # w)" using Sdouble.prems IHw by blast
  have "S(v' @ (r @ a # b # w))" using v'S S.Sdouble S.intros(3) \<open>S (r @ a # b # w)\<close> by blast
thus ?thesis using B by auto
qed
qed

lemma balanced_add_b: "balanced n w \<Longrightarrow> balanced (Suc n) (w @ [b])"
proof(induction n w rule: balanced.induct)
case 1
  then show ?case by auto
next
case (2 n w)
  then show ?case by simp
next
  case (3 n w)
then show ?case by simp
next
  case ("4_1" v)
  then show ?case by simp
next
case ("4_2" va)
then show ?case by simp
qed

lemma balanced_append: "balanced n x \<Longrightarrow> balanced 0 y \<Longrightarrow> balanced n (x @ y)"
proof(induction n x rule: balanced.induct)
case 1
  then show ?case by auto
next
  case (2 n w)
then show ?case by simp
next
  case (3 n w)
  then show ?case by simp
next
case ("4_1" v)
then show ?case by simp
next
  case ("4_2" va)
  then show ?case by simp
qed

lemma replicate_pinch: "m < n \<Longrightarrow> replicate n x = replicate m x @ replicate (n - m) x"

  by (metis add_diff_inverse_nat less_imp_not_less replicate_add)

lemma append_pinch:
"length zs < length xs \<Longrightarrow> xs @ ys = zs @ ws \<Longrightarrow> EX us. xs = zs @ us"
  by (metis append_eq_append_conv_if id_take_nth_drop nat_less_le)

theorem "balanced n w = S (replicate n a @ w) "
proof
  show "balanced n w \<Longrightarrow> S (replicate n a @ w)"
  proof(induction n w rule: balanced.induct)
case 1
  then show ?case
  by (simp add: Sempty)
next
  case (2 n w)
  then show ?case
  by (simp add: replicate_app_Cons_same)
next
  case (3 n w)
  hence c1: "S (replicate n a @ w)" by simp
  have c2: "replicate (Suc n) a @ b # w = replicate n a @ a # b # w" using replicate_prop1 by auto
  have  c3: "S(replicate n a @ a # b # w)" using Insert_ab c1 by simp
  thus ?case using c2 by auto
next
  case ("4_1" v)
  then show ?case by simp
next
  case ("4_2" va)
  then show ?case by simp
qed
next
  show "S (replicate n a @ w) \<Longrightarrow> balanced n w"
  proof(induction "replicate n a @ w" arbitrary: n w rule: S.induct)
case Sempty
then show ?case by simp
next
  case (Sconj u)
  thus ?case
  proof (cases n)
    case 0
    then have "balanced 0 u" using Sconj(2) by auto
    thus ?thesis using 0 Sconj(3) balanced_add_b by auto
  next
    case (Suc k)
    then obtain z where p: "z @ [b] = w" using Sconj(3)
      by (metis Nil_is_append_conv alpha.distinct(1) append_butlast_last_id last.simps last_appendR
list.distinct(1) replicate_app_Cons_same)
    hence "u = replicate k a @ z" using Sconj(3) Suc by auto
    hence "balanced k z" using Sconj(2) by simp
    thus ?thesis using Suc p balanced_add_b by auto
  qed
next
  case (Sdouble x y)
  then show ?case
  proof (cases "x = Nil")
    case True
then show ?thesis using Sdouble.hyps(4) Sdouble.hyps(5) by auto
next
case False
  then show ?thesis
  proof (cases " length x < n")
    case True
    hence "x @ y = replicate (length x) a @ replicate (n - length x) a @ w" using Sdouble(5)
      by (simp add: replicate_pinch)
    hence "x = replicate (length x) a" by auto
    hence False using False Sdouble(1)
      by (metis Sdouble.hyps(2) append.right_neutral balanced.simps(4) lessI less_Suc_eq_0_disj
replicate_empty)
    thus ?thesis by blast
next
case False
  then obtain z' where p': "x = replicate n a @ z'" using Sdouble(5) append_pinch
  by (metis append_Nil2 append_eq_append_conv length_replicate linorder_neqE_nat)
  hence L : "balanced n z'" by (simp add: Sdouble.hyps(2))
  have R : "balanced 0 y"  by (simp add: Sdouble.hyps(4))
  from p' and Sdouble(5) have "w = z' @ y" by auto
  hence "balanced n w" using balanced_append L R by blast
  thus ?thesis by auto
qed
qed
qed
qed

end


theory DiscMaths
  imports Main
begin

text \<open>Section 1.2 Question 7(c)\<close>

lemma dvd_linear_comb:
  fixes d::int
  assumes "d dvd m" and "d dvd n"
  shows "d dvd (k*m + l*n)"
proof -
  from \<open>d dvd m\<close> obtain i where "m = d*i"
    using dvdE by blast
  moreover from \<open>d dvd n\<close> obtain j where "n = d*j"
    using dvdE by blast
  ultimately have "k*m + l*n = d*(k*i + l*j)"
    using int_distrib by simp
  thus "d dvd (k*m + l*n)"
    using dvdI by blast
qed

text \<open>Euclid's algorithm\<close>

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

text \<open>Definition of the GCD\<close>

definition gcd_props :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "gcd_props m n x \<equiv> (x dvd m) \<and> (x dvd n) \<and> (\<forall>d. d dvd m \<and> d dvd n \<longrightarrow> d dvd x)"

text \<open>Proof that Euclid's algorithm returns the GCD\<close>

lemma euclid_gcd_props:
  shows "gcd_props m n (gcd m n)"
proof -
  have "(gcd m n) dvd m \<and> (gcd m n) dvd n"
  proof(induction m n rule: gcd.induct)
    case (1 m)
    then show ?case by simp
  next
    case (2 m v)
    then show ?case using dvd_mod_imp_dvd by auto
  qed
  moreover have "\<forall>d. d dvd m \<and> d dvd n \<longrightarrow> d dvd (gcd m n)"
  proof(induction m n rule: gcd.induct)
    case (1 m)
    then show ?case by simp
  next
    case (2 m v)
    then show ?case by (simp add: dvd_mod)
  qed
  ultimately show "gcd_props m n (gcd m n)" by (simp add: gcd_props_def)
qed

text \<open>Properties of GCD: commutativity, linearity, associativity\<close>

lemma gcd_commute:
  shows "gcd m n = gcd n m"
proof -
  fix x::nat
  have "gcd_props m n x \<longleftrightarrow> gcd_props n m x"
    using gcd_props_def by auto
  thus "gcd m n = gcd n m"
    using dvd_antisym euclid_gcd_props gcd_props_def by auto
qed

lemma gcd_linear:
  shows "i * (gcd m n) = gcd (i*m) (i*n)"
proof(induction m n rule: gcd.induct)
  case (1 m)
  then show ?case by simp
next
  case (2 m v)
  then show ?case by (metis divisors_zero gcd.elims mult_eq_if mult_mod_right nat.simps(3))
qed

lemma gcd_assoc:
  shows "gcd l (gcd m n) = gcd (gcd l m) n"
by (meson dvd_antisym dvd_trans euclid_gcd_props gcd_props_def)

text \<open>Section 3.2 Question 2\<close>

lemma gcd_coprime_prod:
  assumes "gcd a c = 1"
  shows "gcd (a*b) c = gcd b c"
proof -
  have "gcd b c = gcd (b * (gcd a c)) c"
    using assms by simp
  moreover have "... = gcd (gcd (b*a) (b*c)) c"
    by (simp add: gcd_linear)
  moreover have "... = gcd (a*b) (gcd (b*c) c)"
    by (simp add: gcd_assoc mult.commute)
  moreover have "... = gcd (a*b) (c*(gcd b 1))"
    by (metis gcd_linear mult.commute mult.right_neutral)
  ultimately show "gcd (a*b) c = gcd b c"
    by simp
qed

end


theory Complete
     imports Main
begin

text \<open> Let's work with skeletons of binary trees where neither the leaves
(``tip'') nor the nodes contain any information: \<close>

datatype tree = Tp | Nd tree tree

text \<open> Define a function @{term tips} that counts the tips of a tree, and a
function @{term height} that computes the height of a tree. \<close>

primrec tips :: "tree \<Rightarrow> nat"
  where
"tips Tp = 1" |
"tips (Nd l r) = tips l + tips r"

primrec height :: "tree \<Rightarrow> nat"
  where
"height Tp = 0" |
"height (Nd l r) = 1 + max (height l) (height r)"

text \<open> Complete binary trees of a given height are generated as follows: \<close>

primrec cbt :: "nat \<Rightarrow> tree" where
"cbt 0       = Tp" |
"cbt (Suc n) = Nd (cbt n) (cbt n)"

text \<open> We will now focus on these complete binary trees.

Instead of generating complete binary trees, we can also \emph{test} if a
binary tree is complete.  Define a function @{term "iscbt f"} (where @{term f}
is a function on trees) that checks for completeness:  @{term Tp} is complete,
and @{term"Nd l r"} is complete iff @{term l} and @{term r} are complete and
@{prop"f l = f r"}. \<close>

primrec iscbt :: "(tree \<Rightarrow> 'a) \<Rightarrow> tree \<Rightarrow> bool"
  where
"iscbt _ Tp = True" |
"iscbt f (Nd l r) = ((iscbt f l) \<and> (iscbt f r) \<and> ((f l) = (f r)))"

text \<open> We now have 3 functions on trees, namely @{term tips}, @{term height}
and @{term size}.  The latter is defined automatically -- look it up in the
tutorial.  Thus we also have 3 kinds of completeness:  complete wrt.\ @{term
tips}, complete wrt.\ @{term height} and complete wrt.\ @{term size}.  Show
that
\begin{itemize}
\item the 3 notions are the same (e.g.\ @{prop "iscbt tips t = iscbt size t"}),
      and
\item the 3 notions describe exactly the trees generated by @{term cbt}:  the
      result of @{term cbt} is complete (in the sense of @{term iscbt}, wrt.\
      any function on trees), and if a tree is complete in the sense of @{term
      iscbt}, it is the result of @{term cbt} (applied to a suitable number~--
      which one?).
\end{itemize}

Hints:
\begin{itemize}
\item Work out and prove suitable relationships between @{term tips}, @{term
      height} und @{term size}.

\item If you need lemmas dealing only with the basic arithmetic operations
      (@{text"+"}, @{text"*"}, @{text"^"} etc), you may ``prove'' them with the
      command @{text sorry}, if neither @{text arith} nor you can find a proof.
      Not @{text "apply sorry"}, just @{text sorry}.

\item You do not need to show that every notion is equal to every other notion.
      It suffices to show that $A = C$ und $B = C$ -- $A = B$ is a trivial
      consequence.  However, the difficulty of the proof will depend on which
      of the equivalences you prove.

\item There is @{text"\<and>"} and @{text"\<longrightarrow>"}.
\end{itemize} \<close>

lemma tips_size_equiv:"tips t = size t + 1"
  apply (induction t) by auto

value "(1^1)::nat"

lemma tips_tips_height_equiv:"iscbt tips t \<Longrightarrow> tips t = 2^(height t)"
  apply (induction t) by auto

lemma height_tips_height_equiv:"iscbt height t \<Longrightarrow> tips t = 2^(height t)"
  apply (induction t) by auto

lemma size_size_height_equiv:"iscbt height t \<Longrightarrow> size t  = (2^(height t)) - 1"
  apply (induction t)
   apply simp_all
  by (metis Suc_diff_Suc add_is_1 minus_nat.diff_0 mult_2 not_gr0 numeral_2_eq_2
      old.nat.distinct(2) power_not_zero trans_less_add2 zero_less_diff)

lemma "iscbt tips t = iscbt size t"
  apply (induction t)
  by (auto simp add: tips_size_equiv)

lemma "iscbt tips t = iscbt height t"
  apply (induction t)
  by (auto simp add: height_tips_height_equiv)

text \<open> Find a function @{term f} such that @{term "iscbt f"} is different from
@{term "iscbt size"}. \<close>

lemma "iscbt (\<lambda> t. size t = 2) \<noteq> iscbt size"
  apply (rule notI)
  apply (drule cong[where x="Nd Tp (Nd Tp Tp)"])
   apply simp
  by simp

end


header {* Solutions to Chapter 2 of "Concrete Semantics" *}

theory Chap_two imports Main begin

declare [[names_short]]

(* 2.1 *)

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

(* 2.2 *)

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

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

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

theorem double_add: "add n n = double n"
apply(induction n)
apply(auto)
done

(* 2.3 *)

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

lemma count_less: "count y xs \<le> length xs"
apply(induction xs)
apply(auto)
done

(* 2.4 *)

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

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

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

lemma reverse_reverse: "reverse (reverse xs) = xs"
apply(induction xs)
apply(auto)
done

(* 2.5 *)

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

lemma sum_is: "sum n = n * (n + 1) div 2"
apply(induction n)
apply(auto)
done

(* 2.6 *)

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

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

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

theorem listsumcontents_treesum: "listsum (contents t) = treesum t"
apply (induction t)
apply (auto)
done

(* 2.7 *)

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

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

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

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

theorem pre_mirror_rev_post: "pre_order (mirror xs) = rev (post_order xs)"
apply (induction xs)
apply (auto)
done

(* 2.8 *)

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

theorem map_intersperse: "map f (intersperse a l) = intersperse (f a) (map f l)"
apply (induction l rule:intersperse.induct)
apply (auto)
done

(* 2.9 *)

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

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

(* 2.10 *)

datatype tree0 = Tip | Node tree0 tree0

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

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

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

(* 2.11 *)

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

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var x = x" |
"eval (Const k) x = k" |
"eval (Add p q) x = eval p x + eval q x" |
"eval (Mult p q) x = eval p x * eval q x"

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

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

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

fun vmult :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"vmult [] xs = []" |
"vmult (x # xs) ys = vsum (scalar_mult x ys) (0 # vmult xs ys)"

fun coeffs :: "exp \<Rightarrow> int list" where
"coeffs Var = [0, 1]" |
"coeffs (Const k) = [k]" |
"coeffs (Add p q) = vsum (coeffs p) (coeffs q)" |
"coeffs (Mult p q) = vmult (coeffs p) (coeffs q)"

lemma evalp_additive[simp]: "evalp (vsum xs ys) a = evalp xs a + evalp ys a"
apply (induction rule:vsum.induct)
apply (auto simp add:Int.int_distrib)
done

lemma eval_preserves_mult[simp]: "evalp (scalar_mult x ys) a = x * evalp ys a"
apply (induction ys)
apply (auto simp add:Int.int_distrib)
done

lemma evalp_multiplicative[simp]: "evalp (vmult xs ys) a = evalp xs a * evalp ys a"
apply (induction xs)
apply (auto simp add:Int.int_distrib)
done

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

end


theory Roy_Floyd_Warshall
imports Main
begin

section \<open>Transitive closure algorithm\<close>

text \<open>
  The Roy-Floyd-Warshall algorithm takes a finite relation as input and produces
  its transitive closure as output. It iterates over all elements of the field
  of the relation and maintains a cumulative approximation of the result: step
  @{text 0} starts with the original relation, and step @{text "Suc n"} connects
  all paths over the intermediate element @{text n}. The final approximation
  coincides with the full transitive closure.

  This algorithm is often named after ``Floyd'', ``Warshall'', or
  ``Floyd-Warshall'', but the earliest known description is due to B. Roy
  @{cite "Roy:1959"}.

  \medskip Subsequently we use a direct mathematical model of the relation,
  bypassing matrices and arrays that are usually seen in the literature. This is
  more efficient for sparse relations: only the adjacency for immediate
  predecessors and successors needs to be maintained, not the square of all
  possible combinations. Moreover we do not have to worry about mutable data
  structures in a multi-threaded environment. See also the graph implementation
  in the Isabelle sources @{file "$ISABELLE_HOME/src/Pure/General/graph.ML"} and
  @{file "$ISABELLE_HOME/src/Pure/General/graph.scala"}.
\<close>

type_synonym relation = "(nat \<times> nat) set"

fun steps :: "relation \<Rightarrow> nat \<Rightarrow> relation"
where
  "steps rel 0 = rel"
| "steps rel (Suc n) =
    steps rel n \<union> {(x, y). (x, n) \<in> steps rel n \<and> (n, y) \<in> steps rel n}"

text \<open>Implementation view on the relation:\<close>

definition preds :: "relation \<Rightarrow> nat \<Rightarrow> nat set"
  where "preds rel y = {x. (x, y) \<in> rel}"

definition succs :: "relation \<Rightarrow> nat \<Rightarrow> nat set"
  where "succs rel x = {y. (x, y) \<in> rel}"

lemma
  "steps rel (Suc n) =
    steps rel n \<union> {(x, y). x \<in> preds (steps rel n) n \<and> y \<in> succs (steps rel n) n}"
  by (simp add: preds_def succs_def)

text \<open>
  The main function requires an upper bound for the iteration, which
  is left unspecified here (via Hilbert's choice).
\<close>

definition is_bound :: "relation \<Rightarrow> nat \<Rightarrow> bool"
  where "is_bound rel n \<longleftrightarrow> (\<forall>m \<in> Field rel. m < n)"

definition "transitive_closure rel = steps rel (SOME n. is_bound rel n)"

section \<open>Correctness proof\<close>

subsection \<open>Miscellaneous lemmas\<close>

lemma finite_bound:
  assumes "finite rel"
  shows "\<exists>n. is_bound rel n"
  using assms
proof induct
  case empty
  then show ?case by (simp add: is_bound_def)
next
  case (insert p rel)
  then obtain n where n: "\<forall>m \<in> Field rel. m < n"
    unfolding is_bound_def by blast
  obtain x y where "p = (x, y)" by (cases p)
  then have "\<forall>m \<in> Field (insert p rel). m < max (Suc x) (max (Suc y) n)"
    using n by auto
  then show ?case
    unfolding is_bound_def by blast
qed

lemma steps_Suc: "(x, y) \<in> steps rel (Suc n) \<longleftrightarrow>
  (x, y) \<in> steps rel n \<or> (x, n) \<in> steps rel n \<and> (n, y) \<in> steps rel n"
  by auto

lemma steps_cases:
  assumes "(x, y) \<in> steps rel (Suc n)"
  obtains (copy) "(x, y) \<in> steps rel n"
    | (step) "(x, n) \<in> steps rel n" and "(n, y) \<in> steps rel n"
  using assms by auto

lemma steps_rel: "(x, y) \<in> rel \<Longrightarrow> (x, y) \<in> steps rel n"
  by (induct n) auto

subsection \<open>Bounded closure\<close>

text \<open>
  The bounded closure connects all transitive paths over elements below a given
  bound. For an upper bound of the relation, this coincides with the full
  transitive closure.
\<close>

inductive_set Clos :: "relation \<Rightarrow> nat \<Rightarrow> relation"
  for rel :: relation and n :: nat
where
  base: "(x, y) \<in> rel \<Longrightarrow> (x, y) \<in> Clos rel n"
| step: "(x, z) \<in> Clos rel n \<Longrightarrow> (z, y) \<in> Clos rel n \<Longrightarrow> z < n \<Longrightarrow>
    (x, y) \<in> Clos rel n"

theorem Clos_closure:
  assumes "is_bound rel n"
  shows "(x, y) \<in> Clos rel n \<longleftrightarrow> (x, y) \<in> rel\<^sup>+"
proof
  assume "(x, y) \<in> Clos rel n"
  then show "(x, y) \<in> rel\<^sup>+" by induct simp_all
next
  assume "(x, y) \<in> rel\<^sup>+"
  then show "(x, y) \<in> Clos rel n"
  proof (induct rule: trancl_induct)
    case (base y)
    then show ?case by (rule Clos.base)
  next
    case (step y z)
    from \<open>(y, z) \<in> rel\<close> have 1: "(y, z) \<in> Clos rel n" by (rule base)
    from \<open>(y, z) \<in> rel\<close> and \<open>is_bound rel n\<close> have 2: "y < n"
      unfolding is_bound_def Field_def by blast
    from step(3) 1 2 show ?case by (rule Clos.step)
  qed
qed

lemma Clos_Suc:
  assumes "(x, y) \<in> Clos rel n"
  shows "(x, y) \<in> Clos rel (Suc n)"
  using assms by induct (auto intro: Clos.intros)

text \<open>
  In each step of the algorithm the approximated relation is exactly the
  bounded closure.
\<close>

theorem steps_Clos_equiv: "(x, y) \<in> steps rel n \<longleftrightarrow> (x, y) \<in> Clos rel n"
proof (induct n arbitrary: x y)
  case 0
  show ?case
  proof
    assume "(x, y) \<in> steps rel 0"
    then have "(x, y) \<in> rel" by simp
    then show "(x, y) \<in> Clos rel 0" by (rule Clos.base)
  next
    assume "(x, y) \<in> Clos rel 0"
    then show "(x, y) \<in> steps rel 0" by cases simp_all
  qed
next
  case (Suc n)
  show ?case
  proof
    assume "(x, y) \<in> steps rel (Suc n)"
    then show "(x, y) \<in> Clos rel (Suc n)"
    proof (cases rule: steps_cases)
      case copy
      with Suc(1) have "(x, y) \<in> Clos rel n" ..
      then show ?thesis by (rule Clos_Suc)
    next
      case step
      with Suc have "(x, n) \<in> Clos rel n" and "(n, y) \<in> Clos rel n"
        by simp_all
      then have "(x, n) \<in> Clos rel (Suc n)" and "(n, y) \<in> Clos rel (Suc n)"
        by (simp_all add: Clos_Suc)
      then show ?thesis by (rule Clos.step) simp
    qed
  next
    assume "(x, y) \<in> Clos rel (Suc n)"
    then show "(x, y) \<in> steps rel (Suc n)"
    proof induct
      case (base x y)
      then show ?case by (simp add: steps_rel)
    next
      case (step x z y)
      with Suc show ?case
        by (auto simp add: steps_Suc less_Suc_eq intro: Clos.step)
    qed
  qed
qed

subsection \<open>Main theorem\<close>

text \<open>
  The main theorem follows immediately from the key observations above. Note
  that the assumption of finiteness gives a bound for the iteration, although
  the details are left unspecified. A concrete implementation could choose the
  the maximum element + 1, or iterate directly over the data structures for
  the @{term preds} and @{term succs} implementation.
\<close>

theorem transitive_closure_correctness:
  assumes "finite rel"
  shows "transitive_closure rel = rel\<^sup>+"
proof -
  let ?N = "SOME n. is_bound rel n"
  have is_bound: "is_bound rel ?N"
    by (rule someI_ex) (rule finite_bound [OF \<open>finite rel\<close>])
  {
    fix x y
    have "(x, y) \<in> steps rel ?N \<longleftrightarrow> (x, y) \<in> Clos rel ?N"
      by (rule steps_Clos_equiv)
    also have "\<dots> \<longleftrightarrow> (x, y) \<in> rel\<^sup>+"
      using is_bound by (rule Clos_closure)
    finally have "(x, y) \<in> steps rel ?N \<longleftrightarrow> (x, y) \<in> rel\<^sup>+" .
  }
  then show ?thesis unfolding transitive_closure_def by auto
qed

section \<open>Alternative formulation\<close>

text \<open>
  The core of the algorithm may be expressed more declaratively as follows,
  using an inductive definition to imitate a logic-program.  This is equivalent
  to the function specification @{term steps} from above.
\<close>

inductive Steps :: "relation \<Rightarrow> nat \<Rightarrow> nat \<times> nat \<Rightarrow> bool"
  for rel :: relation
where
  base: "(x, y) \<in> rel \<Longrightarrow> Steps rel 0 (x, y)"
| copy: "Steps rel n (x, y) \<Longrightarrow> Steps rel (Suc n) (x, y)"
| step: "Steps rel n (x, n) \<Longrightarrow> Steps rel n (n, y) \<Longrightarrow> Steps rel (Suc n) (x, y)"

lemma steps_equiv: "(x, y) \<in> steps rel n \<longleftrightarrow> Steps rel n (x, y)"
proof
  assume "(x, y) \<in> steps rel n"
  then show "Steps rel n (x, y)"
  proof (induct n arbitrary: x y)
    case 0
    then have "(x, y) \<in> rel" by simp
    then show ?case by (rule base)
  next
    case (Suc n)
    from Suc(2) show ?case
    proof (cases rule: steps_cases)
      case copy
      with Suc(1) have "Steps rel n (x, y)" .
      then show ?thesis by (rule Steps.copy)
    next
      case step
      with Suc(1) have "Steps rel n (x, n)" and "Steps rel n (n, y)"
        by simp_all
      then show ?thesis by (rule Steps.step)
    qed
  qed
next
  assume "Steps rel n (x, y)"
  then show "(x, y) \<in> steps rel n"
    by induct simp_all
qed

end


(*  Title:       Deriving class instances for datatypes
    Author:      Christian Sternagel and René Thiemann  <christian.sternagel|rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)
section \<open>Comparisons\<close>

subsection \<open>Comparators and Linear Orders\<close>

theory Comparator
imports Main
begin

text \<open>Instead of having to define a strict and a weak linear order, @{term "((<), (\<le>))"},
 one can alternative use a comparator to define the linear order, which may deliver
 three possible outcomes when comparing two values.\<close>

datatype order = Eq | Lt | Gt

type_synonym 'a comparator = "'a \<Rightarrow> 'a \<Rightarrow> order"

text \<open>In the following, we provide the obvious definitions how to switch between
  linear orders and comparators.\<close>

definition lt_of_comp :: "'a comparator \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "lt_of_comp acomp x y = (case acomp x y of Lt \<Rightarrow> True | _ \<Rightarrow> False)"

definition le_of_comp :: "'a comparator \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "le_of_comp acomp x y = (case acomp x y of Gt \<Rightarrow> False | _ \<Rightarrow> True)"

definition comp_of_ords :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a comparator" where
  "comp_of_ords le lt x y = (if lt x y then Lt else if le x y then Eq else Gt)"

lemma comp_of_ords_of_le_lt[simp]: "comp_of_ords (le_of_comp c) (lt_of_comp c) = c"
  by (intro ext, auto simp: comp_of_ords_def le_of_comp_def lt_of_comp_def split: order.split)

lemma lt_of_comp_of_ords: "lt_of_comp (comp_of_ords le lt) = lt"
  by (intro ext, auto simp: comp_of_ords_def le_of_comp_def lt_of_comp_def split: order.split)

lemma le_of_comp_of_ords_gen: "(\<And> x y. lt x y \<Longrightarrow> le x y) \<Longrightarrow> le_of_comp (comp_of_ords le lt) = le"
  by (intro ext, auto simp: comp_of_ords_def le_of_comp_def lt_of_comp_def split: order.split)

lemma le_of_comp_of_ords_linorder: assumes "class.linorder le lt"
  shows "le_of_comp (comp_of_ords le lt) = le"
proof -
  interpret linorder le lt by fact
  show ?thesis by (rule le_of_comp_of_ords_gen) simp
qed

fun invert_order:: "order \<Rightarrow> order" where
  "invert_order Lt = Gt" |
  "invert_order Gt = Lt" |
  "invert_order Eq = Eq"

locale comparator =
  fixes comp :: "'a comparator"
  assumes sym: "invert_order (comp x y) = comp y x"
    and weak_eq: "comp x y = Eq \<Longrightarrow> x = y"
    and trans: "comp x y = Lt \<Longrightarrow> comp y z = Lt \<Longrightarrow> comp x z = Lt"
begin

lemma eq: "(comp x y = Eq) = (x = y)"
proof
  assume "x = y"
  with sym [of y y] show "comp x y = Eq" by (cases "comp x y") auto
qed (rule weak_eq)

lemma comp_same [simp]:
  "comp x x = Eq"
  by (simp add: eq)

abbreviation "lt \<equiv> lt_of_comp comp"
abbreviation "le \<equiv> le_of_comp comp"

lemma linorder: "class.linorder le lt"
proof
  note [simp] = lt_of_comp_def le_of_comp_def
  fix x y z :: 'a
  show "lt x y = (le x y \<and> \<not> le y x)"
    using sym [of x y] by (cases "comp x y") (simp_all)
  show "le x y \<or> le y x"
    using sym [of x y] by (cases "comp x y") (simp_all)
  show "le x x" using eq [of x x] by (simp)
  show "le x y \<Longrightarrow> le y x \<Longrightarrow> x = y"
    using sym [of x y] by (cases "comp x y") (simp_all add: eq)
  show "le x y \<Longrightarrow> le y z \<Longrightarrow> le x z"
    by (cases "comp x y" "comp y z" rule: order.exhaust [case_product order.exhaust])
       (auto dest: trans simp: eq)
qed

sublocale linorder le lt
  by (rule linorder)

lemma Gt_lt_conv: "comp x y = Gt \<longleftrightarrow> lt y x"
  unfolding lt_of_comp_def sym[of x y, symmetric]
  by (cases "comp x y", auto)
lemma Lt_lt_conv: "comp x y = Lt \<longleftrightarrow> lt x y"
  unfolding lt_of_comp_def by (cases "comp x y", auto)
lemma eq_Eq_conv: "comp x y = Eq \<longleftrightarrow> x = y"
  by (rule eq)
lemma nGt_le_conv: "comp x y \<noteq> Gt \<longleftrightarrow> le x y"
  unfolding le_of_comp_def by (cases "comp x y", auto)
lemma nLt_le_conv: "comp x y \<noteq> Lt \<longleftrightarrow> le y x"
  unfolding le_of_comp_def sym[of x y, symmetric] by (cases "comp x y", auto)
lemma nEq_neq_conv: "comp x y \<noteq> Eq \<longleftrightarrow> x \<noteq> y"
  using eq_Eq_conv[of x y] by simp

lemmas le_lt_convs =  nLt_le_conv nGt_le_conv Gt_lt_conv Lt_lt_conv eq_Eq_conv nEq_neq_conv

lemma two_comparisons_into_case_order:
  "(if le x y then (if x = y then P else Q) else R) = (case_order P Q R (comp x y))"
  "(if le x y then (if y = x then P else Q) else R) = (case_order P Q R (comp x y))"
  "(if le x y then (if le y x then P else Q) else R) = (case_order P Q R (comp x y))"
  "(if le x y then (if lt x y then Q else P) else R) = (case_order P Q R (comp x y))"
  "(if lt x y then Q else (if le x y then P else R)) = (case_order P Q R (comp x y))"
  "(if lt x y then Q else (if lt y x then R else P)) = (case_order P Q R (comp x y))"
  "(if lt x y then Q else (if x = y then P else R)) = (case_order P Q R (comp x y))"
  "(if lt x y then Q else (if y = x then P else R)) = (case_order P Q R (comp x y))"
  "(if x = y then P else (if lt y x then R else Q)) = (case_order P Q R (comp x y))"
  "(if x = y then P else (if lt x y then Q else R)) = (case_order P Q R (comp x y))"
  "(if x = y then P else (if le y x then R else Q)) = (case_order P Q R (comp x y))"
  "(if x = y then P else (if le x y then Q else R)) = (case_order P Q R (comp x y))"
  by (auto simp: le_lt_convs split: order.splits)

end

lemma comp_of_ords: assumes "class.linorder le lt"
  shows "comparator (comp_of_ords le lt)"
proof -
  interpret linorder le lt by fact
  show ?thesis
    by (unfold_locales, auto simp: comp_of_ords_def split: if_splits)
qed

definition (in linorder) comparator_of :: "'a comparator" where
  "comparator_of x y = (if x < y then Lt else if x = y then Eq else Gt)"

lemma comparator_of: "comparator comparator_of"
  by unfold_locales (auto split: if_splits simp: comparator_of_def)

end