theory ABB
imports "~~/src/HOL/Library/Tree"
begin

text {* Se declara que la función Let como simplificador. *}
declare Let_def [simp]

section "Funciones sobre los árboles binarios de búsqueda (ABB)"

text {* Ejemplos de árboles de búsqueda. *}
abbreviation abb1 :: "int tree"
where
  "abb1 \<equiv> \<langle>\<langle>\<rangle>, 3::int, \<langle>\<langle>\<rangle>, 9, \<langle>\<rangle>\<rangle>\<rangle>"

text {* (pertenece t ) se verifica si x es un elemento del árbol t.  Por
  ejemplo,
     pertenece abb1 3 = True
     pertenece abb1 5 = False
*}
fun pertenece :: "('a::linorder) tree \<Rightarrow> 'a \<Rightarrow> bool"
where
  "pertenece Leaf x         = False"
| "pertenece (Node i a d) x =
    (if x < a then pertenece i x else
     if x > a then pertenece d x
     else True)"

value "pertenece abb1 3"
lemma "pertenece abb1 3 = True" by simp
value "pertenece abb1 5"
lemma "pertenece abb1 5 = False" by simp

text {* (inserta x t) es el ABB obtenido insertando el elemento x en el
  ABB t. Por ejemplo,
     inserta 4 abb1 = \<langle>\<langle>\<rangle>, 3, \<langle>\<langle>\<langle>\<rangle>, 4, \<langle>\<rangle>\<rangle>, 9, \<langle>\<rangle>\<rangle>\<rangle>
     inserta 2 abb1 = \<langle>\<langle>\<langle>\<rangle>, 2, \<langle>\<rangle>\<rangle>, 3, \<langle>\<langle>\<rangle>, 9, \<langle>\<rangle>\<rangle>\<rangle>
     inserta 12 abb1 = \<langle>\<langle>\<rangle>, 3, \<langle>\<langle>\<rangle>, 9, \<langle>\<langle>\<rangle>, 12, \<langle>\<rangle>\<rangle>\<rangle>\<rangle>
*}
fun inserta :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
where
  "inserta x Leaf = Node Leaf x Leaf"
| "inserta x (Node l a r) =
    (if x < a then Node (inserta x l) a r else
     if x > a then Node l a (inserta x r)
     else Node l a r)"

value "inserta 4 abb1"
lemma "inserta 4 abb1 = \<langle>\<langle>\<rangle>, 3, \<langle>\<langle>\<langle>\<rangle>, 4, \<langle>\<rangle>\<rangle>, 9, \<langle>\<rangle>\<rangle>\<rangle>" by simp
value "inserta 2 abb1"
lemma "inserta 2 abb1 = \<langle>\<langle>\<langle>\<rangle>, 2, \<langle>\<rangle>\<rangle>, 3, \<langle>\<langle>\<rangle>, 9, \<langle>\<rangle>\<rangle>\<rangle>" by simp
value "inserta 12 abb1"
lemma "inserta 12 abb1 = \<langle>\<langle>\<rangle>, 3, \<langle>\<langle>\<rangle>, 9, \<langle>\<langle>\<rangle>, 12, \<langle>\<rangle>\<rangle>\<rangle>\<rangle>" by simp

subsection "Corrección funcional"

text {* Prop: Si t es un ABB, entonces son equivalentes:
  · La relación (pertenece t x) se verifica
  · x pertenece al conjunto de los elementos de t. *}
lemma set_tree_pertenece:
  "bst t \<Longrightarrow> pertenece t x = (x \<in> set_tree t)"
apply (induction t)
apply auto
done

text {* Prop.: El conjunto de los elementos de (inserta x t) es igual a
  la unión de {x} y el conjunto de los elementos de t. *}
lemma set_tree_inserta:
  "set_tree (inserta x t) = {x} \<union> set_tree t"
apply (induction t)
apply auto
done

subsection "Conservación del invariante"

text {* Prop: Al insertar un elemento en un ABB se obtiene un ABB. *}
lemma bst_inserta:
  "bst t \<Longrightarrow> bst (inserta x t)"
apply (induction t)
apply (auto simp: set_tree_inserta)
done

section "Reducción del número de comparaciones"

text\<open>Idea: never test for \<open>=\<close> but remember the last value where you
should have tested for \<open>=\<close> but did not. Compare with that value when
you reach a leaf.\<close>

fun pertenece2 :: "('a::linorder) tree \<Rightarrow> 'a option \<Rightarrow> 'a \<Rightarrow> bool"
where
  "pertenece2 Leaf z x =
    (case z of None   \<Rightarrow> False
             | Some y \<Rightarrow> x = y) "
| "pertenece2 (Node l a r) z x =
    (if x < a
     then pertenece2 l z x
     else pertenece2 r (Some a) x)"

lemma pertenece2_Some:
  "\<lbrakk> bst t
   ; \<forall>x \<in> set_tree t. y < x \<rbrakk>
  \<Longrightarrow> pertenece2 t (Some y) x = (pertenece t x \<or> x=y)"
apply (induction t arbitrary: y)
apply auto
done

lemma pertenece2_None:
  "bst t \<Longrightarrow> pertenece2 t None x = pertenece t x"
apply (induction t)
apply (auto simp: pertenece2_Some)
done

section "Árboles con información del tamaño"

text {* Un árbol con información de tamaño es un árbol cuyos elementos
  son pares donde la segunda componente es un número natural (que
  representa el tamaño). *}
type_synonym 'a tree_sz = "('a * nat) tree"

text {* (inv_sz t) se verifica si t es un árbol con información de
  tamaño. *}
fun inv_sz :: "('a::linorder) tree_sz \<Rightarrow> bool"
where
  "inv_sz \<langle>\<rangle> = True"
| "inv_sz \<langle>l, (a,s), r\<rangle> =
    (inv_sz l \<and> inv_sz r \<and> s = size l + size r + 1)"

text {* (sz t) es el tamaño del árbol con información de tamaño t. *}
fun sz :: "'a tree_sz \<Rightarrow> nat"
where
  "sz Leaf             = 0"
| "sz (Node _ (_,s) _) = s"

text {* (un_sz t) es el árbol sin información de tamaño correspondiente
  al árbol con información de tamaño t. *}
abbreviation un_sz :: "'a tree_sz \<Rightarrow> 'a tree"
where
  "un_sz t \<equiv> map_tree fst t"

text {* (ins_sz x t) es el ABB con información de tamaño obtenido
  insertando el elemento x en el ABB con información de tamaño t. *}
fun ins_sz :: "'a::linorder \<Rightarrow> 'a tree_sz \<Rightarrow> 'a tree_sz"
where
  "ins_sz x Leaf = Node Leaf (x,1) Leaf"
| "ins_sz x (Node l (a,s) r) =
    (if x < a
       then let l' = ins_sz x l in Node l' (a, sz l' + sz r + 1) r
     else if x > a
       then let r' = ins_sz x r in Node l (a, sz l + sz r' + 1) r'
     else Node l (a,s) r)"

subsection "Corrección funcional"

text {* El árbol sin información de tamaño obtenido insertado x en t es
  igual que árbol obtenido insertando x en el árbol sin información de
  tamaño correspondiente a t. *}
lemma un_sz_ins_sz:
  "un_sz (ins_sz x t) = inserta x (un_sz t)"
apply (induction t)
apply auto
done

subsection "Conservación del invariante"

text{* Sea t un árbol con información de tamaño. Si el árbol sin
  información de tamaño correspondiente a t es un ABB, entonces también
  los es el árbol sin información de tamaño correspondiente a insertar
  un elemento en t. *}
lemma "bst (un_sz t) \<Longrightarrow> bst (un_sz (ins_sz x t))"
by (simp add: un_sz_ins_sz bst_inserta)

text {* Para los árboles con información de tamaño las funciones six y
  size son equivalentes. *}
lemma sz_size [simp]:
  "inv_sz t \<Longrightarrow> sz t = size t"
apply (induction t)
apply auto
done

text {* Al insertar un elemento en un árbol con información de tamaño se
  obtiene otro árbol con información de tamaño. *}
lemma "inv_sz t \<Longrightarrow> inv_sz (ins_sz x t)"
apply (induction t)
apply (auto)
done

text {* (nth_min t n) es el n-ésimo elemento del árbol con información
  de tamaño t (con los elementos ordenado de manera creciente). *}
fun nth_min :: "('a::linorder) tree_sz \<Rightarrow> nat \<Rightarrow> 'a" where
"nth_min \<langle>l, (a,s), r\<rangle> n =
   (let sl = sz l in
    if n = sl then a else
    if n < sl then nth_min l n
              else nth_min r (n-sl-1))"

text {* Si t es un árbol con información de tamaño tal que su
  correspondiente árbol sin información de tamaño es un ABB y n es menor
  que el tamaño de t, entonces (nth_min t n) es el n-ésimo elemento del
  recorrido inorden del árbol sin información de tamaño correspondiente
  a t. *}
lemma "\<lbrakk> bst (un_sz t)
       ; inv_sz t
       ; n < size t \<rbrakk>
       \<Longrightarrow> nth_min t n = nth (inorder (un_sz t)) n"
apply (induction t arbitrary: n)
apply (auto simp: nth_append)
done

text {* En el lema anterior se puede eliminar la primera hipótesis. *}
lemma "\<lbrakk> inv_sz t
       ;  n < size t \<rbrakk>
       \<Longrightarrow> nth_min t n = nth (inorder (un_sz t)) n"
apply (induction t arbitrary: n)
apply (auto simp: nth_append)
done

section "Compressing the Height of BSTs"

fun compress :: "'a tree \<Rightarrow> 'a tree" where
"compress (Node Leaf a t) =
  (case compress t of
     Node Leaf b u \<Rightarrow> Node (Node Leaf a Leaf) b u |
     u \<Rightarrow> Node Leaf a u)" |
"compress (Node l a r) = Node (compress l) a (compress r)" |
"compress Leaf = Leaf"

(* Another way of saying that \<open>bst\<close> and \<open>set_tree\<close> are preserved: *)
lemma "inorder(compress t) = inorder t"
apply(induction t rule: compress.induct)
apply (auto split: tree.split)
done

lemma "height (compress t) \<le> height t"
apply(induction t rule: compress.induct)
apply (auto split: tree.split)
done

(* What is the correct relationship? *)
lemma "height t \<le> height (compress t)"
oops

section "BST Implementation of Maps"

fun lookup :: "('a::linorder * 'b) tree \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup Leaf x = None" |
"lookup (Node l (a,b) r) x =
  (if x < a then lookup l x else
   if x > a then lookup r x
   else Some b)"

fun update :: "'a \<Rightarrow> 'b \<Rightarrow> ('a::linorder * 'b) tree \<Rightarrow> ('a * 'b) tree" where
"update x y Leaf = Node Leaf (x,y) Leaf" |
"update x y (Node l (a,b) r) =
  (if x < a then Node (update x y l) (a,b) r else
   if x > a then Node l (a,b) (update x y r)
   else Node l (x,y) r)"

subsection "Functional Correctness"

lemma "lookup (update x y t) a = (if x=a then Some y else lookup t a)"
apply(induction t)
apply auto
done

subsection "Preservation of Invariant"

definition "bst1 t = bst (map_tree fst t)"

lemma map_tree_update: "map_tree fst (update x y t) = inserta x (map_tree fst t)"
apply(induction t)
apply auto
done

lemma "bst1 t \<Longrightarrow> bst1(update x y t)"
apply(induction t)
apply (auto simp: bst1_def map_tree_update set_tree_inserta)
done

end


theory Demo4 imports Main begin

subsection{*Inductive definition of the even numbers*}

consts Ev :: "nat set"
inductive Ev
intros
ZeroI: "0 \<in> Ev"
Add2I: "n \<in> Ev \<Longrightarrow> Suc(Suc n) \<in> Ev"

text{* Using the introduction rules: *}
lemma "Suc(Suc(Suc(Suc 0))) \<in> Ev"
apply(rule Add2I)
apply(rule Add2I)
apply(rule ZeroI)
done

text{*A simple inductive proof: *}
lemma "n \<in> Ev \<Longrightarrow> n+n \<in> Ev"
apply(erule Ev.induct)
 apply(simp)
 apply(rule ZeroI)
apply(simp)
apply(rule Add2I)
apply(rule Add2I)
apply(assumption)
done

end


(*  Title:      HOL/Library/Indicator_Function.thy
    Author:     Johannes Hoelzl (TU Muenchen)
*)

section {* Indicator Function *}

theory Indicator_Function
imports Complex_Main
begin

definition "indicator S x = (if x \<in> S then 1 else 0)"

lemma indicator_simps[simp]:
  "x \<in> S \<Longrightarrow> indicator S x = 1"
  "x \<notin> S \<Longrightarrow> indicator S x = 0"
  unfolding indicator_def by auto

lemma indicator_pos_le[intro, simp]: "(0::'a::linordered_semidom) \<le> indicator S x"
  and indicator_le_1[intro, simp]: "indicator S x \<le> (1::'a::linordered_semidom)"
  unfolding indicator_def by auto

lemma indicator_abs_le_1: "\<bar>indicator S x\<bar> \<le> (1::'a::linordered_idom)"
  unfolding indicator_def by auto

lemma indicator_eq_0_iff: "indicator A x = (0::_::zero_neq_one) \<longleftrightarrow> x \<notin> A"
  by (auto simp: indicator_def)

lemma indicator_eq_1_iff: "indicator A x = (1::_::zero_neq_one) \<longleftrightarrow> x \<in> A"
  by (auto simp: indicator_def)

lemma split_indicator: "P (indicator S x) \<longleftrightarrow> ((x \<in> S \<longrightarrow> P 1) \<and> (x \<notin> S \<longrightarrow> P 0))"
  unfolding indicator_def by auto

lemma split_indicator_asm: "P (indicator S x) \<longleftrightarrow> (\<not> (x \<in> S \<and> \<not> P 1 \<or> x \<notin> S \<and> \<not> P 0))"
  unfolding indicator_def by auto

lemma indicator_inter_arith: "indicator (A \<inter> B) x = indicator A x * (indicator B x::'a::semiring_1)"
  unfolding indicator_def by (auto simp: min_def max_def)

lemma indicator_union_arith: "indicator (A \<union> B) x = indicator A x + indicator B x - indicator A x * (indicator B x::'a::ring_1)"
  unfolding indicator_def by (auto simp: min_def max_def)

lemma indicator_inter_min: "indicator (A \<inter> B) x = min (indicator A x) (indicator B x::'a::linordered_semidom)"
  and indicator_union_max: "indicator (A \<union> B) x = max (indicator A x) (indicator B x::'a::linordered_semidom)"
  unfolding indicator_def by (auto simp: min_def max_def)

lemma indicator_disj_union: "A \<inter> B = {} \<Longrightarrow>  indicator (A \<union> B) x = (indicator A x + indicator B x::'a::linordered_semidom)"
  by (auto split: split_indicator)

lemma indicator_compl: "indicator (- A) x = 1 - (indicator A x::'a::ring_1)"
  and indicator_diff: "indicator (A - B) x = indicator A x * (1 - indicator B x::'a::ring_1)"
  unfolding indicator_def by (auto simp: min_def max_def)

lemma indicator_times: "indicator (A \<times> B) x = indicator A (fst x) * (indicator B (snd x)::'a::semiring_1)"
  unfolding indicator_def by (cases x) auto

lemma indicator_sum: "indicator (A <+> B) x = (case x of Inl x \<Rightarrow> indicator A x | Inr x \<Rightarrow> indicator B x)"
  unfolding indicator_def by (cases x) auto

lemma indicator_image: "inj f \<Longrightarrow> indicator (f ` X) (f x) = (indicator X x::_::zero_neq_one)"
  by (auto simp: indicator_def inj_on_def)

lemma
  fixes f :: "'a \<Rightarrow> 'b::semiring_1" assumes "finite A"
  shows setsum_mult_indicator[simp]: "(\<Sum>x \<in> A. f x * indicator B x) = (\<Sum>x \<in> A \<inter> B. f x)"
  and setsum_indicator_mult[simp]: "(\<Sum>x \<in> A. indicator B x * f x) = (\<Sum>x \<in> A \<inter> B. f x)"
  unfolding indicator_def
  using assms by (auto intro!: setsum.mono_neutral_cong_right split: split_if_asm)

lemma setsum_indicator_eq_card:
  assumes "finite A"
  shows "(SUM x : A. indicator B x) = card (A Int B)"
  using setsum_mult_indicator[OF assms, of "%x. 1::nat"]
  unfolding card_eq_setsum by simp

lemma setsum_indicator_scaleR[simp]:
  "finite A \<Longrightarrow>
    (\<Sum>x \<in> A. indicator (B x) (g x) *\<^sub>R f x) = (\<Sum>x \<in> {x\<in>A. g x \<in> B x}. f x::'a::real_vector)"
  using assms by (auto intro!: setsum.mono_neutral_cong_right split: split_if_asm simp: indicator_def)

lemma LIMSEQ_indicator_incseq:
  assumes "incseq A"
  shows "(\<lambda>i. indicator (A i) x :: 'a :: {topological_space, one, zero}) ----> indicator (\<Union>i. A i) x"
proof cases
  assume "\<exists>i. x \<in> A i"
  then obtain i where "x \<in> A i"
    by auto
  then have
    "\<And>n. (indicator (A (n + i)) x :: 'a) = 1"
    "(indicator (\<Union> i. A i) x :: 'a) = 1"
    using incseqD[OF `incseq A`, of i "n + i" for n] `x \<in> A i` by (auto simp: indicator_def)
  then show ?thesis
    by (rule_tac LIMSEQ_offset[of _ i]) simp
qed (auto simp: indicator_def)

lemma LIMSEQ_indicator_UN:
  "(\<lambda>k. indicator (\<Union> i<k. A i) x :: 'a :: {topological_space, one, zero}) ----> indicator (\<Union>i. A i) x"
proof -
  have "(\<lambda>k. indicator (\<Union> i<k. A i) x::'a) ----> indicator (\<Union>k. \<Union> i<k. A i) x"
    by (intro LIMSEQ_indicator_incseq) (auto simp: incseq_def intro: less_le_trans)
  also have "(\<Union>k. \<Union> i<k. A i) = (\<Union>i. A i)"
    by auto
  finally show ?thesis .
qed

lemma LIMSEQ_indicator_decseq:
  assumes "decseq A"
  shows "(\<lambda>i. indicator (A i) x :: 'a :: {topological_space, one, zero}) ----> indicator (\<Inter>i. A i) x"
proof cases
  assume "\<exists>i. x \<notin> A i"
  then obtain i where "x \<notin> A i"
    by auto
  then have
    "\<And>n. (indicator (A (n + i)) x :: 'a) = 0"
    "(indicator (\<Inter>i. A i) x :: 'a) = 0"
    using decseqD[OF `decseq A`, of i "n + i" for n] `x \<notin> A i` by (auto simp: indicator_def)
  then show ?thesis
    by (rule_tac LIMSEQ_offset[of _ i]) simp
qed (auto simp: indicator_def)

lemma LIMSEQ_indicator_INT:
  "(\<lambda>k. indicator (\<Inter>i<k. A i) x :: 'a :: {topological_space, one, zero}) ----> indicator (\<Inter>i. A i) x"
proof -
  have "(\<lambda>k. indicator (\<Inter>i<k. A i) x::'a) ----> indicator (\<Inter>k. \<Inter>i<k. A i) x"
    by (intro LIMSEQ_indicator_decseq) (auto simp: decseq_def intro: less_le_trans)
  also have "(\<Inter>k. \<Inter> i<k. A i) = (\<Inter>i. A i)"
    by auto
  finally show ?thesis .
qed

lemma indicator_add:
  "A \<inter> B = {} \<Longrightarrow> (indicator A x::_::monoid_add) + indicator B x = indicator (A \<union> B) x"
  unfolding indicator_def by auto

lemma of_real_indicator: "of_real (indicator A x) = indicator A x"
  by (simp split: split_indicator)

lemma real_of_nat_indicator: "real (indicator A x :: nat) = indicator A x"
  by (simp split: split_indicator)

lemma abs_indicator: "\<bar>indicator A x :: 'a::linordered_idom\<bar> = indicator A x"
  by (simp split: split_indicator)

lemma mult_indicator_subset:
  "A \<subseteq> B \<Longrightarrow> indicator A x * indicator B x = (indicator A x :: 'a::{comm_semiring_1})"
  by (auto split: split_indicator simp: fun_eq_iff)

lemma indicator_sums:
  assumes "\<And>i j. i \<noteq> j \<Longrightarrow> A i \<inter> A j = {}"
  shows "(\<lambda>i. indicator (A i) x::real) sums indicator (\<Union>i. A i) x"
proof cases
  assume "\<exists>i. x \<in> A i"
  then obtain i where i: "x \<in> A i" ..
  with assms have "(\<lambda>i. indicator (A i) x::real) sums (\<Sum>i\<in>{i}. indicator (A i) x)"
    by (intro sums_finite) (auto split: split_indicator)
  also have "(\<Sum>i\<in>{i}. indicator (A i) x) = indicator (\<Union>i. A i) x"
    using i by (auto split: split_indicator)
  finally show ?thesis .
qed simp

end


theory Concrete_Semantics_2_5_ex11
imports Main
begin

(* Define arithmetic expressions in one variable over integers *)

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

fun eval :: "exp => int => int" where
"eval Var x = x" |
"eval (Const m) x = m" |
"eval (Add e1 e2) x = (eval e1 x) + (eval e2 x)" |
"eval (Mult e1 e2) x = (eval e1 x) * (eval e2 x)"

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

fun a_coeffs :: "int list => int list => int list" where
"a_coeffs Nil Nil = Nil" |
"a_coeffs Nil ys = ys" |
"a_coeffs xs Nil = xs" |
"a_coeffs (x#xs) (y#ys) = (x + y) # (a_coeffs xs ys)"

fun multi_dist_list:: "int => int list => int list" where
"multi_dist_list n Nil = Nil" |
"multi_dist_list n (x#xs) = (n*x)#(multi_dist_list n xs)"

fun m_coeffs :: "int list => int list => int list" where
"m_coeffs Nil ys = Nil" |
"m_coeffs (x#xs) ys = a_coeffs (multi_dist_list x ys)  (0 # m_coeffs xs ys)"

fun coeffs :: "exp => int list" where
"coeffs Var = [0, 1]" |
"coeffs (Const n) = [n]" |
"coeffs (Add a b) = a_coeffs (coeffs(a)) (coeffs(b))" |
"coeffs (Mult a b) = m_coeffs (coeffs(a)) (coeffs(b))"

lemma evalp_coeffs_to_eval_add : "evalp (a_coeffs xs ys) x = evalp xs x + evalp ys x"
apply(induction xs rule: a_coeffs.induct)
apply(auto simp add: algebra_simps)
(* apply(simp add:algebra_simps) *)
done

lemma evalp_m_d_l: "evalp (multi_dist_list a ys) x = a * evalp ys x"
apply(induction ys )
apply(auto simp add: algebra_simps)
done

lemma evalp_coeffs_to_eval_multi: "evalp (m_coeffs xs ys) x = evalp xs x * evalp ys x"
apply(induction xs )
apply(auto simp add:algebra_simps evalp_m_d_l evalp_coeffs_to_eval_add)
done

(*
If not proved internal cases,
2. \<And>e1 e2 x.
       (\<And>x. evalp (coeffs e1) x = eval e1 x) \<Longrightarrow>
       (\<And>x. evalp (coeffs e2) x = eval e2 x) \<Longrightarrow>
       evalp (a_coeffs (coeffs e1) (coeffs e2)) x = eval e1 x + eval e2 x
 3. \<And>e1 e2 x.
       (\<And>x. evalp (coeffs e1) x = eval e1 x) \<Longrightarrow>
       (\<And>x. evalp (coeffs e2) x = eval e2 x) \<Longrightarrow>
       evalp (m_coeffs (coeffs e1) (coeffs e2)) x = eval e1 x * eval e1 x
*)
(*
Find Typo in eval:
 1. \<And>e1 e2 x.
       (\<And>x. evalp (coeffs e1) x = eval e1 x) \<Longrightarrow>
       (\<And>x. evalp (coeffs e2) x = eval e2 x) \<Longrightarrow>
       eval e2 x \<noteq> eval e1 x \<Longrightarrow> eval e1 x = 0
*)
lemma "evalp (coeffs e) x = eval e x"
apply(induction e arbitrary: x)
apply(auto simp add: evalp_coeffs_to_eval_add evalp_m_d_l  evalp_coeffs_to_eval_multi)
done

end


(* Title: Resolvable_Designs.thy
   Author: Chelsea Edmonds
*)

section \<open>Resolvable Designs \<close>
text \<open>Resolvable designs have further structure, and can be "resolved" into a set of resolution
classes. A resolution class is a subset of blocks which exactly partitions the point set.
Definitions based off the handbook \cite{colbournHandbookCombinatorialDesigns2007}
 and Stinson \cite{stinsonCombinatorialDesignsConstructions2004}.
This theory includes a proof of an alternate statement of Bose's theorem \<close>

theory Resolvable_Designs imports BIBD
begin

subsection \<open>Resolutions and Resolution Classes \<close>
text \<open>A resolution class is a partition of the point set using a set of blocks from the design
A resolution is a group of resolution classes partitioning the block collection \<close>

context incidence_system
begin

definition resolution_class :: "'a set set \<Rightarrow> bool" where
"resolution_class S \<longleftrightarrow> partition_on \<V> S \<and> (\<forall> bl \<in> S . bl \<in># \<B>)"

lemma resolution_classI [intro]: "partition_on \<V>  S \<Longrightarrow> (\<And> bl . bl \<in> S \<Longrightarrow> bl \<in># \<B>)
    \<Longrightarrow> resolution_class S"
  by (simp add: resolution_class_def)

lemma resolution_classD1: "resolution_class S \<Longrightarrow> partition_on \<V> S"
  by (simp add: resolution_class_def)

lemma resolution_classD2: "resolution_class S \<Longrightarrow>  bl \<in> S \<Longrightarrow> bl \<in># \<B>"
  by (simp add: resolution_class_def)

lemma resolution_class_empty_iff: "resolution_class {} \<longleftrightarrow> \<V>  = {}"
  by (auto simp add: resolution_class_def partition_on_def)

lemma resolution_class_complete: "\<V>  \<noteq> {} \<Longrightarrow> \<V>  \<in># \<B> \<Longrightarrow> resolution_class {\<V>}"
  by (auto simp add: resolution_class_def partition_on_space)

lemma resolution_class_union: "resolution_class S \<Longrightarrow> \<Union>S = \<V> "
  by (simp add: resolution_class_def partition_on_def)

lemma (in finite_incidence_system) resolution_class_finite: "resolution_class S \<Longrightarrow> finite S"
  using finite_elements finite_sets by (auto simp add: resolution_class_def)

lemma (in design) resolution_class_sum_card: "resolution_class S \<Longrightarrow> (\<Sum>bl \<in> S . card bl) = \<v>"
  using resolution_class_union finite_blocks
  by (auto simp add: resolution_class_def partition_on_def card_Union_disjoint)

definition resolution:: "'a set multiset multiset \<Rightarrow> bool" where
"resolution P \<longleftrightarrow> partition_on_mset \<B> P \<and> (\<forall> S \<in># P . distinct_mset S \<and> resolution_class (set_mset S))"

lemma resolutionI : "partition_on_mset \<B> P \<Longrightarrow> (\<And> S . S \<in>#P \<Longrightarrow> distinct_mset S) \<Longrightarrow>
    (\<And> S . S\<in># P \<Longrightarrow> resolution_class (set_mset S)) \<Longrightarrow> resolution P"
  by (simp add: resolution_def)

lemma (in proper_design) resolution_blocks: "distinct_mset \<B> \<Longrightarrow> disjoint (set_mset \<B>) \<Longrightarrow>
    \<Union>(set_mset \<B>) = \<V> \<Longrightarrow> resolution {#\<B>#}"
  unfolding resolution_def resolution_class_def partition_on_mset_def partition_on_def
  using design_blocks_nempty blocks_nempty by auto

end

subsection \<open>Resolvable Design Locale \<close>
text \<open> A resolvable design is one with a resolution P \<close>
locale resolvable_design = design +
  fixes partition :: "'a set multiset multiset" ("\<P>")
  assumes resolvable: "resolution \<P>"
begin

lemma resolutionD1: "partition_on_mset \<B> \<P>"
  using resolvable by (simp add: resolution_def)

lemma resolutionD2: "S \<in>#\<P> \<Longrightarrow> distinct_mset S"
  using resolvable by (simp  add: resolution_def)

lemma resolutionD3: " S\<in># \<P> \<Longrightarrow> resolution_class (set_mset S)"
  using resolvable by (simp add: resolution_def)

lemma resolution_class_blocks_disjoint: "S \<in># \<P> \<Longrightarrow> disjoint (set_mset S)"
  using resolutionD3 by (simp add: partition_on_def resolution_class_def)

lemma resolution_not_empty: "\<B> \<noteq> {#} \<Longrightarrow> \<P> \<noteq> {#}"
  using partition_on_mset_not_empty resolutionD1 by auto

lemma resolution_blocks_subset: "S \<in># \<P> \<Longrightarrow> S \<subseteq># \<B>"
  using partition_on_mset_subsets resolutionD1 by auto

end

lemma (in incidence_system) resolvable_designI [intro]: "resolution \<P> \<Longrightarrow> design \<V> \<B> \<Longrightarrow>
    resolvable_design \<V> \<B> \<P>"
  by (simp add: resolvable_design.intro resolvable_design_axioms.intro)

subsection \<open>Resolvable Block Designs \<close>
text \<open>An RBIBD is a resolvable BIBD - a common subclass of interest for block designs \<close>
locale r_block_design = resolvable_design + block_design
begin
lemma resolution_class_blocks_constant_size: "S \<in># \<P> \<Longrightarrow> bl \<in># S \<Longrightarrow> card bl = \<k>"
  by (metis resolutionD3 resolution_classD2 uniform_alt_def_all)

lemma resolution_class_size1:
  assumes "S \<in># \<P>"
  shows "\<v> = \<k> * size S"
proof -
  have "(\<Sum>bl \<in># S . card bl) = (\<Sum>bl \<in> (set_mset S) . card bl)" using resolutionD2 assms
    by (simp add:  sum_unfold_sum_mset)
  then have eqv: "(\<Sum>bl \<in># S . card bl) = \<v>" using resolutionD3 assms resolution_class_sum_card
    by presburger
  have "(\<Sum>bl \<in># S . card bl) = (\<Sum>bl \<in># S . \<k>)" using resolution_class_blocks_constant_size assms
    by auto
  thus ?thesis using eqv by auto
qed

lemma resolution_class_size2:
  assumes "S \<in># \<P>"
  shows "size S = \<v> div \<k>"
  using resolution_class_size1 assms
  by (metis nonzero_mult_div_cancel_left not_one_le_zero k_non_zero)

lemma resolvable_necessary_cond_v: "\<k> dvd \<v>"
proof -
  obtain S where s_in: "S \<in>#\<P>" using resolution_not_empty design_blocks_nempty by blast
  then have "\<k> * size S = \<v>" using resolution_class_size1 by simp
  thus ?thesis by (metis dvd_triv_left)
qed

end

locale rbibd = r_block_design + bibd

begin

lemma resolvable_design_num_res_classes: "size \<P> = \<r>"
proof -
  have k_ne0: "\<k> \<noteq> 0" using k_non_zero by auto
  have f1: "\<b> = (\<Sum>S \<in># \<P> . size S)"
    by (metis partition_on_msetD1 resolutionD1 size_big_union_sum)
  then have "\<b> = (\<Sum>S \<in># \<P> . \<v> div \<k>)" using resolution_class_size2 f1 by auto
  then have f2: "\<b> = (size \<P>) * (\<v> div \<k>)" by simp
  then have "size \<P> = \<b> div (\<v> div \<k>)"
    using b_non_zero by auto
  then have "size \<P> = (\<b> * \<k>) div \<v>" using f2 resolvable_necessary_cond_v
    by (metis div_div_div_same div_dvd_div dvd_triv_right k_ne0 nonzero_mult_div_cancel_right)
  thus ?thesis using necessary_condition_two
    by (metis nonzero_mult_div_cancel_left not_one_less_zero t_design_min_v)
qed

lemma resolvable_necessary_cond_b: "\<r> dvd \<b>"
proof -
  have f1: "\<b> = (\<Sum>S \<in># \<P> . size S)"
    by (metis partition_on_msetD1 resolutionD1 size_big_union_sum)
  then have "\<b> = (\<Sum>S \<in># \<P> . \<v> div \<k>)" using resolution_class_size2 f1 by auto
  thus ?thesis using resolvable_design_num_res_classes by simp
qed

subsubsection \<open>Bose's Inequality\<close>
text \<open> Boses inequality is an important theorem on RBIBD's. This is a proof
of an alternate statement of the thm, which does not require a linear algebraic approach,
taken directly from Stinson \cite{stinsonCombinatorialDesignsConstructions2004} \<close>
theorem bose_inequality_alternate: "\<b> \<ge> \<v> + \<r> - 1 \<longleftrightarrow> \<r> \<ge> \<k> + \<Lambda>"
proof -
  let ?k' = "(int \<k>)" let ?b' = "(int \<b>)" let ?v' = "int \<v>" let ?\<Lambda>' = "int \<Lambda>" let ?r' = "int \<r>"
  have kdvd: "?k' dvd (?v' * (?r' - ?k'))"
    by (meson dvd_mult2 of_nat_dvd_iff resolvable_necessary_cond_v right_diff_distrib')
  have necess1_alt: "?\<Lambda>' * ?v' - ?\<Lambda>' =  (?r' * (?k' - 1))" using necessary_condition_one
    by (smt (verit) diff_diff_cancel int_ops(2) int_ops(6) k_non_zero nat_mult_1_right of_nat_0_less_iff of_nat_mult right_diff_distrib' v_non_zero)
  then have v_eq: "?v' = (?r' * (?k' - 1) + ?\<Lambda>' ) div ?\<Lambda>'"
    using necessary_condition_one index_not_zero
    by (metis diff_add_cancel nonzero_mult_div_cancel_left not_one_le_zero of_nat_mult unique_euclidean_semiring_with_nat_class.of_nat_div)
  have ldvd: " \<And> x. ?\<Lambda>' dvd (x * (?r' * (?k' - 1) + ?\<Lambda>'))"
    by (metis necess1_alt diff_add_cancel dvd_mult dvd_triv_left)
  have "(?b' \<ge> ?v' + ?r' - 1) \<longleftrightarrow> ((\<v> * ?r') div ?k' \<ge> ?v' + ?r' - 1)"
    using necessary_condition_two k_non_zero
    by (metis (no_types, lifting) nonzero_mult_div_cancel_right not_one_le_zero of_nat_eq_0_iff of_nat_mult)

  also have  "... \<longleftrightarrow> (((?v' * ?r') - (?v' * ?k')) div ?k' \<ge> ?r' - 1)"
    using  k_non_zero div_mult_self3 k_non_zero necessary_condition_two
    by (smt (verit, ccfv_SIG) Euclidean_Division.div_eq_0_iff b_non_zero bibd_block_number mult_is_0 of_nat_eq_0_iff)
  also have f2: " ... \<longleftrightarrow> ((?v' * ( ?r' - ?k')) div ?k' \<ge> ( ?r' - 1))"
    using int_distrib(3) mult_of_nat_commute by (metis (no_types, hide_lams))
  also have f2: " ... \<longleftrightarrow> ((?v' * ( ?r' - ?k')) \<ge> ?k' * ( ?r' - 1))"
    using k_non_zero kdvd by (auto simp add: mult_of_nat_commute)
  also have "... \<longleftrightarrow> ((((?r' * (?k' - 1) + ?\<Lambda>' ) div ?\<Lambda>') * (?r' - ?k')) \<ge> ?k' * (?r' - 1))"
    using v_eq by presburger
  also have "... \<longleftrightarrow> ( (?r' - ?k') * ((?r' * (?k' - 1) + ?\<Lambda>' ) div ?\<Lambda>') \<ge> (?k' * (?r' - 1)))"
    by (simp add: mult.commute)
  also have " ... \<longleftrightarrow> ( ((?r' - ?k') * (?r' * (?k' - 1) + ?\<Lambda>' )) div ?\<Lambda>' \<ge> (?k' * (?r' - 1)))"
    using  div_mult_swap necessary_condition_one by (metis (no_types, hide_lams) ldvd mult_cancel_right1)
  also have " ... \<longleftrightarrow> (((?r' - ?k') * (?r' * (?k' - 1) + ?\<Lambda>' ))  \<ge>  ?\<Lambda>' * (?k' * (?r' - 1)))"
    using ldvd[of "(?r' - ?k')"]  dvd_mult_div_cancel index_not_zero mult_strict_left_mono
    by (smt (z3) div_by_0 nat_less_le of_nat_0 of_nat_le_0_iff v_eq v_non_zero)
  also have 1: "... \<longleftrightarrow> (((?r' - ?k') * (?r' * (?k' - 1))) + ((?r' - ?k') * ?\<Lambda>' )  \<ge>  ?\<Lambda>' * (?k' * (?r' - 1)))"
    by (simp add: distrib_left)
  also have "... \<longleftrightarrow> (((?r' - ?k') * ?r' * (?k' - 1)) \<ge> ?\<Lambda>' * ?k' * (?r' - 1) - ((?r' - ?k') * ?\<Lambda>' ))"
    using mult.assoc by linarith
  also have "... \<longleftrightarrow> (((?r' - ?k') * ?r' * (?k' - 1)) \<ge> (?\<Lambda>' * ?k' * ?r') - (?\<Lambda>' * ?k') - ((?r' * ?\<Lambda>') -(?k' * ?\<Lambda>' )))"
    using distrib_right by (simp add: distrib_left right_diff_distrib' left_diff_distrib')
  also have "... \<longleftrightarrow> (((?r' - ?k') * ?r' * (?k' - 1)) \<ge> (?\<Lambda>' * ?k' * ?r')  - ( ?\<Lambda>' * ?r'))"
    by (simp add: mult.commute)
  also have "... \<longleftrightarrow> (((?r' - ?k') * ?r' * (?k' - 1)) \<ge> (?\<Lambda>'  * (?k' * ?r'))  - ( ?\<Lambda>' * ?r'))"
    by linarith
  also have "... \<longleftrightarrow> (((?r' - ?k') * ?r' * (?k' - 1)) \<ge> (?\<Lambda>'  * (?r' * ?k'))  - ( ?\<Lambda>' * ?r'))"
    by (simp add: mult.commute)
  also have "... \<longleftrightarrow> (((?r' - ?k') * ?r' * (?k' - 1)) \<ge> ?\<Lambda>' * ?r' * (?k' - 1))"
    by (simp add:  mult.assoc int_distrib(4))
  finally have "(?b' \<ge> ?v' + ?r' - 1) \<longleftrightarrow> (?r' \<ge> ?k' + ?\<Lambda>')"
    using index_lt_replication mult_right_le_imp_le r_gzero mult_cancel_right k_non_zero
    by (smt (z3) of_nat_0_less_iff of_nat_1 of_nat_le_iff of_nat_less_iff) (* SLOW *)
  then have "\<b> \<ge> \<v> + \<r> - 1 \<longleftrightarrow> \<r> \<ge> \<k> + \<Lambda>"
    using k_non_zero le_add_diff_inverse of_nat_1 of_nat_le_iff by linarith
  thus ?thesis by simp
qed
end
end


(*  Title:      HOL/Types_To_Sets/Examples/Finite.thy
    Author:     Ondřej Kunčar, TU München
*)

theory Finite
  imports "../Types_To_Sets" Prerequisites
begin

section \<open>The Type-Based Theorem\<close>

text\<open>This example file shows how we perform the relativization in presence of axiomatic
  type classes: we internalize them.\<close>

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

text\<open>We want to relativize the following type-based theorem using the type class finite.\<close>

lemma type_based: "\<exists>f :: 'a::finite \<Rightarrow> nat. injective f"
  unfolding injective_def
  using finite_imp_inj_to_nat_seg[of "UNIV::'a set", unfolded inj_on_def] by auto

section \<open>Definitions and Setup for The Relativization\<close>

text\<open>We have to define what being injective on a set means.\<close>

definition injective_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "injective_on A f \<equiv> \<forall>x \<in> A. \<forall>y \<in> A. f x = f y \<longrightarrow> x = y"

text\<open>The predicate injective_on is the relativization of the predicate injective.\<close>

lemma injective_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total T"
  assumes [transfer_rule]: "bi_unique T"
  shows "((T ===> (=)) ===> (=)) (injective_on (Collect(Domainp T))) injective"
  unfolding injective_on_def[abs_def] injective_def[abs_def] by transfer_prover

text\<open>Similarly, we define the relativization of the internalization
     of the type class finite, class.finite\<close>

definition finite_on :: "'a set => bool" where "finite_on A = finite A"

lemma class_finite_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total (T::'a\<Rightarrow>'b\<Rightarrow>bool)"
  assumes [transfer_rule]: "bi_unique T"
  shows "(=) (finite_on (Collect(Domainp T))) (class.finite TYPE('b))"
  unfolding finite_on_def class.finite_def by transfer_prover

text\<open>The aforementioned development can be automated. The main part is already automated
     by the transfer_prover.\<close>

section \<open>The Relativization to The Set-Based Theorem\<close>

lemmas internalized = type_based[internalize_sort "'a::finite"]
text\<open>We internalized the type class finite and thus reduced the task to the
  original relativization algorithm.\<close>
thm internalized

text\<open>This is the set-based variant.\<close>

lemma set_based:
  assumes "(A::'a set) \<noteq> {}"
  shows "finite_on A \<longrightarrow> (\<exists>f :: 'a \<Rightarrow> nat. injective_on A f)"
proof -
  {
    text\<open>We define the type 'b to be isomorphic to A.\<close>
    assume T: "\<exists>(Rep :: 'b \<Rightarrow> 'a) Abs. type_definition Rep Abs A"
    from T obtain rep :: "'b \<Rightarrow> 'a" and abs :: "'a \<Rightarrow> 'b" where t: "type_definition rep abs A"
      by auto

    text\<open>Setup for the Transfer tool.\<close>
    define cr_b where "cr_b == \<lambda>r a. r = rep a"
    note type_definition_Domainp[OF t cr_b_def, transfer_domain_rule]
    note typedef_right_total[OF t cr_b_def, transfer_rule]
    note typedef_bi_unique[OF t cr_b_def, transfer_rule]

    have ?thesis
      text\<open>Relativization by the Transfer tool.\<close>
      using internalized[where 'a = 'b, untransferred, simplified]
      by blast
  } note * = this[cancel_type_definition, OF assms] text\<open>We removed the definition of 'b.\<close>

  show ?thesis by (rule *)
qed

text\<open>The Final Result. We can compare the type-based and the set-based statement.\<close>
thm type_based set_based

end


theory a3
imports "AutoCorres"
begin

(*******************************************************************************)

section {* Regular Expressions (21 marks)*}

(* Definitions of regular expressions from week06B's demo. *)

datatype regexp =
  Atom char ("<_>")
 |Alt regexp regexp (infixl "\<bar>" 50)
 |Conc regexp regexp (infixl "\<cdot>"  60)
 |Star regexp ("_ \<star>" [79] 80)
 |Neg regexp ("!_" [70] 70)

inductive_set star for L
where
  star_empty[simp,intro!]: "[] \<in> star L"
 |star_app: "\<lbrakk>u\<in>L; v\<in>star L\<rbrakk> \<Longrightarrow> u@v \<in> star L"

definition conc :: "string set \<Rightarrow> string set \<Rightarrow> string set"
  where
  "conc  l1 l2 \<equiv>{ w1@w2  |w1 w2. w1 \<in>  l1 \<and> w2 \<in>  l2}"

primrec
  lang :: "regexp \<Rightarrow> string set"
where
  "lang (Atom c) = {[c]}"
 |"lang (Alt e1 e2) = lang e1 \<union> lang e2"
 |"lang (Conc e1 e2) = conc (lang e1) (lang e2)"
 |"lang (Star e) = star (lang e)"
 |"lang (Neg e) = - (lang e)"

(* Let U be the regular expression defining the
   universal language, i.e. the language of all words.
   Let N be the regular expression defining the
   empty language, i.e. the language containing no words.
   Let E be the regular expression defining the
   language containing only the empty word. *)

definition
  U :: regexp
where
  "U \<equiv> Alt (Atom CHR ''x'')  (Neg (Atom CHR ''x''))"

definition
  N :: regexp
where
  "N \<equiv> Neg U"

definition
  E :: regexp
where
  "E \<equiv> Star N"

(* (a) Prove that the language recognised by U is indeed
        the universal set UNIV, that the language recognised
        by N is indeed the empty set, and that the language
        recognised by E is indeed the set containing
        only the empty word. *)

lemma lang_U [simp]:
  "lang U = UNIV"
  (*TODO*)
  sorry

lemma lang_N [simp]:
  "lang N = {}"
  (* TODO *)
  sorry

lemma lang_E [simp]:
  "lang E = {[]}"
  (*TODO*)
  sorry

(* (b) Define a function  String (using primrec),
      taking a list of characters in parameters, and producing
      the regular expression recognising that string.
      If the list is empty, the regular expression should
      the regular expression recognising only the empty word.
      Check (prove) the lang_String lemma. *)

primrec
  String :: "char list \<Rightarrow> regexp"
  where
  (*TODO*)

lemma lang_String: "lang (String xs) = {xs}"
  (*TODO*)

(* (c) Define a function Maybe, taking a regular
       expression e, and producing the regular
       expression (noted "e?") recognising
       either e or empty word.
       Check (prove) the lang_Maybe lemma.
       (1 mark) *)

definition
  Maybe :: "regexp \<Rightarrow> regexp" ("_?" [79] 80)
where
  (* TODO *)

lemma lang_Maybe [simp]:
  "lang (e?) = {[]} \<union> lang e"
  (* TODO *)

(* (d) Define a function Plus, taking a regular
       expression e, and producing the regular
       expression (noted "e+") recognising
       one or more concatenations of e.
       Check (prove) the lang_Plus lemma. *)

definition
  Plus :: "regexp \<Rightarrow> regexp" ("_+" [79] 80)
where
  (*TODO*)

lemma lang_Plus [simp]:
  "[] \<notin> lang e \<Longrightarrow> lang (Plus e) = lang (Star e) - {[]}"
  (*TODO*)

(* (e) Define a function CClass, taking a list of characters,
       and producing the regular expression recognising
       the words made of any of these single characters, i.e.
       "CClass [c1, c2]" recognises the two words "[c1]"
       and "[c2]".
       Check (prove) the lang_CClass lemma. *)

primrec
  CClass :: "char list \<Rightarrow> regexp"
where
  (*TODO *)

lemma lang_CClass: "lang (CClass xs) = set (map (\<lambda>c. [c]) xs)"
  (* TODO *)

(* (f) Consider the function  Tilde below, taking a regular
       expression e,
       and producing the regular expression recognising
       words made of any string not containing e
       followed by one e. This function is useful to
       define comments. Note that  enum enumerates all the elements
       of a finite type.
       Check the lang_Tilde lemma. *)

definition
  AnyChar :: regexp
where
  "AnyChar \<equiv> CClass Enum.enum"

definition
  Tilde :: "regexp \<Rightarrow> regexp"
where
  "Tilde e \<equiv> ! ( AnyChar \<star> \<cdot> e \<cdot> AnyChar \<star>) \<cdot> e"

lemma lang_Tilde: "{w@[c] | w. c\<notin> set w} \<subseteq> lang (Tilde <c>)"
  (*TODO*)

(*(g) Define a function  maybeempty (using primrec)
      taking a regular expression  e of type regexp
      (i.e. one of the five type of regular expressions of week06B)
      and returning True if this  e may contain
      the empty word, False otherwise.
      Check (proof) the maybeempty_correct lemma.
      Hint: you may look at how JFlex defines this function. *)

primrec maybeempty :: "regexp \<Rightarrow> bool"
where
  (*TODO*)

lemma maybeempty_correct: "maybeempty e = ([] \<in> lang e) "
  (*TODO*)

(*(h) Prove that maybeempty of the five new types of regular expressions
      defined above (Maybe, Plus, CClass and Tilde) is equal
      to what JFlex defines, i.e. prove maybeempty_Maybe,
      maybeempty_Plus, maybeempty_CCLass, maybeempty_String and
      maybeempty_Tilde.
      (2 points) *)

lemma maybeempty_Maybe: "maybeempty (Maybe e)= True"
  (*TODO*)

lemma maybeempty_Plus: "maybeempty (Plus e)= maybeempty e"
  (*TODO*)

lemma maybeempty_CCLass: "maybeempty (CClass xs) = False"
  (*TODO*)

lemma maybeempty_String: "maybeempty (String xs) = (length xs = 0)"
  (*TODO*)

lemma maybeempty_Tilde: "maybeempty (Tilde c) = False"
  (*TODO*)

(*******************************************************************************)

section {* Termination (15 marks)*}

(* see a3.pdf *)

(*******************************************************************************)

section "C Verification: Binary Search (64 marks)"

install_C_file "binsearch.c"

autocorres [unsigned_word_abs=binary_search] "binsearch.c"

context binsearch
begin

(* The monadic definition that autocorres produces for the C code: *)
thm binary_search'_def

(* Abbreviation for signed machine integers *)
type_synonym s_int = "32 signed word"

(* The heap only stores unsigned machine integers;
   they have the same representation as signed ones and can be converted to each other *)
type_synonym u_int = "32 word"

(* A few lemmas to help improve automation: *)

(* Pointer arithmetic on pointers to signed and unsigned words is the same *)
lemma ptr_coerce_add_signed_unsigned [simp]:
  "(ptr_coerce ((a :: s_int ptr) +\<^sub>p x) :: u_int ptr) = ptr_coerce a +\<^sub>p x"
  by (cases a) (simp add: ptr_add_def)

(* Pointer arithmetic distributivity law *)
lemma ptr_add_add [simp]:
  "p +\<^sub>p (x + y) = p +\<^sub>p x +\<^sub>p y"
  by (simp add: ptr_add_def distrib_left mult.commute)

(* C division is the same as Isabelle division for non-negative numbers: *)
lemma sdiv [simp]:
  "0 \<le> a \<Longrightarrow> a sdiv 2 = a div (2::int)"
  by (auto simp: sdiv_int_def sgn_if)

(* Some useful facts about INT_MIN and INT_MAX to improve automation: *)
lemma INT_MIN_neg [simp]:
  "INT_MIN < 0"
  by (simp add: INT_MIN_def)
lemma INT_MAX_gr [simp]:
  "- 1 < INT_MAX" "-1 \<le> INT_MAX" "1 \<le> INT_MAX"
  by (auto simp add: INT_MAX_def)

(* This function enumerates the addresses of the entries of an signed int array: *)
fun array_addrs :: "s_int ptr \<Rightarrow> nat \<Rightarrow> s_int ptr list" where
  "array_addrs p 0 = []" |
  "array_addrs p (Suc len) = p # array_addrs (p +\<^sub>p 1) len"

(*******************************************************************************)
(* a) fill in the array_list definition *)
definition array_list :: "(u_int ptr \<Rightarrow> u_int) \<Rightarrow> s_int ptr \<Rightarrow> int \<Rightarrow> int list" where
  "array_list h p len = TODO"

(* b) fill in the valid_array definition. It might make sense to do this in two parts and look
   at the invariant and proof obligations first. *)
definition valid_array :: "(u_int ptr \<Rightarrow> bool) \<Rightarrow> (u_int ptr \<Rightarrow> u_int) \<Rightarrow> s_int ptr \<Rightarrow> int \<Rightarrow> bool" where
  "valid_array vld h p len = TODO"

(* Hints:
    - remember to try the @{text arith} proof method for arithmetic goals on
      integers or natural numbers.
    - use find_theorems to find Isabelle library theorems about existing concepts.
    - the lemma @{thm sorted_equals_nth_mono} might be useful
    - you are allowed to use sledgehammer and other automation
    - if you can't prove one of the lemmas below, you can still assume it in the rest of the proof
    - the function @{const int} converts an Isabelle nat to an int
    - the function @{const nat} converts an Isabelle int to a nat
*)

thm sorted_equals_nth_mono
term int
term nat

text {* Prove the following lemma: *}
lemma length_array_addrs [simp]:
  "length (array_addrs a len) = len"
  sorry

text {* Prove the following lemma: *}
lemma array_addrs_nth [simp]:
  "\<lbrakk> 0 \<le> x; nat x < len \<rbrakk> \<Longrightarrow> array_addrs a len ! nat x = a +\<^sub>p x"
  sorry

text {* Prove the following lemma: *}
lemma ptr_array:
  "\<lbrakk> 0 \<le> x; x < len \<rbrakk> \<Longrightarrow>
   uint (heap_w32 s (ptr_coerce (a :: s_int ptr) +\<^sub>p x)) = array_list (heap_w32 s) a len ! nat x"
   sorry

text {* Prove the following lemma: *}
lemma key_lt:
  "\<lbrakk> key < xs ! nat mid;  mid - 1 < x; sorted xs; 0 \<le> mid; x < int (length xs) \<rbrakk>
  \<Longrightarrow> key < xs ! nat x"
  sorry

text {* Prove the following lemma: *}
lemma key_gt:
  "\<lbrakk> xs ! nat mid < key; 0 \<le> x; x \<le> mid; sorted xs; mid < int (length xs) \<rbrakk>
  \<Longrightarrow> xs ! nat x < key"
  sorry

lemma binary_search_correct:
  notes ptr_array [where len=len, simp]
  shows
  "\<lbrace>\<lambda>s. sorted (array_list (heap_w32 s) a len) \<and>
        valid_array (is_valid_w32 s) (heap_w32 s) a len \<and>
        TODO \<rbrace>
   binary_search' a len key
   \<lbrace> \<lambda>r s. (r < 0 \<longrightarrow> key \<notin> set (array_list (heap_w32 s) a len)) \<and>
           (0 \<le> r \<longrightarrow> r < len \<and> (array_list (heap_w32 s) a len ! nat r) = key)\<rbrace>!"
  unfolding binary_search'_def
  apply(subst whileLoopE_add_inv[where
               I="\<lambda>(high,low) s. valid_array (is_valid_w32 s) (heap_w32 s) a len \<and>
                                 sorted (array_list (heap_w32 s) a len) \<and>
                                 TODO1" and
               M="\<lambda>((high,low),_). TODO2"])
  apply wp
  oops

end

end
(*>*)


(*  Authors:    Christophe Tabacznyj, Lawrence C. Paulson, Amine Chaieb,
                Thomas M. Rasmussen, Jeremy Avigad, Tobias Nipkow

This file deals with properties of primes. Definitions and lemmas are
proved uniformly for the natural numbers and integers.

This file combines and revises a number of prior developments.

The original theories "GCD" and "Primes" were by Christophe Tabacznyj
and Lawrence C. Paulson, based on @{cite davenport92}. They introduced
gcd, lcm, and prime for the natural numbers.

The original theory "IntPrimes" was by Thomas M. Rasmussen, and
extended gcd, lcm, primes to the integers. Amine Chaieb provided
another extension of the notions to the integers, and added a number
of results to "Primes" and "GCD". IntPrimes also defined and developed
the congruence relations on the integers. The notion was extended to
the natural numbers by Chaieb.

Jeremy Avigad combined all of these, made everything uniform for the
natural numbers and the integers, and added a number of new theorems.

Tobias Nipkow cleaned up a lot.
*)

section {* Primes *}

theory Primes
imports "~~/src/HOL/GCD"
begin

declare [[coercion int]]
declare [[coercion_enabled]]

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

lemmas prime_nat_def = prime_def

subsection {* Primes *}

lemma prime_odd_nat: "prime p \<Longrightarrow> p > 2 \<Longrightarrow> odd p"
  apply (auto simp add: prime_nat_def even_iff_mod_2_eq_zero dvd_eq_mod_eq_0)
  apply (metis dvd_eq_mod_eq_0 even_Suc even_iff_mod_2_eq_zero mod_by_1 nat_dvd_not_less not_mod_2_eq_0_eq_1 zero_less_numeral)
  done

(* FIXME Is there a better way to handle these, rather than making them elim rules? *)

lemma prime_gt_0_nat [elim]: "prime p \<Longrightarrow> p > 0"
  unfolding prime_nat_def by auto

lemma prime_ge_1_nat [elim]: "prime p \<Longrightarrow> p >= 1"
  unfolding prime_nat_def by auto

lemma prime_gt_1_nat [elim]: "prime p \<Longrightarrow> p > 1"
  unfolding prime_nat_def by auto

lemma prime_ge_Suc_0_nat [elim]: "prime p \<Longrightarrow> p >= Suc 0"
  unfolding prime_nat_def by auto

lemma prime_gt_Suc_0_nat [elim]: "prime p \<Longrightarrow> p > Suc 0"
  unfolding prime_nat_def by auto

lemma prime_ge_2_nat [elim]: "prime p \<Longrightarrow> p >= 2"
  unfolding prime_nat_def by auto

lemma prime_imp_coprime_nat: "prime p \<Longrightarrow> \<not> p dvd n \<Longrightarrow> coprime p n"
  apply (unfold prime_nat_def)
  apply (metis gcd_dvd1_nat gcd_dvd2_nat)
  done

lemma prime_int_altdef:
  "prime p = (1 < p \<and> (\<forall>m::int. m \<ge> 0 \<longrightarrow> m dvd p \<longrightarrow>
    m = 1 \<or> m = p))"
  apply (simp add: prime_def)
  apply (auto simp add: )
  apply (metis One_nat_def int_1 nat_0_le nat_dvd_iff)
  apply (metis zdvd_int One_nat_def le0 of_nat_0 of_nat_1 of_nat_eq_iff of_nat_le_iff)
  done

lemma prime_imp_coprime_int:
  fixes n::int shows "prime p \<Longrightarrow> \<not> p dvd n \<Longrightarrow> coprime p n"
  apply (unfold prime_int_altdef)
  apply (metis gcd_dvd1_int gcd_dvd2_int gcd_ge_0_int)
  done

lemma prime_dvd_mult_nat: "prime p \<Longrightarrow> p dvd m * n \<Longrightarrow> p dvd m \<or> p dvd n"
  by (blast intro: coprime_dvd_mult_nat prime_imp_coprime_nat)

lemma prime_dvd_mult_int:
  fixes n::int shows "prime p \<Longrightarrow> p dvd m * n \<Longrightarrow> p dvd m \<or> p dvd n"
  by (blast intro: coprime_dvd_mult_int prime_imp_coprime_int)

lemma prime_dvd_mult_eq_nat [simp]: "prime p \<Longrightarrow>
    p dvd m * n = (p dvd m \<or> p dvd n)"
  by (rule iffI, rule prime_dvd_mult_nat, auto)

lemma prime_dvd_mult_eq_int [simp]:
  fixes n::int
  shows "prime p \<Longrightarrow> p dvd m * n = (p dvd m \<or> p dvd n)"
  by (rule iffI, rule prime_dvd_mult_int, auto)

lemma not_prime_eq_prod_nat: "(n::nat) > 1 \<Longrightarrow> ~ prime n \<Longrightarrow>
    EX m k. n = m * k & 1 < m & m < n & 1 < k & k < n"
  unfolding prime_nat_def dvd_def apply auto
  by (metis mult.commute linorder_neq_iff linorder_not_le mult_1
      n_less_n_mult_m one_le_mult_iff less_imp_le_nat)

lemma prime_dvd_power_nat: "prime p \<Longrightarrow> p dvd x^n \<Longrightarrow> p dvd x"
  by (induct n) auto

lemma prime_dvd_power_int:
  fixes x::int shows "prime p \<Longrightarrow> p dvd x^n \<Longrightarrow> p dvd x"
  by (induct n) auto

lemma prime_dvd_power_nat_iff: "prime p \<Longrightarrow> n > 0 \<Longrightarrow>
    p dvd x^n \<longleftrightarrow> p dvd x"
  by (cases n) (auto elim: prime_dvd_power_nat)

lemma prime_dvd_power_int_iff:
  fixes x::int
  shows "prime p \<Longrightarrow> n > 0 \<Longrightarrow> p dvd x^n \<longleftrightarrow> p dvd x"
  by (cases n) (auto elim: prime_dvd_power_int)

subsubsection {* Make prime naively executable *}

lemma zero_not_prime_nat [simp]: "~prime (0::nat)"
  by (simp add: prime_nat_def)

lemma one_not_prime_nat [simp]: "~prime (1::nat)"
  by (simp add: prime_nat_def)

lemma Suc_0_not_prime_nat [simp]: "~prime (Suc 0)"
  by (simp add: prime_nat_def)

lemma prime_nat_code [code]:
    "prime p \<longleftrightarrow> p > 1 \<and> (\<forall>n \<in> {1<..<p}. ~ n dvd p)"
  apply (simp add: Ball_def)
  apply (metis One_nat_def less_not_refl prime_nat_def dvd_triv_right not_prime_eq_prod_nat)
  done

lemma prime_nat_simp:
    "prime p \<longleftrightarrow> p > 1 \<and> (\<forall>n \<in> set [2..<p]. \<not> n dvd p)"
  by (auto simp add: prime_nat_code)

lemmas prime_nat_simp_numeral [simp] = prime_nat_simp [of "numeral m"] for m

lemma two_is_prime_nat [simp]: "prime (2::nat)"
  by simp

text{* A bit of regression testing: *}

lemma "prime(97::nat)" by simp
lemma "prime(997::nat)" by eval

lemma prime_imp_power_coprime_nat: "prime p \<Longrightarrow> ~ p dvd a \<Longrightarrow> coprime a (p^m)"
  by (metis coprime_exp_nat gcd_nat.commute prime_imp_coprime_nat)

lemma prime_imp_power_coprime_int:
  fixes a::int shows "prime p \<Longrightarrow> ~ p dvd a \<Longrightarrow> coprime a (p^m)"
  by (metis coprime_exp_int gcd_int.commute prime_imp_coprime_int)

lemma primes_coprime_nat: "prime p \<Longrightarrow> prime q \<Longrightarrow> p \<noteq> q \<Longrightarrow> coprime p q"
  by (metis gcd_nat.absorb1 gcd_nat.absorb2 prime_imp_coprime_nat)

lemma primes_imp_powers_coprime_nat:
    "prime p \<Longrightarrow> prime q \<Longrightarrow> p ~= q \<Longrightarrow> coprime (p^m) (q^n)"
  by (rule coprime_exp2_nat, rule primes_coprime_nat)

lemma prime_factor_nat: "n \<noteq> (1::nat) \<Longrightarrow> \<exists> p. prime p \<and> p dvd n"
  apply (induct n rule: nat_less_induct)
  apply (case_tac "n = 0")
  using two_is_prime_nat
  apply blast
  apply (metis One_nat_def dvd.order_trans dvd_refl less_Suc0 linorder_neqE_nat
    nat_dvd_not_less neq0_conv prime_nat_def)
  done

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

lemma prime_divprod_pow_nat:
  assumes p: "prime p" and ab: "coprime a b" and pab: "p^n dvd a * b"
  shows "p^n dvd a \<or> p^n dvd b"
proof-
  { assume "n = 0 \<or> a = 1 \<or> b = 1" with pab have ?thesis
      apply (cases "n=0", simp_all)
      apply (cases "a=1", simp_all)
      done }
  moreover
  { assume n: "n \<noteq> 0" and a: "a\<noteq>1" and b: "b\<noteq>1"
    then obtain m where m: "n = Suc m" by (cases n) auto
    from n have "p dvd p^n" apply (intro dvd_power) apply auto done
    also note pab
    finally have pab': "p dvd a * b".
    from prime_dvd_mult_nat[OF p pab']
    have "p dvd a \<or> p dvd b" .
    moreover
    { assume pa: "p dvd a"
      from coprime_common_divisor_nat [OF ab, OF pa] p have "\<not> p dvd b" by auto
      with p have "coprime b p"
        by (subst gcd_commute_nat, intro prime_imp_coprime_nat)
      then have pnb: "coprime (p^n) b"
        by (subst gcd_commute_nat, rule coprime_exp_nat)
      from coprime_dvd_mult_nat[OF pnb pab] have ?thesis by blast }
    moreover
    { assume pb: "p dvd b"
      have pnba: "p^n dvd b*a" using pab by (simp add: mult.commute)
      from coprime_common_divisor_nat [OF ab, of p] pb p have "\<not> p dvd a"
        by auto
      with p have "coprime a p"
        by (subst gcd_commute_nat, intro prime_imp_coprime_nat)
      then have pna: "coprime (p^n) a"
        by (subst gcd_commute_nat, rule coprime_exp_nat)
      from coprime_dvd_mult_nat[OF pna pnba] have ?thesis by blast }
    ultimately have ?thesis by blast }
  ultimately show ?thesis by blast
qed

subsection {* Infinitely many primes *}

lemma next_prime_bound: "\<exists>p. prime p \<and> n < p \<and> p <= fact n + 1"
proof-
  have f1: "fact n + 1 \<noteq> 1" using fact_ge_one_nat [of n] by arith
  from prime_factor_nat [OF f1]
  obtain p where "prime p" and "p dvd fact n + 1" by auto
  then have "p \<le> fact n + 1" apply (intro dvd_imp_le) apply auto done
  { assume "p \<le> n"
    from `prime p` have "p \<ge> 1"
      by (cases p, simp_all)
    with `p <= n` have "p dvd fact n"
      by (intro dvd_fact_nat)
    with `p dvd fact n + 1` have "p dvd fact n + 1 - fact n"
      by (rule dvd_diff_nat)
    then have "p dvd 1" by simp
    then have "p <= 1" by auto
    moreover from `prime p` have "p > 1" by auto
    ultimately have False by auto}
  then have "n < p" by presburger
  with `prime p` and `p <= fact n + 1` show ?thesis by auto
qed

lemma bigger_prime: "\<exists>p. prime p \<and> p > (n::nat)"
  using next_prime_bound by auto

lemma primes_infinite: "\<not> (finite {(p::nat). prime p})"
proof
  assume "finite {(p::nat). prime p}"
  with Max_ge have "(EX b. (ALL x : {(p::nat). prime p}. x <= b))"
    by auto
  then obtain b where "ALL (x::nat). prime x \<longrightarrow> x <= b"
    by auto
  with bigger_prime [of b] show False
    by auto
qed

subsection{*Powers of Primes*}

text{*Versions for type nat only*}

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

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

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

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

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

subsection {*Chinese Remainder Theorem Variants*}

lemma bezout_gcd_nat:
  fixes a::nat shows "\<exists>x y. a * x - b * y = gcd a b \<or> b * x - a * y = gcd a b"
  using bezout_nat[of a b]
by (metis bezout_nat diff_add_inverse gcd_add_mult_nat gcd_nat.commute
  gcd_nat.right_neutral mult_0)

lemma gcd_bezout_sum_nat:
  fixes a::nat
  assumes "a * x + b * y = d"
  shows "gcd a b dvd d"
proof-
  let ?g = "gcd a b"
    have dv: "?g dvd a*x" "?g dvd b * y"
      by simp_all
    from dvd_add[OF dv] assms
    show ?thesis by auto
qed

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

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

text {* Primality *}

lemma coprime_bezout_strong:
  fixes a::nat assumes "coprime a b"  "b \<noteq> 1"
  shows "\<exists>x y. a * x = b * y + 1"
by (metis assms bezout_nat gcd_nat.left_neutral)

lemma bezout_prime:
  assumes p: "prime p" and pa: "\<not> p dvd a"
  shows "\<exists>x y. a*x = Suc (p*y)"
proof-
  have ap: "coprime a p"
    by (metis gcd_nat.commute p pa prime_imp_coprime_nat)
  from coprime_bezout_strong[OF ap] show ?thesis
    by (metis Suc_eq_plus1 gcd_lcm_complete_lattice_nat.bot.extremum pa)
qed

end


theory Exercise1 imports Main
begin

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

fun set :: "'a tree => 'a set" where
"set (Tip) = {}" |
"set (Node a v b) = (set a) Un {v} Un (set b)"

fun ord :: "int tree => bool" where
"ord (Tip) = True" |
"ord (Node (Tip) v (Tip)) = True" |
"ord (Node (Node a v1 b) v2 c) = ((v1 < v2) \<and> (ord (Node a v1 b)) \<and> (ord c))" |
"ord (Node (Tip) v1 (Node a v2 b)) = ((v1 < v2) \<and> (ord (Node a v2 b)))"

fun ins :: "int => int tree => int tree" where
"ins v (Tip) = Node (Tip) v (Tip)" |
"ins v (Node a ov b) = (
  if (v : ({ov} Un (set a) Un (set b)))
  then (Node a ov b)
  else (
    if v<ov
    then (Node (ins v a) ov b)
    else (Node a ov (ins v b))
  )
)"

theorem ins_non_duplication [simp]: "(x \<in> (set t)) ==> (ins x t = t)"
  apply (induction t)
	apply auto
	done

theorem set_inc_is_union [simp]: "set (ins x t) = {x} Un (set t)"
  apply (induction t)
	apply auto
	done

theorem ins_preserves_ord [simp]: "ord t ==> ord (ins x t)"
  apply (induction t rule: ord.induct)
	apply auto
	done

end


(*  Title:      CoW/Arithmetical_Hints.thy
    Author:     Štěpán Holub, Charles University
    Author:     Martin Raška, Charles University
    Author:     Štěpán Starosta, CTU in Prague
*)

theory Arithmetical_Hints
  imports Main
begin

section "Arithmetical hints"

text\<open>In this section we give some specific auxiliary lemmas on natural integers.\<close>

lemma zero_diff_eq: "i \<le> j \<Longrightarrow> (0::nat) = j - i  \<Longrightarrow> j = i"
  by simp

lemma zero_less_diff': "i < j \<Longrightarrow> j - i \<noteq> (0::nat)"
   by simp

lemma nat_prod_le: "m \<noteq> (0 :: nat) \<Longrightarrow> m*n \<le> k \<Longrightarrow> n \<le> k"
  using le_trans[of n "m*n" k] by auto

lemma get_div: "(p :: nat) < a \<Longrightarrow> m = (m * a + p) div a"
  by simp

lemma get_mod: "(p :: nat) < a \<Longrightarrow> p = (m * a + p) mod a"
  by simp

lemma plus_one_between:  "(a :: nat) < b \<Longrightarrow> \<not> b < a + 1"
  by auto

lemma quotient_smaller: "a \<noteq> 0 \<Longrightarrow> a = k * b \<Longrightarrow> b \<le> (a::nat)"
  by simp

lemma mult_cancel_le: "b \<noteq> 0 \<Longrightarrow> a*b \<le> c*b \<Longrightarrow> a \<le> (c::nat)"
  by simp

lemma add_lessD2: assumes "k + m < (n::nat)" shows "m < n"
  using add_lessD1[OF assms[unfolded add.commute[of k m]]].

lemma mod_offset:  assumes "M \<noteq> (0 :: nat)"
  obtains k where "n mod M = (l + k) mod M"
proof-
  have "(l + (M - l mod M)) mod M = 0"
    using mod_add_left_eq[of l M "(M - l mod M)", unfolded le_add_diff_inverse[OF mod_le_divisor[OF assms[unfolded neq0_conv]], of l] mod_self, symmetric].
  from mod_add_left_eq[of "(l + (M - l mod M))" M n, symmetric, unfolded this add.commute[of 0] add.comm_neutral]
  have "((l + (M - l mod M)) + n) mod M = n mod M".
  from that[OF this[unfolded add.assoc, symmetric]]
  show thesis.
qed

lemma assumes "q \<noteq> (0::nat)" shows "p \<le> p + q - gcd p q"
  using gcd_le2_nat[OF \<open>q \<noteq> 0\<close>, of p]
  by linarith

lemma less_mult_one: assumes "(m-1)*k < k" obtains "m = 0" | "m = (1::nat)"
  using assms by fastforce

end


theory EjT2C
imports Main
begin

section "Ejercicio 2.10: Número de nodos en copias de árboles binarios"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.10.1. Definir el tipo arbol0 para representar los
  árboles binarios sin valores en los nodos ni en las hojas. Por
  ejemplo, el árbol
       /\
      /\
  se define por
     abbreviation ejArbol0 :: arbol0 where
       "ejArbol0 \<equiv> N (N H H) H"
  ------------------------------------------------------------------- *}

datatype arbol0 = H
                | N arbol0 arbol0

abbreviation ejArbol0 :: arbol0 where
  "ejArbol0 \<equiv> N (N H H) H"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.10.2. Definir la función
     nNodos :: "arbol0 \<Rightarrow> nat
  tal que (nNodos t) es el número de los nodos (internos u hojas) del
  árbol t. Por ejemplo,
     nNodos ejArbol0 = 3
  ------------------------------------------------------------------- *}

fun nNodos :: "arbol0 \<Rightarrow> nat" where
  "nNodos H       = 1"
| "nNodos (N i d) = nNodos i + nNodos d"

value "nNodos ejArbol0 = 3"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.10.3. Definir la función
     copias :: "nat \<Rightarrow> arbol0 \<Rightarrow> arbol0
  tal que (copias n t) es es árbol con 2^n copias de t. Por ejemplo,
     copias 0 t = t
     copias 1 t = N t t
     copias 2 t = N (N t t) (N t t)
     copias 3 t = N (N (N t t) (N t t)) (N (N t t) (N t t))
  ------------------------------------------------------------------- *}

fun copias :: "nat \<Rightarrow> arbol0 \<Rightarrow> arbol0" where
  "copias 0 t       = t"
| "copias (Suc n) t = copias n (N t t)"

value "copias 0 t = t"
value "copias 1 t = N t t"
value "copias 2 t = N (N t t) (N t t)"
value "copias 3 t = N (N (N t t) (N t t)) (N (N t t) (N t t))"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.10.4. Demostrar que
     nNodos (copias n t) = 2^n * nNodos t
  ------------------------------------------------------------------- *}

lemma "nNodos (copias n t) = 2^n * nNodos t"
apply (induction n arbitrary: t)
apply simp_all
done

section "Ejercicio 2.11: Expresiones aritméticas y polinomios"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.11.1. Las expresiones aritméticas sobre los enteros, con
  una variable como máximo,se definen mediante el siguiente tipo de
  datos
     datatype exp = Var | Const int | Suma exp exp | Mult exp exp

  Definir la función
     valor :: "exp \<Rightarrow> int \<Rightarrow> int
  tal que (valor e n) es e valor de la expresión e cuando se le asigna a
  su variable el valor n. Por ejemplo,
     valor (Suma (Mult (Const 2) Var) (Const 3)) i = 2*i+3
  ------------------------------------------------------------------- *}

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

fun valor :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "valor Var n          = n"
| "valor (Const x) _    = x"
| "valor (Suma e1 e2) n = valor e1 n + valor e2 n"
| "valor (Mult e1 e2) n = valor e1 n * valor e2 n"

value "valor (Suma (Mult (Const 2) Var) (Const 3)) i = 2*i+3"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.11.2. Los polinomios se pueden representar mediante la
  lista de sus coeficientes. Por ejemplo, el polinomio 4+2x-x^2+3x^3
  se puede representar por [4,2,-1,3].

  Definir la función
     valorP :: "int list \<Rightarrow> int \<Rightarrow> int
  tal que (valorP p n) es el valor del polinomio p cuando se sustituye
  su variable por el número n. Por ejemplo,
     valorP [4]        2 = 4
     valorP [4,2]      2 = 8
     valorP [4,2,-1]   2 = 4
     valorP [4,2,-1,3] 2 = 28
  ------------------------------------------------------------------- *}

fun valorP :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "valorP [] _ = 0"
| "valorP (c#cs) n = c + n * valorP cs n"

value "valorP [4]        2 = 4"
value "valorP [4,2]      2 = 8"
value "valorP [4,2,-1]   2 = 4"
value "valorP [4,2,-1,3] 2 = 28"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.11.3. Definir la función
     coeficientes :: "exp \<Rightarrow> int list" where
  tal que (coeficientes e) es la lista de los coeficientes del polinomio
  correspondiente a la expresión e. Por ejemplo,
     coeficientes (Suma Var (Const 3)) = [3,1]
     coeficientes (Suma Var (Const (-3))) = [-3,1]
     coeficientes (Mult (Suma Var (Const 3)) (Suma Var (Const (-3))))
     = [-9,0,1]
  ------------------------------------------------------------------- *}

text {* (sumaP p1 p2) es la suma de los polinomios p1 y p2. Por ejemplo.
     sumaP [2,3,5] [1,4] = [3,7,5]
*}
fun sumaP :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "sumaP [] p2           = p2"
| "sumaP p1 []           = p1"
| "sumaP (c1#p1) (c2#p2) = (c1 + c2) # sumaP p1 p2"

value "sumaP [2,3,5] [1,4] = [3,7,5]"

text {* (multE x p) es el producto del número x por el polinomio p. Por
  ejemplo,
*}
fun multE :: "int \<Rightarrow> int list \<Rightarrow> int list" where
  "multE _ []    = []"
| "multE x (c#p) = (x*c) # multE x p"

value "multE 2 [3,1,4] = [6,2,8]"

text {* (multP p1 p2) es el producto de los polinomios p1 y p2. Por
  ejemplo,
     multP [3,1] [-3,1]  = [-9,0,1]
     multP [2,1] [1,4,3] = [2,9,10,3]
*}
fun multP :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "multP [] _ = []"
| "multP _ [] = []"
| "multP (c#p) p2 = sumaP (multE c p2) (0 # multP p p2)"

value "multP [3,1] [-3,1]  = [-9,0,1]"
value "multP [2,1] [1,4,3] = [2,9,10,3]"

fun coeficientes :: "exp \<Rightarrow> int list" where
  "coeficientes Var          = [0,1]"
| "coeficientes (Const n)    = [n]"
| "coeficientes (Suma e1 e2) = sumaP (coeficientes e1) (coeficientes e2)"
| "coeficientes (Mult e1 e2) = multP (coeficientes e1) (coeficientes e2)"

value "coeficientes (Suma Var (Const 3)) = [3,1]"
value "coeficientes (Suma Var (Const (-3))) = [-3,1]"
value "coeficientes (Mult (Suma Var (Const 3)) (Suma Var (Const (-3))))
       = [-9,0,1]"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.11.4. Demostrar que la función coeficientes preserva los
  valores de las expresiones.

  Nota: Se pueden usar las reglas de simplificación algebraica
  algebra_simps.
  ------------------------------------------------------------------- *}

lemma valorP_sumaP:
  "valorP (sumaP p1 p2) x = valorP p1 x + valorP p2 x"
apply (induction p1 p2 rule: sumaP.induct)
apply (simp_all add: algebra_simps)
done

lemma valorP_multE:
  "valorP (multE n p) x = n * valorP p x"
apply (induction p)
apply (simp_all add: algebra_simps)
done

lemma valorP_multP:
  "valorP (multP p1 p2) x = valorP p1 x * valorP p2 x"
apply (induction p1 p2 rule: multP.induct)
apply (simp_all add: valorP_sumaP
                     valorP_multE
                     algebra_simps)
done

theorem valorP_coeficientes:
  "valorP (coeficientes e) x = valor e x"
apply (induction e rule: exp.induct)
apply (simp_all add: valorP_sumaP
                     valorP_multP)
done

section "Ejercicio 2.12: Plegados sobre árboles"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.12.1. Definir el tipo de dato arbolH para representar los
  árboles binarios que sólo tienen valores en las hojas. Por ejemplo, el
  árbol
       ·
      / \
     3   ·
        / \
       5   7
  se representa por
     Nodo (Hoja 3) (Nodo (Hoja 5) (Hoja 7))
  ------------------------------------------------------------------- *}

datatype 'a arbolH =
  Hoja 'a
| Nodo "'a arbolH" "'a arbolH"

abbreviation ejArbolH1 :: "int arbolH"
where
  "ejArbolH1 \<equiv> Nodo (Hoja (3::int)) (Nodo (Hoja 5) (Hoja 7))"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.12.2. Definir la función
     infijo :: "'a arbolH \<Rightarrow> 'a list"
  tal que (infijo x) es el recorrido infijo del árbol hoja x. Por
  ejemplo,
     infijo ejArbolH1 = [3,5,7]
  ------------------------------------------------------------------- *}

fun infijo :: "'a arbolH \<Rightarrow> 'a list"
where
  "infijo (Hoja x)   = [x]"
| "infijo (Nodo i d) = infijo i @ infijo d"

value "infijo ejArbolH1"
lemma "infijo ejArbolH1 = [3,5,7]" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.12.3. Consultar la definición de la función fold de plegado
  de listas.
  ------------------------------------------------------------------- *}

-- "Una forma de consultarlo es"
thm fold.simps

text {*
  El resultado es
     fold ?f []         = id
     fold ?f (?x # ?xs) = fold ?f ?xs \<circ> ?f ?x
  *}

-- "Otra forma de consultarlo es"
thm fold_simps

text {*
  El resultado es
     fold ?f [] ?s         = ?s
     fold ?f (?x # ?xs) ?s = fold ?f ?xs (?f ?x ?s)
  *}

-- "Se puede comprobar la definición"
lemma
  "fold f [] s     = s"
  "fold f (x#xs) s = fold f xs (f x s)"
by simp_all

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.12.4. Definir la función
     fold_arbolH :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a arbolH \<Rightarrow> 'b \<Rightarrow> 'b"
  tal que (fold_arbolH f x y) es plegado del árbol hoja x con la
  operación f y el valor inicial x. Por ejemplo,
     fold_arbolH op+ ejArbolH1 0 = 15
     fold_arbolH op* ejArbolH1 1 = 105
  ------------------------------------------------------------------- *}

fun fold_arbolH :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a arbolH \<Rightarrow> 'b \<Rightarrow> 'b"
where
  "fold_arbolH f (Hoja x) y   = f x y"
| "fold_arbolH f (Nodo i d) y = fold_arbolH f d (fold_arbolH f i y)"

value "fold_arbolH op+ ejArbolH1 0"
lemma "fold_arbolH op+ ejArbolH1 0 = 15" by simp
value "fold_arbolH op* ejArbolH1 1"
lemma "fold_arbolH op* ejArbolH1 1 = 105" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.12.5. Demostrar que
     fold_arbolH f x y = fold f (infijo x) y
  ------------------------------------------------------------------- *}

lemma "fold_arbolH f x y = fold f (infijo x) y"
by (induction x arbitrary: y) auto

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.12.6. Definir la función
     espejo :: "'a arbolH \<Rightarrow> 'a arbolH"
  tal que (espejo x) es la imagen especular del árbol x. Por ejemplo,
     espejo ejArbolH1 = Nodo (Nodo (Hoja 7) (Hoja 5)) (Hoja 3)
  ------------------------------------------------------------------- *}

fun espejo :: "'a arbolH \<Rightarrow> 'a arbolH"
where
  "espejo (Hoja x)   = Hoja x"
| "espejo (Nodo i d) = Nodo (espejo d) (espejo i)"

value "espejo ejArbolH1"
lemma "espejo ejArbolH1 = Nodo (Nodo (Hoja 7) (Hoja 5)) (Hoja 3)"
  by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.12.7. Demostrar que
     infijo (espejo t) = rev (infijo t)
  ------------------------------------------------------------------- *}

lemma "infijo (espejo t) = rev (infijo t)"
by (induction t) auto

section "Ejercicio 2.13: Alineamientos de listas"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.13.1. Un alineamiento de dos lista xs e ys es una lista
  cuyos elementos son los de xs e ys consevando su orden original. Por
  ejemplo, un alineamiento de [a,b] y [c,d,e] es [a,c,d,b,e] y otro es
  [c,a,d,e,b].

  Definir la función
     alineamientos :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list"
  tal que (alineamientos xs ys) es la lista de los alineamientos de xs e
  ys. Por ejemplo,
     alineamientos [a,b] [c,d,e]
     = [[a,b,c,d,e],[a,c,b,d,e],[a,c,d,b,e],[a,c,d,e,b],[c,a,b,d,e],
        [c,a,d,b,e],[c,a,d,e,b],[c,d,a,b,e],[c,d,a,e,b],[c,d,e,a,b]]
  ------------------------------------------------------------------- *}

fun alineamientos :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list"
where
  "alineamientos xs []         = [xs]"
| "alineamientos [] ys         = [ys]"
| "alineamientos (x#xs) (y#ys) =
    map (op # x) (alineamientos xs (y#ys)) @
    map (op # y) (alineamientos (x#xs) ys)"

value "alineamientos [a,b] [c,d,e]"
lemma "alineamientos [a,b] [c,d,e] =
       [[a,b,c,d,e],[a,c,b,d,e],[a,c,d,b,e],[a,c,d,e,b],[c,a,b,d,e],
        [c,a,d,b,e],[c,a,d,e,b],[c,d,a,b,e],[c,d,a,e,b],[c,d,e,a,b]]"
  by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.13.2. Demostrar que la longitud de cualquier alineamiento de
  las listas xs e ys es la suma de las longitudes de los alineamientos
  de xs e ys.
  ------------------------------------------------------------------- *}

lemma "zs \<in> set (alineamientos xs ys) \<Longrightarrow>
       length zs = length xs + length ys"
apply (induction xs ys arbitrary: zs rule: alineamientos.induct)
apply auto
done

text {* Nota. La función set convierte una lista en el conjunto de sus
  elementos. Por ejemplo, el resultado de
     value "set [a,b,c]"
  es
     "{a, b, c}"
      :: "'a set"
  *}

section "Ejercicio 2.14: Plegado de listas"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.14.1. Definir, por recursión, la función
     suma1 :: "int list \<Rightarrow> int"
  tal que (suma1 xs) es la suma de los elementos de la lista xs. Por
  ejemplo,
     suma1 [3,1,4] = 8
  ------------------------------------------------------------------- *}

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

value "suma1 [3,1,4]"
lemma "suma1 [3,1,4] = 8" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.14.2. Definir, por plegado, la función
     suma2 :: "int list \<Rightarrow> int"
  tal que (suma2 xs) es la suma de los elementos de la lista xs. Por
  ejemplo,
     suma2 [3,1,4] = 8
  ------------------------------------------------------------------- *}

definition suma2 :: "int list \<Rightarrow> int"
where
  "suma2 xs \<equiv> fold op+ xs 0"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.14.3. Demostrar que las funciones suma1 y suma2 son
  equivalentes.
  ------------------------------------------------------------------- *}

lemma aux: "fold op+ xs a = suma1 xs + a"
by (induction xs arbitrary: a) auto

lemma "suma1 xs = suma2 xs"
by (simp add: aux suma2_def)

section "Ejercicio 2.15: Lista con elementos distintos"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.15.1. Definir, por recursión, la función
     pertenece :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
  tal que (pertenece x ys) se verifica si x es un elemento de ys. Por
  ejemplo,
     pertenece 2 [7,2,5] = True
     pertenece 4 [7,2,5] = False
  ------------------------------------------------------------------- *}

fun pertenece :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "pertenece x []     = False"
| "pertenece x (y#ys) = (x = y \<or> pertenece x ys)"

value "pertenece 4 [7,2,(5::nat)]"
lemma "pertenece 4 [7,2,(5::nat)] = False" by simp
value "pertenece 2 [7,2,(5::nat)]"
lemma "pertenece 2 [7,2,(5::nat)] = True" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.15.2. Definir la función
     distintos :: "'a list \<Rightarrow> bool
  tal que (distintos xs) se verifica si la lista xs no tiene elementos
  repetidos. Por ejemplo,
     distintos [7,2,5] = True
     distintos [7,2,7] = False
  ------------------------------------------------------------------- *}

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

value "distintos [7,2,(5::nat)]"
lemma "distintos [7,2,(5::nat)] = True" by simp
value "distintos [7,2,(7::nat)]"
lemma "distintos [7,2,(7::nat)] = False" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.15.3. Demostrar que la inversa de una lista no tiene
  repeticiones si, y sólo si, la lista original no tiene repeticiones.
  ------------------------------------------------------------------- *}

lemma pertenece_conc:
  "pertenece x (ys @ zs) = (pertenece x ys \<or> pertenece x zs)"
by (induction ys) simp_all

lemma pertenece_rev:
  "pertenece x (rev ys) = pertenece x ys"
by (induction ys) (auto simp add: pertenece_conc)

lemma distintos_conc:
  "distintos (xs @ [y]) = ( \<not>(pertenece y xs) \<and> distintos xs)"
by (induction xs) (auto simp add: pertenece_conc)

lemma "distintos (rev xs) = distintos xs"
by (induction xs) (auto simp add: distintos_conc pertenece_rev)

section "Ejercicio 2.16: Plegados de listas por la derecha y por la izquierda"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.16.1. Consultar las definiciones de fold y foldr
  ------------------------------------------------------------------- *}

thm fold.simps
thm foldr.simps

text {*
  El resultado es
    fold ?f []         = id
    fold ?f (?x # ?xs) = fold ?f ?xs \<circ> ?f ?x

    foldr ?f []         = id
    foldr ?f (?x # ?xs) = ?f ?x \<circ> foldr ?f ?xs
*}

lemma "fold  f [a,b,c] d = f c (f b (f a d))" by simp
lemma "foldr f [a,b,c] d = f a (f b (f c d))" by simp

lemma "foldr (op-) [1,2,3::int] 7 = (1 - (2 - (3 - 7)))" by auto
lemma "fold  (op-) [1,2,3::int] 7 = 3 - (2 - (1 - 7)) " by auto

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.16.2. Definir, usando fold, la función
     longitud1 :: "'a list \<Rightarrow> nat"
  tal que (longitud1 xs) es la longitud de la lista xs. Por ejemplo,
     longitud1 [a,b,c] = 3
  ------------------------------------------------------------------- *}

definition longitud1 :: "'a list \<Rightarrow> nat"
where
  "longitud1 xs = fold (\<lambda>x. Suc) xs 0"

value "longitud1 [a,b,c]"
lemma "longitud1 [a,b,c] = 3" by (simp add: longitud1_def)

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.16.3. Definir, usando fold, la función
     longitud2 :: "'a list \<Rightarrow> nat"
  tal que (longitud2 xs) es la longitud de la lista xs. Por ejemplo,
     longitud2 [a,b,c] = 3
  ------------------------------------------------------------------- *}

definition longitud2 :: "'a list \<Rightarrow> nat"
where
  "longitud2 xs = foldr (\<lambda>x. Suc) xs 0"

value "longitud2 [a,b,c]"
lemma "longitud2 [a,b,c] = 3" by (simp add: longitud2_def)

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.16.4. Demostrar que las funciones longitud1 y length son
  equivalentes.
  ------------------------------------------------------------------- *}

lemma aux_fold:
  "fold (\<lambda>x. Suc) xs y  = y + length xs"
by (induction xs arbitrary: y) auto

lemma "longitud1 xs = length xs"
by (simp add: longitud1_def aux_fold)

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.16.5. Demostrar que las funciones longitud2 y length son
  equivalentes.
  ------------------------------------------------------------------- *}

lemma aux_foldr:
  "foldr (\<lambda>x. Suc) xs y  = y + length xs"
by (induction xs arbitrary: y) auto

lemma "longitud2 xs = length xs"
by (simp add: longitud2_def aux_foldr)

section "Ejercicio 2.17: Cortes de listas"

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.17.1. Dada una lista xs, el corte de xs de longitud menor
  o igual que m con inicio en i es la lista formada por el elemento de
  xs en la posición i y en las m-1 siguientes posiciones (si existen
  dichos elementos).

  Definir la función
     corte :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
  tal que (corte xs i m) es el corte de xs de longitud menor o igual que
  m que empieza en la posición i. Por ejemplo,
     "corte [0,1,2,3,4,5,6] 2 3 = [2,3,4]
     "corte [0,1,2,3,4,5,6] 2 9 = [2,3,4,5,6]
     "corte [0,1,2,3,4,5,6] 9 9 = []
  ------------------------------------------------------------------- *}

definition corte :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
where
  "corte xs i m = take m (drop i xs)"

declare corte_def [simp]

lemma "corte [0,1,2,3,4,5,6 ::int] 2 3 = [2,3,4]" by simp
lemma "corte [0,1,2,3,4,5,6 ::int] 2 9 = [2,3,4,5,6]" by simp
lemma "corte [0,1,2,3,4,5,6 ::int] 9 9 = []" by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.17.2. Demostrar que la concatenación de dos cortes adyacentes
  se puede expresar como un único corte.
  ------------------------------------------------------------------- *}

lemma "corte xs i m1 @ corte xs (i + m1) m2 = corte xs i (m1 + m2)"
by (induction xs) (auto simp add: take_add add.commute)

text {*
  Los lemas utilizados son
  + take_add:    take (i + j) xs = take i xs @ take j (drop i xs)
  + add.commute: a + b = b + a
*}

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.17.3. Demostrar que los cortes en listas de elementos no
  repetidos no tienen elementos repetidos.
  ------------------------------------------------------------------- *}

lemma pertenece_take:
  "pertenece a (take n xs) \<Longrightarrow> pertenece a xs"
by (metis append_take_drop_id pertenece_conc)

lemma distintos_take:
  "distintos xs \<Longrightarrow> distintos (take n xs)"
apply (induction xs arbitrary: n)
apply simp
apply (case_tac n)
  apply (auto simp add: pertenece_take)
done

lemma pertenece_drop:
  "pertenece a (drop n xs) \<Longrightarrow> pertenece a xs"
by (metis append_take_drop_id pertenece_conc)

lemma distintos_drop:
  "distintos xs \<Longrightarrow> distintos (drop n xs)"
apply (induction xs arbitrary: n)
apply simp
apply (case_tac n)
  apply (auto simp add: pertenece_drop)
done

lemma "distintos xs \<Longrightarrow> distintos (corte xs i m)"
by (induct xs) (auto simp add: distintos_take distintos_drop)

end