theory Chapter4
imports "HOL-IMP.ASM"
begin

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

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

\exercise
Start from the data type of binary trees defined earlier:
\<close>

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

text \<open>
An @{typ "int tree"} is ordered if for every @{term "Node l i r"} in the tree,
@{text l} and @{text r} are ordered
and all values in @{text l} are @{text "< i"}
and all values in @{text r} are @{text "> i"}.
Define a function that returns the elements in a tree and one
the tests if a tree is ordered:
\<close>

fun set :: "'a tree \<Rightarrow> 'a set"  where
  "set Tip = {}" |
  "set (Node l a r) = \<Union> {set l, {a}, set r}"

fun ord :: "int tree \<Rightarrow> bool"  where
  "ord Tip = True" |
  "ord (Node l a r) \<longleftrightarrow> ord l \<and> ord r \<and> (\<forall> x \<in> set l. x < a) \<and> (\<forall> x \<in> set r. a < x)"

text \<open> Hint: use quantifiers.

Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
while maintaining the order of the tree. If the element is already in the tree, the
same tree should be returned.
\<close>

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree"  where
  "ins x Tip = Node Tip x Tip" |
  "ins x (Node l a r) =
    (if x < a
      then Node (ins x l) a r
      else if a < x
        then Node l a (ins x r)
        else Node l a r)"

text \<open> Prove correctness of @{const ins}: \<close>

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

theorem ord_ins: "ord t \<Longrightarrow> ord (ins i t)"
  apply (induction t)
   apply (auto simp add: set_ins)
  done

text \<open>
\endexercise

\exercise
Formalize the following definition of palindromes
\begin{itemize}
\item The empty list and a singleton list are palindromes.
\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
\end{itemize}
as an inductive predicate
\<close>

inductive palindrome :: "'a list \<Rightarrow> bool" where
  palindrome_Nil: "palindrome []" |
  palindrome_singleton: "palindrome [a]" |
  palindrome_circumfix: "palindrome as \<Longrightarrow> palindrome (a # as @ [a])"

text  \<open> and prove \<close>

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply (induction rule: palindrome.induct)
    apply auto
  done

text \<open>
\endexercise

\exercise
We could also have defined @{const star} as follows:
\<close>

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

text \<open>
The single @{text r} step is performed after rather than before the @{text star'}
steps. Prove
\<close>

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply (induction rule: star.induct)
   apply assumption
  by (rule step) (* alternatively, apply (metis step) done *)

lemma "star' r x y \<Longrightarrow> star r x y"
  apply (induction rule: star'.induct)
  by (auto simp add: refl step intro: star_trans)

(* limitation: no way to change order of premises, induction works
  only on first premise *)
lemma star'_trans: "star' r y z \<Longrightarrow> star' r x y \<Longrightarrow> star' r x z"
  apply (induction rule: star'.induct)
   apply assumption
  by (rule step')

lemma "star r x y \<Longrightarrow> star' r x y"
  apply (induction rule: star.induct)
   apply (auto intro: refl' step')
  by (blast intro: refl' step' star'_trans)

text \<open>
You may need lemmas. Note that rule induction fails
if the assumption about the inductive predicate
is not the first assumption.
\endexercise

\exercise\label{exe:iter}
Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
all @{prop"i < n"}:
\<close>

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter0: "iter r 0 x x" |
iterS: "\<lbrakk>r x y; iter r n y z \<rbrakk> \<Longrightarrow> iter r (Suc n) x z"

text \<open>
Correct and prove the following claim:
\<close>

lemma "star r x y \<Longrightarrow> \<exists> n. iter r n x y"
  apply (induction rule: star.induct)
  apply (blast intro: iter0)
  by (blast intro: iterS)

text \<open>
\endexercise

\exercise\label{exe:cfg}
A context-free grammar can be seen as an inductive definition where each
nonterminal $A$ is an inductively defined predicate on lists of terminal
symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
For example, the production $S \to aSb$ can be viewed as the implication
@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
i.e., elements of some alphabet. The alphabet can be defined as a datatype:
\<close>

datatype alpha = alphaa | alphab

text \<open>
If you think of @{const alphaa} and @{const alphab} as ``@{text "("}'' and  ``@{text ")"}'',
the following two grammars both generate strings of balanced parentheses
(where $\varepsilon$ is the empty word):
\[
\begin{array}{r@ {\quad}c@ {\quad}l}
S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
T &\to& \varepsilon \quad\mid\quad TaTb
\end{array}
\]
Define them as inductive predicates and prove their equivalence:
\<close>

inductive S :: "alpha list \<Rightarrow> bool" where
S_\<epsilon>: "S []" |
S_aSb: "S w \<Longrightarrow> S (alphaa # w @ [alphab])" |
S_SS: "\<lbrakk> S v; S w \<rbrakk> \<Longrightarrow> S (v @ w)"

inductive T :: "alpha list \<Rightarrow> bool" where
T_\<epsilon>: "T []" |
T_TaTb: "\<lbrakk> T v; T w \<rbrakk> \<Longrightarrow> T (v @ [alphaa] @ w @ [alphab])"

lemma TS: "T w \<Longrightarrow> S w"
  apply (induction rule: T.induct)
  by (auto intro: S_\<epsilon> S_SS S_aSb)

lemma ST_aux_1: "[] @ [alphaa] @ w @ [alphab] = alphaa # w @ [alphab]"
  by simp

lemma ST_aux_2: "T v \<Longrightarrow> T w \<Longrightarrow> T (w @ v)"
  apply (induction rule: T.induct)
  apply simp
  by (subst append_assoc [THEN sym], blast intro: T_TaTb)

lemma ST: "S w \<Longrightarrow> T w"
  apply (induction rule: S.induct)
    apply (rule T_\<epsilon>)
   apply (subst ST_aux_1 [THEN sym], rule T_TaTb, rule T_\<epsilon>, assumption)
  by (rule ST_aux_2)

corollary SeqT: "S w \<longleftrightarrow> T w"
  by (auto intro: TS ST)

text \<open>
\endexercise
\<close>

text \<open>
\exercise
In Chapter 3 we defined a recursive evaluation function
@{text "aval ::"} @{typ "aexp \<Rightarrow> state \<Rightarrow> val"}.
Define an inductive evaluation predicate and prove that it agrees with
the recursive function:
\<close>

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
aval_N: "aval_rel (N i) s i" |
aval_V: "aval_rel (V x) s (s x)" |
aval_Plus: "\<lbrakk> aval_rel e\<^sub>1 s v\<^sub>1; aval_rel e\<^sub>2 s v\<^sub>2 \<rbrakk> \<Longrightarrow> aval_rel (Plus e\<^sub>1 e\<^sub>2) s (v\<^sub>1 + v\<^sub>2)"

lemma aval_rel_aval: "aval_rel e s v \<Longrightarrow> aval e s = v"
  apply (induction rule: aval_rel.induct)
  by auto

lemma aval_aval_rel: "aval e s = v \<Longrightarrow> aval_rel e s v"
  apply (induction e arbitrary: v)
  by (auto simp add: aval_N aval_V aval_Plus)

corollary "aval_rel e s v \<longleftrightarrow> aval e s = v"
  by (blast intro: aval_rel_aval aval_aval_rel)

text \<open>
\endexercise

\exercise
Consider the stack machine from Chapter~3
and recall the concept of \concept{stack underflow}
from Exercise~\ref{exe:stack-underflow}.
Define an inductive predicate
\<close>

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
ok_Nil: "ok 0 [] 0" |
ok_Pad: "ok n is n' \<Longrightarrow> ok (Suc n) is (Suc n')" |
ok_LOADI: "ok (Suc n) is n' \<Longrightarrow> ok n (LOADI i # is) n'" |
ok_LOAD: "ok (Suc n) is n' \<Longrightarrow> ok n (LOAD x # is) n'" |
ok_ADD: "ok (Suc n) is n' \<Longrightarrow> ok (Suc (Suc n)) (ADD # is) n'"

text \<open>
such that @{text "ok n is n'"} means that with any initial stack of length
@{text n} the instructions @{text "is"} can be executed
without stack underflow and that the final stack has length @{text n'}.

Using the introduction rules for @{const ok},
prove the following special cases: \<close>

lemma "ok 0 [LOAD x] (Suc 0)"
  by (auto intro: ok_Nil ok_Pad ok_LOAD)

lemma "ok 0 [LOAD x, LOADI v, ADD] (Suc 0)"
  apply (rule ok_LOAD)
  apply (rule ok_LOADI)
  apply (rule ok_ADD)
  apply (rule ok_Pad)
  by (rule ok_Nil)

lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
  apply (rule ok_LOAD)
  apply (rule ok_ADD)
  apply (rule ok_ADD)
  apply (rule ok_LOAD)
  apply (rule ok_Pad)
  apply (rule ok_Pad)
  by (rule ok_Nil)

text  \<open> Prove that @{text ok} correctly computes the final stack size: \<close>

(* near impossible (probably impossible) without _tac and without using Isar *)

(* because of ok_Pad, inversion rules need to induct over that case *)
lemma ok_Nil_inv_aux: "\<lbrakk>ok n j n'; j = []\<rbrakk> \<Longrightarrow> n = n'"
  apply (induction rule: ok.induct)
  by auto

lemma ok_Nil_inv: "ok n [] n' \<Longrightarrow> n = n'"
  by (simp add: ok_Nil_inv_aux)

lemma ok_LOADI_inv_aux: "\<lbrakk>ok n j n'; j = LOADI i # iss\<rbrakk> \<Longrightarrow> ok (Suc n) iss n'"
  apply (induction rule: ok.induct)
  by (auto simp add: ok.ok_Pad)

lemma ok_LOADI_inv: "ok n (LOADI i # iss) n' \<Longrightarrow> ok (Suc n) iss n'"
  by (simp add: ok_LOADI_inv_aux)

lemma ok_LOAD_inv_aux: "\<lbrakk>ok n j n'; j = LOAD x # iss\<rbrakk> \<Longrightarrow> ok (Suc n) iss n'"
  apply (induction rule: ok.induct)
  by (auto simp add: ok.ok_Pad)

lemma ok_LOAD_inv: "ok n (LOAD x # iss) n' \<Longrightarrow> ok (Suc n) iss n'"
  by (simp add: ok_LOAD_inv_aux)

lemma ok_ADD_inv_aux: "\<lbrakk>ok n j n'; j = ADD # iss\<rbrakk> \<Longrightarrow> \<exists> k. ok (Suc k) iss n' \<and> n = (Suc (Suc k))"
  apply (induction rule: ok.induct)
  by (auto simp add: ok.ok_Pad)

lemma ok_ADD_inv: "ok n (ADD # iss) n' \<Longrightarrow> \<exists> k. ok (Suc k) iss n' \<and> n = (Suc (Suc k))"
  by (auto simp add: ok_ADD_inv_aux)

lemma "\<lbrakk>ok n inss n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec inss s stk) = n'"
proof (induct inss arbitrary: n n' stk)
  case Nil
  thus ?case by (simp add: ok_Nil_inv)
next
  case (Cons a inss)
  note H = this
  thus ?case
  proof (cases a)
    case (LOADI i)
    thus ?thesis using Cons.hyps H(2) H(3) ok_LOADI_inv by fastforce
  next
    case (LOAD x)
    note Hx = this
    thus ?thesis using Cons.hyps H(2) H(3) ok_LOAD_inv by fastforce
  next
    case ADD
    note Ha = this
    from H(2) obtain k where H2': "ok (Suc k) inss n'" and H2eq: "n = (Suc (Suc k))" using Ha ok_ADD_inv by blast
    from H(3) H2eq have H3': "length stk = Suc (Suc k)" by simp
    then obtain x y stkr where Hstk: "stk = x # y # stkr" by (metis Suc_length_conv)
    hence H3'': "length ((y + x) # stkr) = Suc k" using H3' by simp
    from Ha Hstk have "length (exec (a # inss) s stk) = length (exec (ADD # inss) s (x # y # stkr))" by simp
    also have "\<dots> = length (exec inss s ((y + x) # stkr))" by simp
    also
    from H(1) H2' H3'' have "\<dots> = n'" by simp
    finally show ?thesis .
  qed
qed

text  \<open>
Lemma @{thm [source] length_Suc_conv} may come in handy.

Prove that instruction sequences generated by @{text comp}
cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
some suitable value of @{text "?"}.
\endexercise
\<close>

end


(*  Title:      ZF/ex/Primes.thy
    Author:     Christophe Tabacznyj and Lawrence C Paulson
    Copyright   1996  University of Cambridge
*)

section\<open>The Divides Relation and Euclid's algorithm for the GCD\<close>

theory Primes imports ZF begin

definition
  divides :: "[i,i]\<Rightarrow>o"              (infixl \<open>dvd\<close> 50)  where
    "m dvd n \<equiv> m \<in> nat \<and> n \<in> nat \<and> (\<exists>k \<in> nat. n = m#*k)"

definition
  is_gcd  :: "[i,i,i]\<Rightarrow>o"     \<comment> \<open>definition of great common divisor\<close>  where
    "is_gcd(p,m,n) \<equiv> ((p dvd m) \<and> (p dvd n))   \<and>
                       (\<forall>d\<in>nat. (d dvd m) \<and> (d dvd n) \<longrightarrow> d dvd p)"

definition
  gcd     :: "[i,i]\<Rightarrow>i"       \<comment> \<open>Euclid's algorithm for the gcd\<close>  where
    "gcd(m,n) \<equiv> transrec(natify(n),
                        \<lambda>n f. \<lambda>m \<in> nat.
                                if n=0 then m else f`(m mod n)`n) ` natify(m)"

definition
  coprime :: "[i,i]\<Rightarrow>o"       \<comment> \<open>the coprime relation\<close>  where
    "coprime(m,n) \<equiv> gcd(m,n) = 1"

definition
  prime   :: i                \<comment> \<open>the set of prime numbers\<close>  where
   "prime \<equiv> {p \<in> nat. 1<p \<and> (\<forall>m \<in> nat. m dvd p \<longrightarrow> m=1 | m=p)}"

subsection\<open>The Divides Relation\<close>

lemma dvdD: "m dvd n \<Longrightarrow> m \<in> nat \<and> n \<in> nat \<and> (\<exists>k \<in> nat. n = m#*k)"
by (unfold divides_def, assumption)

lemma dvdE:
     "\<lbrakk>m dvd n;  \<And>k. \<lbrakk>m \<in> nat; n \<in> nat; k \<in> nat; n = m#*k\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (blast dest!: dvdD)

lemmas dvd_imp_nat1 = dvdD [THEN conjunct1]
lemmas dvd_imp_nat2 = dvdD [THEN conjunct2, THEN conjunct1]

lemma dvd_0_right [simp]: "m \<in> nat \<Longrightarrow> m dvd 0"
apply (simp add: divides_def)
apply (fast intro: nat_0I mult_0_right [symmetric])
done

lemma dvd_0_left: "0 dvd m \<Longrightarrow> m = 0"
by (simp add: divides_def)

lemma dvd_refl [simp]: "m \<in> nat \<Longrightarrow> m dvd m"
apply (simp add: divides_def)
apply (fast intro: nat_1I mult_1_right [symmetric])
done

lemma dvd_trans: "\<lbrakk>m dvd n; n dvd p\<rbrakk> \<Longrightarrow> m dvd p"
by (auto simp add: divides_def intro: mult_assoc mult_type)

lemma dvd_anti_sym: "\<lbrakk>m dvd n; n dvd m\<rbrakk> \<Longrightarrow> m=n"
apply (simp add: divides_def)
apply (force dest: mult_eq_self_implies_10
             simp add: mult_assoc mult_eq_1_iff)
done

lemma dvd_mult_left: "\<lbrakk>(i#*j) dvd k; i \<in> nat\<rbrakk> \<Longrightarrow> i dvd k"
by (auto simp add: divides_def mult_assoc)

lemma dvd_mult_right: "\<lbrakk>(i#*j) dvd k; j \<in> nat\<rbrakk> \<Longrightarrow> j dvd k"
apply (simp add: divides_def, clarify)
apply (rule_tac x = "i#*ka" in bexI)
apply (simp add: mult_ac)
apply (rule mult_type)
done

subsection\<open>Euclid's Algorithm for the GCD\<close>

lemma gcd_0 [simp]: "gcd(m,0) = natify(m)"
apply (simp add: gcd_def)
apply (subst transrec, simp)
done

lemma gcd_natify1 [simp]: "gcd(natify(m),n) = gcd(m,n)"
by (simp add: gcd_def)

lemma gcd_natify2 [simp]: "gcd(m, natify(n)) = gcd(m,n)"
by (simp add: gcd_def)

lemma gcd_non_0_raw:
    "\<lbrakk>0<n;  n \<in> nat\<rbrakk> \<Longrightarrow> gcd(m,n) = gcd(n, m mod n)"
apply (simp add: gcd_def)
apply (rule_tac P = "\<lambda>z. left (z) = right" for left right in transrec [THEN ssubst])
apply (simp add: ltD [THEN mem_imp_not_eq, THEN not_sym]
                 mod_less_divisor [THEN ltD])
done

lemma gcd_non_0: "0 < natify(n) \<Longrightarrow> gcd(m,n) = gcd(n, m mod n)"
apply (cut_tac m = m and n = "natify (n) " in gcd_non_0_raw)
apply auto
done

lemma gcd_1 [simp]: "gcd(m,1) = 1"
by (simp (no_asm_simp) add: gcd_non_0)

lemma dvd_add: "\<lbrakk>k dvd a; k dvd b\<rbrakk> \<Longrightarrow> k dvd (a #+ b)"
apply (simp add: divides_def)
apply (fast intro: add_mult_distrib_left [symmetric] add_type)
done

lemma dvd_mult: "k dvd n \<Longrightarrow> k dvd (m #* n)"
apply (simp add: divides_def)
apply (fast intro: mult_left_commute mult_type)
done

lemma dvd_mult2: "k dvd m \<Longrightarrow> k dvd (m #* n)"
apply (subst mult_commute)
apply (blast intro: dvd_mult)
done

(* k dvd (m*k) *)
lemmas dvdI1 [simp] = dvd_refl [THEN dvd_mult]
lemmas dvdI2 [simp] = dvd_refl [THEN dvd_mult2]

lemma dvd_mod_imp_dvd_raw:
     "\<lbrakk>a \<in> nat; b \<in> nat; k dvd b; k dvd (a mod b)\<rbrakk> \<Longrightarrow> k dvd a"
apply (case_tac "b=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (blast intro: mod_div_equality [THEN subst]
             elim: dvdE
             intro!: dvd_add dvd_mult mult_type mod_type div_type)
done

lemma dvd_mod_imp_dvd: "\<lbrakk>k dvd (a mod b); k dvd b; a \<in> nat\<rbrakk> \<Longrightarrow> k dvd a"
apply (cut_tac b = "natify (b)" in dvd_mod_imp_dvd_raw)
apply auto
apply (simp add: divides_def)
done

(*Imitating TFL*)
lemma gcd_induct_lemma [rule_format (no_asm)]: "\<lbrakk>n \<in> nat;
         \<forall>m \<in> nat. P(m,0);
         \<forall>m \<in> nat. \<forall>n \<in> nat. 0<n \<longrightarrow> P(n, m mod n) \<longrightarrow> P(m,n)\<rbrakk>
      \<Longrightarrow> \<forall>m \<in> nat. P (m,n)"
apply (erule_tac i = n in complete_induct)
apply (case_tac "x=0")
apply (simp (no_asm_simp))
apply clarify
apply (drule_tac x1 = m and x = x in bspec [THEN bspec])
apply (simp_all add: Ord_0_lt_iff)
apply (blast intro: mod_less_divisor [THEN ltD])
done

lemma gcd_induct: "\<And>P. \<lbrakk>m \<in> nat; n \<in> nat;
         \<And>m. m \<in> nat \<Longrightarrow> P(m,0);
         \<And>m n. \<lbrakk>m \<in> nat; n \<in> nat; 0<n; P(n, m mod n)\<rbrakk> \<Longrightarrow> P(m,n)\<rbrakk>
      \<Longrightarrow> P (m,n)"
by (blast intro: gcd_induct_lemma)

subsection\<open>Basic Properties of \<^term>\<open>gcd\<close>\<close>

text\<open>type of gcd\<close>
lemma gcd_type [simp,TC]: "gcd(m, n) \<in> nat"
apply (subgoal_tac "gcd (natify (m), natify (n)) \<in> nat")
apply simp
apply (rule_tac m = "natify (m)" and n = "natify (n)" in gcd_induct)
apply auto
apply (simp add: gcd_non_0)
done

text\<open>Property 1: gcd(a,b) divides a and b\<close>

lemma gcd_dvd_both:
     "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> gcd (m, n) dvd m \<and> gcd (m, n) dvd n"
apply (rule_tac m = m and n = n in gcd_induct)
apply (simp_all add: gcd_non_0)
apply (blast intro: dvd_mod_imp_dvd_raw nat_into_Ord [THEN Ord_0_lt])
done

lemma gcd_dvd1 [simp]: "m \<in> nat \<Longrightarrow> gcd(m,n) dvd m"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_dvd_both)
apply auto
done

lemma gcd_dvd2 [simp]: "n \<in> nat \<Longrightarrow> gcd(m,n) dvd n"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_dvd_both)
apply auto
done

text\<open>if f divides a and b then f divides gcd(a,b)\<close>

lemma dvd_mod: "\<lbrakk>f dvd a; f dvd b\<rbrakk> \<Longrightarrow> f dvd (a mod b)"
apply (simp add: divides_def)
apply (case_tac "b=0")
 apply (simp add: DIVISION_BY_ZERO_MOD, auto)
apply (blast intro: mod_mult_distrib2 [symmetric])
done

text\<open>Property 2: for all a,b,f naturals,
               if f divides a and f divides b then f divides gcd(a,b)\<close>

lemma gcd_greatest_raw [rule_format]:
     "\<lbrakk>m \<in> nat; n \<in> nat; f \<in> nat\<rbrakk>
      \<Longrightarrow> (f dvd m) \<longrightarrow> (f dvd n) \<longrightarrow> f dvd gcd(m,n)"
apply (rule_tac m = m and n = n in gcd_induct)
apply (simp_all add: gcd_non_0 dvd_mod)
done

lemma gcd_greatest: "\<lbrakk>f dvd m;  f dvd n;  f \<in> nat\<rbrakk> \<Longrightarrow> f dvd gcd(m,n)"
apply (rule gcd_greatest_raw)
apply (auto simp add: divides_def)
done

lemma gcd_greatest_iff [simp]: "\<lbrakk>k \<in> nat; m \<in> nat; n \<in> nat\<rbrakk>
      \<Longrightarrow> (k dvd gcd (m, n)) \<longleftrightarrow> (k dvd m \<and> k dvd n)"
by (blast intro!: gcd_greatest gcd_dvd1 gcd_dvd2 intro: dvd_trans)

subsection\<open>The Greatest Common Divisor\<close>

text\<open>The GCD exists and function gcd computes it.\<close>

lemma is_gcd: "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> is_gcd(gcd(m,n), m, n)"
by (simp add: is_gcd_def)

text\<open>The GCD is unique\<close>

lemma is_gcd_unique: "\<lbrakk>is_gcd(m,a,b); is_gcd(n,a,b); m\<in>nat; n\<in>nat\<rbrakk> \<Longrightarrow> m=n"
apply (simp add: is_gcd_def)
apply (blast intro: dvd_anti_sym)
done

lemma is_gcd_commute: "is_gcd(k,m,n) \<longleftrightarrow> is_gcd(k,n,m)"
by (simp add: is_gcd_def, blast)

lemma gcd_commute_raw: "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> gcd(m,n) = gcd(n,m)"
apply (rule is_gcd_unique)
apply (rule is_gcd)
apply (rule_tac [3] is_gcd_commute [THEN iffD1])
apply (rule_tac [3] is_gcd, auto)
done

lemma gcd_commute: "gcd(m,n) = gcd(n,m)"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_commute_raw)
apply auto
done

lemma gcd_assoc_raw: "\<lbrakk>k \<in> nat; m \<in> nat; n \<in> nat\<rbrakk>
      \<Longrightarrow> gcd (gcd (k, m), n) = gcd (k, gcd (m, n))"
apply (rule is_gcd_unique)
apply (rule is_gcd)
apply (simp_all add: is_gcd_def)
apply (blast intro: gcd_dvd1 gcd_dvd2 gcd_type intro: dvd_trans)
done

lemma gcd_assoc: "gcd (gcd (k, m), n) = gcd (k, gcd (m, n))"
apply (cut_tac k = "natify (k)" and m = "natify (m)" and n = "natify (n) "
       in gcd_assoc_raw)
apply auto
done

lemma gcd_0_left [simp]: "gcd (0, m) = natify(m)"
by (simp add: gcd_commute [of 0])

lemma gcd_1_left [simp]: "gcd (1, m) = 1"
by (simp add: gcd_commute [of 1])

subsection\<open>Addition laws\<close>

lemma gcd_add1 [simp]: "gcd (m #+ n, n) = gcd (m, n)"
apply (subgoal_tac "gcd (m #+ natify (n), natify (n)) = gcd (m, natify (n))")
apply simp
apply (case_tac "natify (n) = 0")
apply (auto simp add: Ord_0_lt_iff gcd_non_0)
done

lemma gcd_add2 [simp]: "gcd (m, m #+ n) = gcd (m, n)"
apply (rule gcd_commute [THEN trans])
apply (subst add_commute, simp)
apply (rule gcd_commute)
done

lemma gcd_add2' [simp]: "gcd (m, n #+ m) = gcd (m, n)"
by (subst add_commute, rule gcd_add2)

lemma gcd_add_mult_raw: "k \<in> nat \<Longrightarrow> gcd (m, k #* m #+ n) = gcd (m, n)"
apply (erule nat_induct)
apply (auto simp add: gcd_add2 add_assoc)
done

lemma gcd_add_mult: "gcd (m, k #* m #+ n) = gcd (m, n)"
apply (cut_tac k = "natify (k)" in gcd_add_mult_raw)
apply auto
done

subsection\<open>Multiplication Laws\<close>

lemma gcd_mult_distrib2_raw:
     "\<lbrakk>k \<in> nat; m \<in> nat; n \<in> nat\<rbrakk>
      \<Longrightarrow> k #* gcd (m, n) = gcd (k #* m, k #* n)"
apply (erule_tac m = m and n = n in gcd_induct, assumption)
apply simp
apply (case_tac "k = 0", simp)
apply (simp add: mod_geq gcd_non_0 mod_mult_distrib2 Ord_0_lt_iff)
done

lemma gcd_mult_distrib2: "k #* gcd (m, n) = gcd (k #* m, k #* n)"
apply (cut_tac k = "natify (k)" and m = "natify (m)" and n = "natify (n) "
       in gcd_mult_distrib2_raw)
apply auto
done

lemma gcd_mult [simp]: "gcd (k, k #* n) = natify(k)"
by (cut_tac k = k and m = 1 and n = n in gcd_mult_distrib2, auto)

lemma gcd_self [simp]: "gcd (k, k) = natify(k)"
by (cut_tac k = k and n = 1 in gcd_mult, auto)

lemma relprime_dvd_mult:
     "\<lbrakk>gcd (k,n) = 1;  k dvd (m #* n);  m \<in> nat\<rbrakk> \<Longrightarrow> k dvd m"
apply (cut_tac k = m and m = k and n = n in gcd_mult_distrib2, auto)
apply (erule_tac b = m in ssubst)
apply (simp add: dvd_imp_nat1)
done

lemma relprime_dvd_mult_iff:
     "\<lbrakk>gcd (k,n) = 1;  m \<in> nat\<rbrakk> \<Longrightarrow> k dvd (m #* n) \<longleftrightarrow> k dvd m"
by (blast intro: dvdI2 relprime_dvd_mult dvd_trans)

lemma prime_imp_relprime:
     "\<lbrakk>p \<in> prime;  \<not> (p dvd n);  n \<in> nat\<rbrakk> \<Longrightarrow> gcd (p, n) = 1"
apply (simp add: prime_def, clarify)
apply (drule_tac x = "gcd (p,n)" in bspec)
apply auto
apply (cut_tac m = p and n = n in gcd_dvd2, auto)
done

lemma prime_into_nat: "p \<in> prime \<Longrightarrow> p \<in> nat"
by (simp add: prime_def)

lemma prime_nonzero: "p \<in> prime \<Longrightarrow> p\<noteq>0"
by (auto simp add: prime_def)

text\<open>This theorem leads immediately to a proof of the uniqueness of
  factorization.  If \<^term>\<open>p\<close> divides a product of primes then it is
  one of those primes.\<close>

lemma prime_dvd_mult:
     "\<lbrakk>p dvd m #* n; p \<in> prime; m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> p dvd m \<or> p dvd n"
by (blast intro: relprime_dvd_mult prime_imp_relprime prime_into_nat)

lemma gcd_mult_cancel_raw:
     "\<lbrakk>gcd (k,n) = 1; m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> gcd (k #* m, n) = gcd (m, n)"
apply (rule dvd_anti_sym)
 apply (rule gcd_greatest)
  apply (rule relprime_dvd_mult [of _ k])
apply (simp add: gcd_assoc)
apply (simp add: gcd_commute)
apply (simp_all add: mult_commute)
apply (blast intro: dvdI1 gcd_dvd1 dvd_trans)
done

lemma gcd_mult_cancel: "gcd (k,n) = 1 \<Longrightarrow> gcd (k #* m, n) = gcd (m, n)"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_mult_cancel_raw)
apply auto
done

subsection\<open>The Square Root of a Prime is Irrational: Key Lemma\<close>

lemma prime_dvd_other_side:
     "\<lbrakk>n#*n = p#*(k#*k); p \<in> prime; n \<in> nat\<rbrakk> \<Longrightarrow> p dvd n"
apply (subgoal_tac "p dvd n#*n")
 apply (blast dest: prime_dvd_mult)
apply (rule_tac j = "k#*k" in dvd_mult_left)
 apply (auto simp add: prime_def)
done

lemma reduction:
     "\<lbrakk>k#*k = p#*(j#*j); p \<in> prime; 0 < k; j \<in> nat; k \<in> nat\<rbrakk>
      \<Longrightarrow> k < p#*j \<and> 0 < j"
apply (rule ccontr)
apply (simp add: not_lt_iff_le prime_into_nat)
apply (erule disjE)
 apply (frule mult_le_mono, assumption+)
apply (simp add: mult_ac)
apply (auto dest!: natify_eqE
            simp add: not_lt_iff_le prime_into_nat mult_le_cancel_le1)
apply (simp add: prime_def)
apply (blast dest: lt_trans1)
done

lemma rearrange: "j #* (p#*j) = k#*k \<Longrightarrow> k#*k = p#*(j#*j)"
by (simp add: mult_ac)

lemma prime_not_square:
     "\<lbrakk>m \<in> nat; p \<in> prime\<rbrakk> \<Longrightarrow> \<forall>k \<in> nat. 0<k \<longrightarrow> m#*m \<noteq> p#*(k#*k)"
apply (erule complete_induct, clarify)
apply (frule prime_dvd_other_side, assumption)
apply assumption
apply (erule dvdE)
apply (simp add: mult_assoc mult_cancel1 prime_nonzero prime_into_nat)
apply (blast dest: rearrange reduction ltD)
done

end


(*  Author: Tobias Nipkow, 2007 *)

section \<open>Lists as vectors\<close>

theory ListVector
imports Main
begin

text\<open>\noindent
A vector-space like structure of lists and arithmetic operations on them.
Is only a vector space if restricted to lists of the same length.\<close>

text\<open>Multiplication with a scalar:\<close>

abbreviation scale :: "('a::times) \<Rightarrow> 'a list \<Rightarrow> 'a list" (infix "*\<^sub>s" 70)
where "x *\<^sub>s xs \<equiv> map ((*) x) xs"

lemma scale1[simp]: "(1::'a::monoid_mult) *\<^sub>s xs = xs"
by (induct xs) simp_all

subsection \<open>\<open>+\<close> and \<open>-\<close>\<close>

fun zipwith0 :: "('a::zero \<Rightarrow> 'b::zero \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list"
where
"zipwith0 f [] [] = []" |
"zipwith0 f (x#xs) (y#ys) = f x y # zipwith0 f xs ys" |
"zipwith0 f (x#xs) [] = f x 0 # zipwith0 f xs []" |
"zipwith0 f [] (y#ys) = f 0 y # zipwith0 f [] ys"

instantiation list :: ("{zero, plus}") plus
begin

definition
  list_add_def: "(+) = zipwith0 (+)"

instance ..

end

instantiation list :: ("{zero, uminus}") uminus
begin

definition
  list_uminus_def: "uminus = map uminus"

instance ..

end

instantiation list :: ("{zero,minus}") minus
begin

definition
  list_diff_def: "(-) = zipwith0 (-)"

instance ..

end

lemma zipwith0_Nil[simp]: "zipwith0 f [] ys = map (f 0) ys"
by(induct ys) simp_all

lemma list_add_Nil[simp]: "[] + xs = (xs::'a::monoid_add list)"
by (induct xs) (auto simp:list_add_def)

lemma list_add_Nil2[simp]: "xs + [] = (xs::'a::monoid_add list)"
by (induct xs) (auto simp:list_add_def)

lemma list_add_Cons[simp]: "(x#xs) + (y#ys) = (x+y)#(xs+ys)"
by(auto simp:list_add_def)

lemma list_diff_Nil[simp]: "[] - xs = -(xs::'a::group_add list)"
by (induct xs) (auto simp:list_diff_def list_uminus_def)

lemma list_diff_Nil2[simp]: "xs - [] = (xs::'a::group_add list)"
by (induct xs) (auto simp:list_diff_def)

lemma list_diff_Cons_Cons[simp]: "(x#xs) - (y#ys) = (x-y)#(xs-ys)"
by (induct xs) (auto simp:list_diff_def)

lemma list_uminus_Cons[simp]: "-(x#xs) = (-x)#(-xs)"
by (induct xs) (auto simp:list_uminus_def)

lemma self_list_diff:
  "xs - xs = replicate (length(xs::'a::group_add list)) 0"
by(induct xs) simp_all

lemma list_add_assoc: fixes xs :: "'a::monoid_add list"
shows "(xs+ys)+zs = xs+(ys+zs)"
apply(induct xs arbitrary: ys zs)
 apply simp
apply(case_tac ys)
 apply(simp)
apply(simp)
apply(case_tac zs)
 apply(simp)
apply(simp add: add.assoc)
done

subsection "Inner product"

definition iprod :: "'a::ring list \<Rightarrow> 'a list \<Rightarrow> 'a" ("\<langle>_,_\<rangle>") where
"\<langle>xs,ys\<rangle> = (\<Sum>(x,y) \<leftarrow> zip xs ys. x*y)"

lemma iprod_Nil[simp]: "\<langle>[],ys\<rangle> = 0"
by(simp add: iprod_def)

lemma iprod_Nil2[simp]: "\<langle>xs,[]\<rangle> = 0"
by(simp add: iprod_def)

lemma iprod_Cons[simp]: "\<langle>x#xs,y#ys\<rangle> = x*y + \<langle>xs,ys\<rangle>"
by(simp add: iprod_def)

lemma iprod0_if_coeffs0: "\<forall>c\<in>set cs. c = 0 \<Longrightarrow> \<langle>cs,xs\<rangle> = 0"
apply(induct cs arbitrary:xs)
 apply simp
apply(case_tac xs) apply simp
apply auto
done

lemma iprod_uminus[simp]: "\<langle>-xs,ys\<rangle> = -\<langle>xs,ys\<rangle>"
by(simp add: iprod_def uminus_sum_list_map o_def split_def map_zip_map list_uminus_def)

lemma iprod_left_add_distrib: "\<langle>xs + ys,zs\<rangle> = \<langle>xs,zs\<rangle> + \<langle>ys,zs\<rangle>"
apply(induct xs arbitrary: ys zs)
apply (simp add: o_def split_def)
apply(case_tac ys)
apply simp
apply(case_tac zs)
apply (simp)
apply(simp add: distrib_right)
done

lemma iprod_left_diff_distrib: "\<langle>xs - ys, zs\<rangle> = \<langle>xs,zs\<rangle> - \<langle>ys,zs\<rangle>"
apply(induct xs arbitrary: ys zs)
apply (simp add: o_def split_def)
apply(case_tac ys)
apply simp
apply(case_tac zs)
apply (simp)
apply(simp add: left_diff_distrib)
done

lemma iprod_assoc: "\<langle>x *\<^sub>s xs, ys\<rangle> = x * \<langle>xs,ys\<rangle>"
apply(induct xs arbitrary: ys)
apply simp
apply(case_tac ys)
apply (simp)
apply (simp add: distrib_left mult.assoc)
done

end


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

text{*\noindent
Define the datatype of \rmindex{binary trees}:
*}

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

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

text{*\noindent
Define a function @{term"mirror"} that mirrors a binary tree
by swapping subtrees recursively. Prove
*}

lemma mirror_mirror: "mirror(mirror t) = t"
(*<*)
apply(induct_tac t)
by(auto)

primrec flatten :: "'a tree => 'a list" where
"flatten Tip = []" |
"flatten (Node l x r) = flatten l @ [x] @ flatten r"
(*>*)

text{*\noindent
Define a function @{term"flatten"} that flattens a tree into a list
by traversing it in infix order. Prove
*}

lemma "flatten(mirror t) = rev(flatten t)"
(*<*)
apply(induct_tac t)
by(auto)

end
(*>*)


(*  Title:      RealInt.thy
    Author:     Sven Linker

Closed, non-empty intervals based on real numbers. Defines functions left, right
to refer to the left (resp. right) border of an interval.

Defines a length function as the difference between left and right border
and a function to shift an interval by a real value (i.e., the value is added
to both borders).

Instantiates "order", as a notion of sub-intervals.

Also contains a "chopping" predicate R_Chop(r,s,t): r can be divided into
sub-intervals s and t.
*)

section \<open>Closed Real-valued Intervals\<close>

text\<open>We define a type for real-valued intervals. It consists of pairs of real numbers, where
the first is lesser or equal to the second. Both endpoints are understood to be part of
the interval, i.e., the intervals are closed. This also implies that we do not
consider empty intervals.

We define a measure on these intervals as the difference between the left and
right endpoint. In addition, we introduce a notion of shifting an interval by
a real value \(x\). Finally, an interval \(r\) can be chopped into \(s\) and
\(t\), if the left endpoint of \(r\) and \(s\) as well as the right endpoint
of \(r\) and \(t\) coincides, and if the right endpoint of \(s\) is
the left endpoint of \(t\).
\<close>

theory RealInt
  imports HOL.Real
begin

typedef real_int = "{r::(real*real) . fst r \<le> snd r}"
  by auto
setup_lifting type_definition_real_int

lift_definition left::"real_int \<Rightarrow> real" is fst proof - qed
lift_definition right::"real_int \<Rightarrow> real" is snd proof - qed

lemmas[simp] = left.rep_eq right.rep_eq

locale real_int
interpretation real_int_class?: real_int .

context real_int
begin

definition length :: "real_int \<Rightarrow> real" ("\<parallel>_\<parallel>" 70)
  where "\<parallel>r\<parallel> \<equiv> right r - left r"

definition shift::"real_int \<Rightarrow> real \<Rightarrow> real_int" (" shift _ _")
  where "(shift r x) = Abs_real_int(left r +x, right r +x)"

definition R_Chop :: "real_int \<Rightarrow> real_int \<Rightarrow> real_int \<Rightarrow> bool" ("R'_Chop'(_,_,_')" 51)
  where rchop_def :
    "R_Chop(r,s,t) ==  left r  = left s \<and> right s = left t \<and> right r =  right t"

end

text \<open>The intervals defined in this way allow for the definition of an order:
the subinterval relation.\<close>

instantiation real_int :: order
begin
definition "less_eq_real_int r s \<equiv> (left r \<ge> left s) \<and> (right r \<le> right s)"
definition "less_real_int r s \<equiv> (left r \<ge> left s) \<and> (right r \<le> right s)
                                  \<and>  \<not>((left s \<ge> left r) \<and> (right s \<le> right r))"
instance
proof
  fix r s t :: real_int
  show "(r < s) = (r \<le> s \<and> \<not> s \<le> r)" using less_eq_real_int_def less_real_int_def by auto
  show "r \<le> r" using less_eq_real_int_def by auto
  show "r \<le> s \<Longrightarrow> s \<le> t \<Longrightarrow> r \<le> t" using less_eq_real_int_def by auto
  show "r \<le> s \<Longrightarrow> s \<le> r \<Longrightarrow> r = s"
    by (metis Rep_real_int_inject left.rep_eq less_le less_eq_real_int_def
        not_le prod.collapse right.rep_eq)
qed
end

context real_int
begin

lemma left_leq_right: "left r \<le> right r"
  using Rep_real_int left.rep_eq right.rep_eq by auto

lemma length_ge_zero :" \<parallel>r\<parallel> \<ge> 0"
  using Rep_real_int left.rep_eq right.rep_eq length_def by auto

lemma consec_add:
  "left r = left s \<and> right r = right t \<and> right s = left t \<Longrightarrow> \<parallel>r\<parallel> = \<parallel>s\<parallel> + \<parallel>t\<parallel>"
  by (simp add:length_def)

lemma length_zero_iff_borders_eq:"\<parallel>r\<parallel> = 0 \<longleftrightarrow> left r = right r"
  using length_def by auto

lemma shift_left_eq_right:"left (shift r x) \<le> right (shift r x)"
  using left_leq_right .

lemma chop_empty2:"R_Chop(r,s,t) \<and> \<parallel>t\<parallel> = 0 \<longrightarrow> r = s "
  by (metis (no_types, hide_lams) Rep_real_int_inject left.rep_eq prod.collapse
      real_int.length_zero_iff_borders_eq real_int.rchop_def right.rep_eq)

end
(*lemmas[simp] = length_dict *)

end


theory PropLogic
  imports Main
begin

datatype formula =
  V string |
  NOT formula |
  And formula formula (infix "AND" 203) |
  Or formula formula (infix "OR" 202) |
  Imp formula formula (infix "\<rightarrow>" 201)

fun Iff ::"formula \<Rightarrow> formula \<Rightarrow> formula" (infix "\<leftrightarrow>" 200) where
  "Iff a b = (a \<rightarrow> b) AND (b \<rightarrow> a)"

type_synonym state = "string \<Rightarrow> bool"

fun evalFol :: "formula \<Rightarrow> state \<Rightarrow> bool" where
  "evalFol (V n) s = s n" |
  "evalFol (NOT f) s = (\<not> evalFol f s)" |
  "evalFol (a AND b) s = (evalFol a s \<and> evalFol b s)" |
  "evalFol (a OR b) s = (evalFol a s \<or> evalFol b s)" |
  "evalFol (a \<rightarrow> b) s = (evalFol a s \<longrightarrow> evalFol b s)"

fun nnfNot :: "formula \<Rightarrow> formula" where
  "nnfNot (NOT a) = a" |
  "nnfNot (a OR b) = (nnfNot a AND nnfNot b)" |
  "nnfNot (a AND b) = (nnfNot a OR nnfNot b)" |
  "nnfNot other = NOT other"

fun toNNF :: "formula \<Rightarrow> formula" where
  "toNNF (V s) = V s" |
  "toNNF (NOT f) = nnfNot (toNNF f)" |
  "toNNF (a AND b) = toNNF a AND toNNF b" |
  "toNNF (a OR b) = toNNF a OR toNNF b" |
  "toNNF (a \<rightarrow> b) = nnfNot (toNNF a) OR toNNF b"

abbreviation equiv :: "formula \<Rightarrow> formula \<Rightarrow> bool" (infix "\<sim>" 199) where
 "a \<sim> b \<equiv> (\<forall>s. evalFol a s = evalFol b s)"

value "toNNF (NOT (V ''p'' \<rightarrow> V ''p'' AND V ''q''))"

lemma nnfNot_equiv: "evalFol (nnfNot f) s = (\<not> evalFol f s)"
  by(induction f rule: nnfNot.induct, auto)

lemma nnf_equiv: "toNNF f \<sim> f"
  by(induction f rule: toNNF.induct, auto simp add: nnfNot_equiv)

text{* function to test if a formula is in NNF *}

fun inNNF :: "formula \<Rightarrow> bool" where
  "inNNF (V v) = True" |
  "inNNF (NOT (V a)) = True" |
  "inNNF (NOT _) = False" |
  "inNNF (a AND b) = (inNNF a \<and> inNNF b)" |
  "inNNF (a OR b) = (inNNF a \<and> inNNF b)" |
  "inNNF (_ \<rightarrow> _) = False"

lemma nnfNot_preserve_inNNF: "inNNF f \<Longrightarrow> inNNF (nnfNot f)"
  by(induction f rule: inNNF.induct, auto)

lemma nnf_inNNF: "inNNF (toNNF f)" using nnfNot_preserve_inNNF
  by(induction f, auto)

text{* test if a formula is in DNF *}

fun noAnd :: "formula \<Rightarrow> bool" where
  "noAnd (V _) = True" |
  "noAnd (_ AND _) = False" |
  "noAnd (a OR b) = (noAnd a \<and> noAnd b)" |
  "noAnd (NOT v) = noAnd v" |
  "noAnd (a \<rightarrow> b) = (noAnd a \<and> noAnd b)"

fun distrAndOverOr_and :: "formula \<Rightarrow> formula \<Rightarrow> formula" where
  "distrAndOverOr_and (f1 OR f2) f3 = (distrAndOverOr_and f1 f3 OR distrAndOverOr_and f2 f3)" |
  "distrAndOverOr_and f3 (f1 OR f2) = (distrAndOverOr_and f3 f1 OR distrAndOverOr_and f3 f2)" |
  "distrAndOverOr_and a b = a AND b"

lemma distrAndOverOr_and_equiv : "distrAndOverOr_and a b \<sim> (a AND b)"
  by(induction a b rule: distrAndOverOr_and.induct, auto)

fun distrAndOverOr :: "formula \<Rightarrow> formula" where
  "distrAndOverOr (a AND b) = distrAndOverOr_and (distrAndOverOr a) (distrAndOverOr b)" |
  "distrAndOverOr (a OR b) = (distrAndOverOr a) OR distrAndOverOr b" |
  "distrAndOverOr (a \<rightarrow> b) = (distrAndOverOr a) \<rightarrow> distrAndOverOr b" |
  "distrAndOverOr other = other"

lemma distrAndOverOr_equiv: "distrAndOverOr f \<sim> f"
  using distrAndOverOr_and_equiv
  by(induction f rule: distrAndOverOr.induct, auto)

fun toDNF :: "formula \<Rightarrow> formula" where
  "toDNF f = distrAndOverOr (toNNF f)"

value "toDNF ((V ''q1'' OR NOT (NOT (V ''q2''))) AND (NOT (V ''r1'') \<rightarrow> V ''r2''))"

lemma toDNF_equiv: "toDNF f \<sim> f"
proof-
  have "toDNF f \<sim> toNNF f" using distrAndOverOr_equiv by auto
  then show ?thesis using nnf_equiv by auto
qed

value "toDNF ((V ''1'' OR V ''2'' ) AND (V ''3'' OR V ''4'' ))"

fun distrOrOverAnd_or :: "formula \<Rightarrow> formula \<Rightarrow> formula" where
  "distrOrOverAnd_or (f1 AND f2) f3 = (distrOrOverAnd_or f1 f3 AND distrOrOverAnd_or f2 f3)" |
  "distrOrOverAnd_or f3 (f1 AND f2) = (distrOrOverAnd_or f3 f1 AND distrOrOverAnd_or f3 f2)" |
  "distrOrOverAnd_or a b = a OR b"

lemma distrOrOverAnd_or_equiv : "distrOrOverAnd_or a b \<sim> (a OR b)"
  by(induction a b rule: distrOrOverAnd_or.induct, auto)

fun distrOrOverAnd :: "formula \<Rightarrow> formula" where
  "distrOrOverAnd (a OR b) = distrOrOverAnd_or (distrOrOverAnd a) (distrOrOverAnd b)" |
  "distrOrOverAnd (a AND b) = (distrOrOverAnd a) AND distrOrOverAnd b" |
  "distrOrOverAnd (a \<rightarrow> b) = (distrOrOverAnd a) \<rightarrow> distrOrOverAnd b" |
  "distrOrOverAnd other = other"

lemma distrOrOverAnd_equiv: "distrOrOverAnd f \<sim> f"
  using distrOrOverAnd_or_equiv
    by (induction f rule: distrOrOverAnd.induct, auto)

fun toCNF :: "formula \<Rightarrow> formula" where
  "toCNF f = distrOrOverAnd (toNNF f)"


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

section \<open>Sorted lists as representation of finite sets\<close>

theory Sorted_List
imports Main
begin

text \<open>Merge function for two distinct sorted lists to get compound distinct sorted list\<close>

fun merge :: "('a::linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "merge (x#xs) (y#ys) =
  (if x < y then x # merge xs (y#ys) else (if x > y then y # merge (x#xs) ys else x # merge xs ys))"
| "merge xs [] = xs"
| "merge [] ys = ys"

text \<open>The function package does not derive automatically the more general rewrite rule as follows:\<close>
lemma merge_Nil[simp]: "merge [] ys = ys"
by (cases ys) auto

lemma set_merge[simp]: "set (merge xs ys) = set xs \<union> set ys"
by (induct xs ys rule: merge.induct, auto)

lemma sorted_merge[simp]:
     "List.sorted (merge xs ys) = (List.sorted xs \<and> List.sorted ys)"
by (induct xs ys rule: merge.induct, auto)

lemma distinct_merge[simp]: "\<lbrakk> distinct xs; distinct ys; List.sorted xs; List.sorted ys \<rbrakk> \<Longrightarrow> distinct (merge xs ys)"
by (induct xs ys rule: merge.induct, auto)

text \<open>The remove function removes an element from a sorted list\<close>

primrec remove :: "('a :: linorder) \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "remove a [] = []"
  |  "remove a (x#xs) = (if a > x then (x # remove a xs) else (if a = x then xs else x#xs))"

lemma remove': "sorted xs \<and> distinct xs \<Longrightarrow> sorted (remove a xs) \<and> distinct (remove a xs) \<and> set (remove a xs) = set xs - {a}"
apply (induct xs)
apply (auto)
done

lemma set_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> set (remove a xs) = set xs - {a}"
using remove' by auto

lemma sorted_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> sorted (remove a xs)"
using remove' by auto

lemma distinct_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> distinct (remove a xs)"
using remove' by auto

lemma remove_insort_cancel: "remove a (insort a xs) = xs"
apply (induct xs)
apply simp
apply auto
done

lemma remove_insort_commute: "\<lbrakk> a \<noteq> b; sorted xs \<rbrakk> \<Longrightarrow> remove b (insort a xs) = insort a (remove b xs)"
apply (induct xs)
apply auto
apply (case_tac xs)
apply auto
done

lemma notinset_remove: "x \<notin> set xs \<Longrightarrow> remove x xs = xs"
apply (induct xs)
apply auto
done

lemma remove1_eq_remove:
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow> remove1 x xs = remove x xs"
apply (induct xs)
apply (auto)
apply (subgoal_tac "x \<notin> set xs")
apply (simp add: notinset_remove)
apply fastforce
done

lemma sorted_remove1:
  "sorted xs \<Longrightarrow> sorted (remove1 x xs)"
apply (induct xs)
apply (auto)
done

subsection \<open>Efficient member function for sorted lists\<close>

primrec smember :: "'a list \<Rightarrow> 'a::linorder \<Rightarrow> bool" where
  "smember [] x \<longleftrightarrow> False"
| "smember (y#ys) x \<longleftrightarrow> x = y \<or> (x > y \<and> smember ys x)"

lemma "sorted xs \<Longrightarrow> smember xs x \<longleftrightarrow> (x \<in> set xs)"
  by (induct xs) (auto)

end


theory a2
imports Main
begin

(**********************************************)
(* PART 1: "Compiling Arithmetic Expressions" *)
(**********************************************)

(* Syntax of the language *)
datatype expr = BinOp "(nat \<Rightarrow> nat \<Rightarrow> nat)" expr expr |
                UnOp "(nat \<Rightarrow> nat)" expr |
                Const nat

definition
  plus :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "plus \<equiv> (\<lambda>a b. a + b)"

lemma "plus = (op +)"
  by(simp add: plus_def)

(* Evaluation function *)
primrec
  eval :: "expr \<Rightarrow> nat"
where
  "eval (Const n) = n" |
  "eval (BinOp f a b) = f (eval a) (eval b)" |
  "eval (UnOp f a) = f (eval a)"

lemma "eval (BinOp (op +) (Const 2) (Const 3)) = 5"
  by simp

(* Programs for the stack machine *)
datatype stackp = Push nat |
                  DoUnOp "nat \<Rightarrow> nat" |
                  DoBinOp "nat \<Rightarrow> nat \<Rightarrow> nat" |
                  Seq stackp stackp ("_ ;; _")  |
                  Skip
print_theorems
type_synonym stack = "nat list"

(* Big step operational semantics to programs for the stack machine *)
inductive
  sem :: "stack \<Rightarrow> stackp \<Rightarrow> stack \<Rightarrow> bool" ("\<langle>_, _\<rangle> \<Down> _")
where
  sem_Push: "sem s (Push n) (n#s)" |
  sem_DoBinOp: "sem (a#b#s) (DoBinOp f) ((f a b)#s)" |
  sem_DoUnOp: "sem (a#s) (DoUnOp f) ((f a)#s)" |
  sem_Seq: "\<lbrakk>sem s a t; sem t b u\<rbrakk> \<Longrightarrow> sem s (Seq a b) u"

print_theorems

inductive_cases sem_PushE[elim!]: "\<langle>s, Push n\<rangle> \<Down> u"
inductive_cases sem_DoBinOpE[elim!]: "\<langle>s, DoBinOp f\<rangle> \<Down> u"
inductive_cases sem_DoUnOpE[elim!]: "\<langle>s, DoUnOp f\<rangle> \<Down> u"
inductive_cases sem_Seq[elim!]: "\<langle>s, Seq a b\<rangle> \<Down> u"
inductive_cases sem_SkipE[elim!]: "\<langle>s, Skip\<rangle> \<Down> u"

declare sem.intros[simp, intro]

(* Simple compiler from expression to stack programs *)
primrec
  compile  :: "expr \<Rightarrow> stackp"
where
  "compile (Const n) = Push n" |
  "compile (BinOp f a b) = Seq (compile b) (Seq (compile a) (DoBinOp f))" |
  "compile (UnOp f a) = Seq (compile a) (DoUnOp f)"

(* ---------- *)
(* Question 1 *)
(* ---------- *)

(* (a) Prove that the stack machine semantics is deterministic *)
lemma sem_det:
  "sem s e t \<Longrightarrow> sem s e u \<Longrightarrow> u = t"
  (***TODO***)
  apply (induct arbitrary:u rule: sem.induct)
   apply (erule sem.cases)
      apply simp+
    apply (erule sem.cases)
      apply simp+
    apply (erule sem.cases)
      apply blast+
    done

(* (b) Prove that the compiler is correct *)
lemma compile_correct:
  "sem s (compile e) ((eval e)#s)"
  (***TODO***)
  apply (induct e arbitrary: s)
    apply simp_all
      apply blast+
  done

(* (c) Prove that whether an expression can evaluate
       depends only on the size of the initial stack *)
lemma sem_stack_content_agnostic_a:
  "sem s p t \<Longrightarrow> \<forall>s'. length s' = length s \<longrightarrow> (\<exists>t'. sem s' p t' \<and> length t = length t')"
    apply (induct rule: sem.induct)
    apply auto[1]
      apply clarsimp
      apply (case_tac s')
        apply simp
      apply (case_tac list)
        apply simp
        apply (rule_tac x="f a aa# lista" in exI)
        apply simp
        apply clarsimp
       apply (case_tac s')
        apply simp
        apply (rule_tac x="f a # list" in exI)
        apply simp
       apply clarsimp
        apply (case_tac s')
          apply auto[1]
        apply (erule_tac x="s'" in allE)
          apply clarsimp
        apply (erule_tac x="t'" in allE)
          apply clarsimp
          apply auto
   done

lemma sem_stack_content_agnostic:
   "sem s p t \<Longrightarrow> \<forall>s'. length s' = length s \<longrightarrow> (\<exists>t'. sem s' p t')"
  (***TODO***)
    apply(drule sem_stack_content_agnostic_a)
      apply blast
    done

(* ---------- *)
(* Question 2 *)
(* ---------- *)

(* Sufficient initial stack size *)
definition
  reqd_init_stack :: "stackp \<Rightarrow> nat \<Rightarrow> bool"
where
  "reqd_init_stack p h \<equiv> (\<exists>s t. \<langle>s,p\<rangle> \<Down> t) \<longrightarrow> (\<forall>s. length s \<ge> h \<longrightarrow> (\<exists>t. \<langle>s,p\<rangle> \<Down> t))"

(* (a) Prove that compiled expressions require no initial stack *)
lemma compile_reqd_init_stack:
  "reqd_init_stack (compile e) 0"
  (***TODO***)
  apply (simp add: reqd_init_stack_def)
   apply (rule impI)
     apply (rule allI)
   apply (rule_tac x="eval e#s" in exI)
    apply (simp add: compile_correct)
  done

(* (b) Minimal initial stack length for atomic programs *)
lemma reqd_init_stack_Push:
  "reqd_init_stack (Push n) 0"
  (***TODO***)
  apply (simp add: reqd_init_stack_def)
  apply (rule impI)
    apply (erule exE)+
    apply (rule allI)
    apply blast
  done

lemma reqd_init_stack_DoUnOp:
  "reqd_init_stack (DoUnOp f) (Suc 0)"
  (***TODO***)
  apply (simp add: reqd_init_stack_def)
    apply (rule impI)
    apply (rule allI)
   apply (erule exE)
   apply (erule exE)
    apply (rule impI)
   apply (case_tac s)
     apply simp+
    apply (rule_tac x="f a#list" in exI)
     apply simp
  done

lemma reqd_init_stack_DoBinOp:
  "reqd_init_stack (DoBinOp f) (Suc (Suc 0))"
  (***TODO***)
  apply (simp add: reqd_init_stack_def)
    apply (rule impI)
      apply (rule allI)
        apply (erule exE)+
        apply (rule impI)
    apply (case_tac s)
      apply simp
     apply (case_tac list)
      apply simp+
        apply blast
  done

lemma reqd_init_stack_Skip:
  "reqd_init_stack Skip 0"
  (***TODO***)
  apply (simp add: reqd_init_stack_def)
    apply (rule impI)
  apply (rule allI)
  apply (erule exE)+
    apply blast
  done

(* (c) Minimal initial stack length for Seq *)
lemma reqd_init_stack_Seq:
  "\<lbrakk>(reqd_init_stack p1) n; (reqd_init_stack p2 m)\<rbrakk>
       \<Longrightarrow> (reqd_init_stack (Seq p1 p2) (m + n))"
  (****TODO***)
   apply (induct p1)
    apply auto
   apply (clarsimp simp: reqd_init_stack_def)
    apply auto
   apply (induct p2)
    apply auto
   apply blast+
    apply (case_tac sa)
     apply (clarsimp simp: reqd_init_stack_Push)
      apply blast
  prefer 5
   apply (clarsimp simp: reqd_init_stack_def)
  prefer 2
   apply (clarsimp simp: reqd_init_stack_def)
    apply auto
    apply (case_tac sb)
    apply blast+

  sorry

(* (d) Define a function that given a program p
       calculates an appropriate stack length h
       such that reqd_init_stack p h holds *)

primrec
  sufficient_init_stack :: "stackp \<Rightarrow> nat"
where
  (***TODO***)
  "sufficient_init_stack (Push n) = 0"|
  "sufficient_init_stack (DoBinOp f) = (Suc 0)"|
  "sufficient_init_stack (DoUnOp f) = (Suc (Suc 0))"|
  "sufficient_init_stack (Seq p1 p2) = sufficient_init_stack p1 + sufficient_init_stack p2"|
  "sufficient_init_stack Skip = 0"

(* (e) Prove your function from (d) correct *)
lemma sufficient_init_stack_is_reqd_init_stack:
  "reqd_init_stack p (sufficient_init_stack p)"
  (***TODO***)
  apply (induct p)
    apply auto[1]
  prefer 5
    apply (clarsimp simp: reqd_init_stack_Skip)
      apply (clarsimp simp: reqd_init_stack_Push)
      apply (clarsimp simp: reqd_init_stack_def)
        apply (case_tac sb)
          apply auto[1]
        apply (clarsimp simp: reqd_init_stack_DoUnOp)
          apply auto
         apply (clarsimp simp: reqd_init_stack_def)
          apply (case_tac sb)
          apply auto[1]
         apply (clarsimp simp: reqd_init_stack_def)
   prefer 2
      apply (clarsimp simp: reqd_init_stack_def)
        apply auto[1]
        apply (case_tac sa)

  sorry

(* ---------- *)
(* Question 3 *)
(* ---------- *)

(*  Small-step semantics *)
inductive
  sems :: "stack \<Rightarrow> stackp \<Rightarrow> stack \<Rightarrow> stackp \<Rightarrow> bool"
where
  "sems s (Push n) (n#s) Skip" |
  "sems (a#b#s) (DoBinOp f) ((f a b)#s) Skip" |
  "sems (a#s) (DoUnOp f) ((f a)#s) Skip" |
  "sems s a s' a' \<Longrightarrow> sems s (Seq a b) s' (Seq a' b)" |
  "sems s (Seq Skip b) s b"

(* (a) Define a function semsn:: nat \<Rightarrow> stack \<Rightarrow> stackp \<Rightarrow> stack \<Rightarrow> stackp \<Rightarrow> bool
       that executes n steps of the small-step semantics *)

primrec
  semsn :: "nat \<Rightarrow> stack \<Rightarrow> stackp \<Rightarrow> stack \<Rightarrow> stackp \<Rightarrow> bool"
where
  "semsn 0 s a s' a' = sems s (Seq Skip a) s a" |
  "semsn (Suc n) s a s' a' = (\<exists>s1 a1. sems s a s1 a1 \<and> semsn n s1 a1 s' a')"

(* (b) Prove that if a program a executes in the big-step semantics to a
       resulting stack t from an initial stack s, then it executes in the
       small-step semantics to the same resulting stack and the resulting
       program Skip. *)
lemma semsn_correct:
  "sem s a t \<Longrightarrow> \<exists>n. semsn n s a t Skip"
  (***TODO***)
  apply (induct)
    using sems.intros(5) semsn.simps(1)
      apply blast
    using sems.intros(5) semsn.simps(1)
      apply blast
    using sems.intros(5) semsn.simps(1)
      apply blast
    using sems.intros(5) semsn.simps(1)
      apply blast
    using sems.intros(5) semsn.simps(1)
      apply blast
  done

(* (c) Prove that there is no universal stack bound for any compiled program *)
(* Predicate stating that stack size h is a stack bound for program p *)

definition
  stack_bound :: "stackp \<Rightarrow> nat \<Rightarrow> bool"
where
  "stack_bound p h \<equiv> \<forall>s n s' p'. semsn n s p s' p' \<longrightarrow>  length s' - length s \<le> h"

primrec
  prog_using_Suc :: "nat \<Rightarrow> expr"
where
  "prog_using_Suc 0 = Const 0" |
  "prog_using_Suc (Suc n) = (BinOp (op +) (prog_using_Suc n) (Const 0))"

lemma compile_has_no_universal_stack_bound:
  "\<not> (\<exists>h. (\<forall>p. stack_bound (compile p) h))"
  apply (induct)
    apply (metis Suc_n_not_le_n diff_zero length_replicate sems.intros(5) semsn.simps(1) stack_bound_def)
    apply (metis Suc_n_not_le_n diff_zero length_replicate sems.intros(5) semsn.simps(1) stack_bound_def)
    apply (metis Suc_n_not_le_n diff_zero length_replicate sems.intros(5) semsn.simps(1) stack_bound_def)
    apply auto
    apply (metis Suc_n_not_le_n diff_zero length_replicate sems.intros(5) semsn.simps(1) stack_bound_def)
  done

(****************************************)
(* PART 2: "Rewriting rules for groups" *)
(****************************************)

(* Replace A-H below by equation stating that e is left- and right-neutral,
   and that i is left- and right-inverse, for the \<star> operator.

   Justify why your set of rules is confluent and terminating.
   (why it is safe to add them to the simp set)
*)

axiomatization
  e:: 'a and
  op:: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<star>" 70)  and
  i:: "'a \<Rightarrow> 'a"
where
  neutral_left[simp]: "\<forall>a::'a. e \<star> a = a" and
  neutral_right[simp]: "\<forall>a::'a. a \<star> e = a" and
  inverse_left[simp]: "\<forall>u v::'a. (u \<star> v = e) \<and> (i v = u)" and
  inverse_right[simp]: "\<forall>u v::'a. u \<star> i u = e"

  lemma case_1:
   "10 \<star> a = e"
    apply auto
    done

  lemma case_2:
   "(i a)  \<star> a = e"
    apply auto
    done

   lemma case_3:
   "a \<star> (i a) = e"
    apply auto
    done

(*
  As the lemma case 1 2 3 can be auto proof correct
  the answer could right
  neutral_left:
    all a in a' and use e \<star> a therefore is neutral a
  neutral_right:
    same with neutral_left when a \<star> e neutral_right e
  inverse_left:
    assume u v in a' u \<star> v = e and i v = u thus inverse_left v
  inverse_right:
    same with inverse_left use simp form inverse_right u
*)

end


(* Author: Tobias Nipkow *)

section \<open>Bubblesort\<close>

theory Bubblesort
imports "~~/src/HOL/Library/Multiset"
begin

text\<open>This is \emph{a} version of bubblesort.\<close>

context linorder
begin

fun bubble_min where
"bubble_min [] = []" |
"bubble_min [x] = [x]" |
"bubble_min (x#xs) =
  (case bubble_min xs of y#ys \<Rightarrow> if x>y then y#x#ys else x#y#ys)"

lemma size_bubble_min: "size(bubble_min xs) = size xs"
by(induction xs rule: bubble_min.induct) (auto split: list.split)

lemma bubble_min_eq_Nil_iff[simp]: "bubble_min xs = [] \<longleftrightarrow> xs = []"
by (metis length_0_conv size_bubble_min)

lemma bubble_minD_size: "bubble_min (xs) = ys \<Longrightarrow> size xs = size ys"
by(auto simp: size_bubble_min)

function (sequential) bubblesort where
"bubblesort []  = []" |
"bubblesort [x] = [x]" |
"bubblesort xs  = (case bubble_min xs of y#ys \<Rightarrow> y # bubblesort ys)"
by pat_completeness auto

termination
proof
  show "wf(measure size)" by simp
next
  fix x1 x2 y :: 'a fix xs ys :: "'a list"
  show "bubble_min(x1#x2#xs) = y#ys \<Longrightarrow> (ys, x1#x2#xs) \<in> measure size"
    by(auto simp: size_bubble_min dest!: bubble_minD_size split: list.splits if_splits)
qed

lemma mset_bubble_min: "mset (bubble_min xs) = mset xs"
apply(induction xs rule: bubble_min.induct)
  apply simp
 apply simp
apply (auto simp: add_eq_conv_ex split: list.split)
done

lemma bubble_minD_mset:
  "bubble_min (xs) = ys \<Longrightarrow> mset xs = mset ys"
by(auto simp: mset_bubble_min)

lemma mset_bubblesort:
  "mset (bubblesort xs) = mset xs"
apply(induction xs rule: bubblesort.induct)
  apply simp
 apply simp
by(auto split: list.splits if_splits dest: bubble_minD_mset)

lemma set_bubblesort: "set (bubblesort xs) = set xs"
by(rule mset_bubblesort[THEN mset_eq_setD])

lemma bubble_min_min: "bubble_min xs = y#ys \<Longrightarrow> z \<in> set ys \<Longrightarrow> y \<le> z"
apply(induction xs arbitrary: y ys z rule: bubble_min.induct)
  apply simp
 apply simp
apply (fastforce split: list.splits if_splits dest!: sym[of "a#b" for a b])
done

lemma sorted_bubblesort: "sorted(bubblesort xs)"
apply(induction xs rule: bubblesort.induct)
  apply simp
 apply simp
apply (fastforce simp: set_bubblesort split: list.split if_splits
  intro!: sorted.Cons dest: bubble_min_min)
done

end

end


(*
Title: Perfect Powers
Author: Jose Manuel Rodriguez Caballero

A perfect power is a natural number of the form u^v, with u \<ge> 2 and v \<ge> 2.

We will prove that any natural number n \<ge> 2 can be expressed as n = u^v,
where u \<ge> 2, v \<ge> 1 and u is not perfect power. Furthermore, we will prove that such
a representation is unique.This result belongs to the mathematical folklore.

(This code  was verified in Isabelle2018)

*)

theory PerfectPowers

imports Complex_Main

begin

text {* Definition of perfect powers *}
definition PerfectPower :: "nat \<Rightarrow> bool" where
  "PerfectPower \<equiv> \<lambda> n. (\<exists> u v::nat. n = u^v \<and> u \<ge> 2 \<and> v \<ge> 2)"

section {* Existence of the representation *}

lemma PPRepresentationBaseAux :
  shows \<open> \<not>(PerfectPower 2)\<close>
  by (metis (mono_tags, hide_lams) One_nat_def PerfectPower_def lessI less_le_trans linorder_not_le numerals(2) power_le_imp_le_exp power_one_right)

lemma PPRepresentationBase :
  shows \<open>\<exists> u v::nat. 2 = u^v \<and> u \<ge> 2 \<and> v \<ge> 1 \<and> \<not>(PerfectPower u)\<close>
  using PPRepresentationBaseAux by force

lemma PPRepresentationRefKInd :
  fixes K :: nat
  shows \<open>(\<forall> k.  (k < K \<longrightarrow> ( \<exists> u v::nat. k+2 = u^v \<and> u \<ge> 2 \<and> v \<ge> 1 \<and> \<not>(PerfectPower u)) )) \<Longrightarrow> ( \<exists> u v::nat. K+2 = u^v \<and> u \<ge> 2 \<and> v \<ge> 1 \<and> \<not>(PerfectPower u)) \<close>
proof (cases \<open>PerfectPower (K+2)\<close>)
  case True
  then obtain u v :: nat where \<open>K+2 = u^v\<close> and \<open>u \<ge> 2\<close> and \<open>v \<ge> 2\<close>
    by (meson PerfectPower_def)
  from  \<open>K+2 = u^v\<close> and \<open>u \<ge> 2\<close> and \<open>v \<ge> 2\<close> have \<open>u < K+2\<close>
    by (metis add_leD2 le_neq_implies_less numeral_le_one_iff one_add_one power_increasing_iff power_one_right semiring_norm(69))
  from \<open>u \<ge> 2\<close> obtain j :: nat where \<open>u = j + 2\<close>
    by (metis add_2_eq_Suc add_2_eq_Suc'  le_Suc_ex )
  assume \<open>(\<forall> k.  (k < K \<longrightarrow> ( \<exists> u v::nat. k+2 = u^v \<and> u \<ge> 2 \<and> v \<ge> 1 \<and> \<not>(PerfectPower u)))) \<close>
  then obtain p q :: nat  where \<open>u = p^q\<close> and \<open>p \<ge> 2\<close> and \<open>q \<ge> 1\<close> and \<open> \<not>(PerfectPower p)\<close>
    using \<open>u < K + 2\<close> \<open>u = j + 2\<close> by auto
  obtain s ::nat where \<open>s = q * v\<close> by auto
  from  \<open>K+2 = u^v\<close> and \<open>u = p^q\<close> have  \<open>K+2 = (p^q)^v\<close>
    by blast
  hence \<open>K+2 = p^s\<close> using  \<open>s = q * v\<close>
    by (simp add: semiring_normalization_rules(31))
  have \<open>( \<exists> u v::nat. K+2 = u^v \<and> u \<ge> 2 \<and> v \<ge> 1 \<and> \<not>(PerfectPower u))\<close>
    using \<open>1 \<le> q\<close> \<open>2 \<le> p\<close> \<open>2 \<le> v\<close> \<open>K + 2 = p ^ s\<close> \<open>\<not> PerfectPower p\<close> \<open>s = q * v\<close> by fastforce
  show ?thesis
    using \<open>\<exists>u v. K + 2 = u ^ v \<and> 2 \<le> u \<and> 1 \<le> v \<and> \<not> PerfectPower u\<close> by blast
next
  case False
  thus ?thesis
    by (metis le_add2 le_numeral_extra(4) power_one_right)
qed

lemma PPRepresentationRefK :
  fixes K :: nat
  shows \<open>\<forall> k. (k < K \<longrightarrow> ( \<exists> u v::nat. k+2 = u^v \<and> u \<ge> 2 \<and> v \<ge> 1 \<and> \<not>(PerfectPower u)) )\<close>
proof (induction K)
  case 0
  thus ?case
    using PPRepresentationBase by force
next
  case (Suc K)
  thus ?case
    using PPRepresentationRefKInd by auto
qed

lemma PPRepresentationRef :
  fixes k :: nat
  shows \<open>\<exists> u v::nat. k+2 = u^v \<and> u \<ge> 2 \<and> v \<ge> 1 \<and> \<not>(PerfectPower u)\<close>
  using PPRepresentationRefK by blast

theorem PPRepresentation :
  fixes n :: nat
  assumes \<open>n \<ge> 2\<close>
  shows \<open>\<exists> u v::nat. n = u^v \<and> u \<ge> 2 \<and> v \<ge> 1 \<and> \<not>(PerfectPower u)\<close>
proof-
  from  \<open>n \<ge> 2\<close> obtain k::nat where \<open>n = 2 + k\<close>
    using le_Suc_ex by blast
  from \<open>n = 2 + k\<close> show ?thesis
    using PPRepresentationRef by auto
qed

section {* Uniqueness of the representation *}

lemma PowReg1:
  fixes a b c p :: nat
  assumes \<open> a \<ge> 2\<close> and \<open>b \<ge> 2\<close> and \<open>c \<ge> 2\<close> and \<open>p \<ge> 1\<close> and \<open>a^p = b^p * c\<close>
  shows \<open>b dvd a\<close>
  by (metis assms(4) assms(5) dvd_triv_left gr0I  le_zero_eq  less_numeral_extra(1) pow_divides_pow_iff)

lemma PowReg:
  fixes a b c p :: nat
  assumes \<open> a \<ge> 2\<close> and \<open>b \<ge> 2\<close> and \<open>c \<ge> 2\<close> and \<open>p \<ge> 1\<close> and \<open>a^p = b^p * c\<close>
  shows \<open>\<exists> k::nat. c = k^p\<close>
proof-
  have \<open>b dvd a\<close>
    using PowReg1 assms(1) assms(2) assms(3) assms(4) assms(5) by blast
  obtain k :: nat where \<open>b*k = a\<close>
    using \<open>b dvd a\<close> dvdE by blast
  from  \<open>a^p = b^p * c\<close> have  \<open>b^p*k^p = b^p * c\<close>
    by (metis \<open>b * k = a\<close> power_mult_distrib)
  thus ?thesis
    using assms(2) by auto
qed

lemma nonPerfectPowerChar : \<open>(n::nat) \<ge> 2 \<Longrightarrow> \<not>(PerfectPower n) \<Longrightarrow>  n = u^v \<Longrightarrow> v = 1 \<close>
proof-
  assume \<open>n \<ge> 2\<close>
  assume \<open>\<not>(PerfectPower n)\<close>
  hence \<open>\<not> (\<exists> u v::nat. n = u^v \<and> u \<ge> 2 \<and> v \<ge> 2)\<close>
    by (meson PerfectPower_def)
  hence \<open>\<forall> u v::nat. n \<noteq> u^v \<or> u \<le> 1 \<or> v \<le> 1\<close>
    by (simp add: not_less_eq_eq)
  assume \<open> n = u^v \<close>
  from  \<open> n = u^v \<close>  \<open>\<forall> u v::nat. n \<noteq> u^v \<or> u \<le> 1 \<or> v \<le> 1\<close>  have \<open> u \<le> 1 \<or> v \<le> 1\<close>
    by blast
  from  \<open> n = u^v \<close> \<open>n \<ge> 2\<close> have \<open>u > 1\<close>
    by (metis One_nat_def Suc_leI add_leD2 dual_order.strict_trans1 le_neq_implies_less less_numeral_extra(4) nat_zero_less_power_iff one_add_one one_less_numeral_iff power_0 power_one semiring_norm(76))
  from  \<open> u \<le> 1 \<or> v \<le> 1\<close>   \<open>u > 1\<close> have \<open>v \<le> 1\<close>
    using not_le by blast
  from  \<open> n = u^v \<close> \<open>n \<ge> 2\<close> have \<open>v \<noteq> 0 \<close>
    by (metis One_nat_def nat_power_eq_Suc_0_iff numeral_le_one_iff semiring_norm(69))
  from \<open>v \<noteq> 0 \<close>   \<open>v \<le> 1\<close>  have \<open>v = 1\<close>
    using le_neq_implies_less by blast
  thus ?thesis
    by blast
qed

lemma BezoutNat:
  fixes x y:: nat
  assumes \<open>x > y\<close> and \<open>gcd x y = 1\<close>
  shows \<open>\<exists> a b::nat. a*x = b*y + 1\<close>
  by (metis assms(1) assms(2) bezout_nat gr_implies_not0 semiring_normalization_rules(7))

lemma PPUniquenessRelPrimesRedEqOne :
  fixes n u v p q :: nat
  assumes \<open>n \<ge> 2\<close> and \<open>n = u^v\<close> and \<open>u \<ge> 2\<close> and \<open>v \<ge> 1\<close> and \<open>\<not>(PerfectPower u)\<close>
    and  \<open>n = p^q\<close> and \<open>p \<ge> 2\<close> and \<open>q \<ge> 1\<close> and \<open>\<not>(PerfectPower p)\<close> and \<open>gcd q v = 1\<close> and \<open>q > v\<close>
  shows \<open> v = 1\<close>
proof-
  from \<open>gcd q v = 1\<close> obtain a b :: nat where \<open>a*q = b*v + 1\<close>
    using BezoutNat assms(11) by presburger
  from \<open>n = u^v\<close>  \<open>n = p^q\<close> have \<open>u^v = p^q\<close>
    by blast
  hence \<open>u^(a*v) = p^(a*q)\<close>
    by (metis mult.commute semiring_normalization_rules(31))
  hence \<open>u^(a*v) = p^(b*v + 1)\<close>
    by (simp add: \<open>a * q = b * v + 1\<close>)
  hence  \<open>(u^a)^v = (p^b)^v * p\<close>
    by (simp add: semiring_normalization_rules(31))
  then obtain X Y :: nat where  \<open>X = u^a\<close> and  \<open>Y = p^b\<close>
    by simp
  from  \<open>X = u^a\<close> \<open>Y = p^b\<close>  \<open>(u^a)^v = (p^b)^v * p\<close>   have \<open>X^v = Y^v * p\<close>
    by blast
  have \<open>X \<ge> 2\<close>
    by (metis One_nat_def Suc_leI \<open>(u ^ a) ^ v = (p ^ b) ^ v * p\<close> \<open>X = u ^ a\<close> add_leD2 assms(3) assms(7) le_neq_implies_less nat_1_eq_mult_iff nat_one_le_power numerals(2) one_add_one power_one)
  have \<open>Y \<ge> 2\<close>
    by (metis Groups.mult_ac(2) One_nat_def PerfectPower_def Suc_leI \<open>(u ^ a) ^ v = (p ^ b) ^ v * p\<close> \<open>2 \<le> X\<close> \<open>X = u ^ a\<close> \<open>Y = p ^ b\<close> add_leD2 assms(11) assms(2) assms(4) assms(5) assms(6) assms(7) assms(9) mult_1_right nat_less_le nat_one_le_power numerals(2) one_add_one power_one power_one_right)
  from \<open>X \<ge> 2\<close>  \<open>Y \<ge> 2\<close> \<open>v \<ge> 1\<close> \<open>X^v = Y^v * p\<close> obtain k::nat where \<open>p = k^v\<close>
    using PowReg assms(7) by blast
  from  \<open>p \<ge> 2\<close> \<open>p = k^v\<close> show ?thesis
    using assms(9) nonPerfectPowerChar by blast
qed

lemma PPUniquenessRelPrimesRed :
  fixes n u v p q :: nat
  assumes \<open>n \<ge> 2\<close> and \<open>n = u^v\<close> and \<open>u \<ge> 2\<close> and \<open>v \<ge> 1\<close> and \<open>\<not>(PerfectPower u)\<close>
    and  \<open>n = p^q\<close> and \<open>p \<ge> 2\<close> and \<open>q \<ge> 1\<close> and \<open>\<not>(PerfectPower p)\<close> and \<open>gcd q v = 1\<close> and \<open>q > v\<close>
  shows \<open>u = p \<and> v = q\<close>
  by (metis PPUniquenessRelPrimesRedEqOne assms(1) assms(10) assms(11) assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) assms(8) assms(9) nonPerfectPowerChar power_one_right)

lemma PPUniquenessRelPrimes :
  fixes n u v p q :: nat
  assumes \<open>n \<ge> 2\<close> and \<open>n = u^v\<close> and \<open>u \<ge> 2\<close> and \<open>v \<ge> 1\<close> and \<open>\<not>(PerfectPower u)\<close>
    and  \<open>n = p^q\<close> and \<open>p \<ge> 2\<close> and \<open>q \<ge> 1\<close> and \<open>\<not>(PerfectPower p)\<close> and \<open>gcd q v = 1\<close>
  shows \<open>u = p \<and> v = q\<close>
  by (metis PPUniquenessRelPrimesRed assms(1) assms(10) assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) assms(8) assms(9) gcd.commute gcd_nat.idem nat_neq_iff power_one_right)

theorem PPUniqueness :
  fixes n u v p q :: nat
  assumes \<open>n \<ge> 2\<close> and \<open>n = u^v\<close> and \<open>u \<ge> 2\<close> and \<open>v \<ge> 1\<close> and \<open>\<not>(PerfectPower u)\<close>
    and  \<open>n = p^q\<close> and \<open>p \<ge> 2\<close> and \<open>q \<ge> 1\<close> and \<open>\<not>(PerfectPower p)\<close>
  shows \<open>u = p \<and> v = q\<close>
proof-
  obtain d :: nat where \<open>gcd q v = d\<close> by auto
  from  \<open>gcd q v = d\<close> obtain qq :: nat where \<open> qq * d = q \<close>
    by (metis assms(8) gcd_coprime_exists gcd_eq_0_iff le_numeral_extra(2))
  from  \<open>gcd q v = d\<close> obtain vv :: nat where \<open> vv * d = v \<close>
    by (metis assms(4) gcd_coprime_exists gcd_eq_0_iff less_le_trans less_numeral_extra(3) zero_less_one)
  from  \<open>gcd q v = d\<close> and  \<open> qq * d = q \<close>  and  \<open> vv * d = v \<close>  have \<open>gcd qq vv = 1\<close>
  proof -
    have "d * gcd qq vv dvd d"
      by (metis (no_types) \<open>gcd q v = d\<close> \<open>qq * d = q\<close> \<open>vv * d = v\<close> dvd_refl gcd_mult_distrib_nat semiring_normalization_rules(7))
    thus ?thesis
      by (metis (no_types) \<open>qq * d = q\<close> assms(8) dvd_mult_cancel2 gcd.bottom_left_bottom le_less_trans nat_0_less_mult_iff nat_mult_eq_1_iff order.not_eq_order_implies_strict semiring_normalization_rules(7) zero_le)
  qed
  from \<open>n = p^q\<close> and \<open>n = u^v\<close> have \<open>p^q = u^v\<close>
    by blast
  from \<open>p^q = u^v\<close> and  \<open> qq * d = q \<close> and  \<open> vv * d = v \<close> have \<open>p^qq = u^vv\<close>
    by (smt assms(4) dual_order.strict_implies_order dual_order.strict_trans1 less_numeral_extra(1) nat_0_less_mult_iff not_gr_zero power_eq_0_iff power_eq_iff_eq_base semiring_normalization_rules(31))
  have  \<open>vv \<ge> 1\<close>
    using \<open>vv * d = v\<close> assms(4) by auto
  have  \<open>qq \<ge> 1\<close>
    using \<open>qq * d = q\<close> assms(8) by auto
  obtain nn where \<open>nn = u^vv\<close>
    by simp
  have  \<open>nn = p^qq\<close>
    by (simp add: \<open>nn = u ^ vv\<close> \<open>p ^ qq = u ^ vv\<close>)
  have  \<open>nn \<ge> 2\<close>
    by (metis One_nat_def \<open>nn = p ^ qq\<close> \<open>qq * d = q\<close> add_leD2 antisym_conv assms(1) assms(6) assms(7) nat_one_le_power not_less_eq_eq numerals(2) one_add_one power_one semiring_normalization_rules(31))
  from  \<open>nn \<ge> 2\<close> and \<open>nn = u^vv\<close> and \<open>u \<ge> 2\<close> and \<open>vv \<ge> 1\<close> and \<open>\<not>(PerfectPower u)\<close>
    and  \<open>nn = p^qq\<close> and \<open>p \<ge> 2\<close> and \<open>qq \<ge> 1\<close> and \<open>\<not>(PerfectPower p)\<close> and \<open>gcd qq vv = 1\<close>
  have  \<open>u = p \<and> vv = qq\<close>
    by (meson PPUniquenessRelPrimes)
  show ?thesis
    using \<open>qq * d = q\<close> \<open>u = p \<and> vv = qq\<close> \<open>vv * d = v\<close> by blast
qed

end


theory ex02
  imports Main
begin

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

value "list_sum [1,2,3]"

thm fold.simps

definition list_sum'::"nat list \<Rightarrow> nat" where
  "list_sum' xs \<equiv> fold (+) xs (0::nat)"

value "list_sum' [1,2,3]"

thm list_sum'_def

lemma lemma_aux: "fold (+) xs a = list_sum xs + a"
  apply(induction xs arbitrary: a)
   apply auto
  done

lemma "list_sum xs = list_sum' xs"
  apply (auto simp: list_sum'_def lemma_aux)
  done

datatype 'a ltree = Leaf 'a | Node "'a ltree" "'a ltree"

fun inorder::"'a ltree \<Rightarrow> 'a list" where
  "inorder (Leaf x) = [x]" |
  "inorder (Node l r) = inorder l @ inorder r"

value "inorder (Node (Node (Leaf (1::nat)) (Leaf 2)) (Leaf 3))"

term "fold f (inorder t) s"

value "fold (+) (inorder (Node (Node (Leaf (1::nat)) (Leaf 2)) (Leaf 3))) 0"

fun fold_ltree:: "('a \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> 'a ltree \<Rightarrow> 's \<Rightarrow> 's" where
  "fold_ltree f (Leaf x) s = f x s" |
  "fold_ltree f (Node l r) s = fold_ltree f r (fold_ltree f l s)"

value "fold_ltree (+) (Node (Node (Leaf (1::nat)) (Leaf 2)) (Leaf 3)) 0"

lemma "fold f (inorder t) s = fold_ltree f t s"
  apply(induction t arbitrary: s)
   apply auto
  done

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

value "inorder (mirror (Node (Node (Leaf (1::nat)) (Leaf 2)) (Leaf 3)))"

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

term "map f xs"

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

thm shuffles.induct

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

end


theory P5 imports Main begin

fun first_pos :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat" where
"first_pos P Nil = 0" |
"first_pos P (x # xs) = (if (P x) then 0 else (Suc (first_pos P xs)))"

lemma "first_pos (\<lambda>x. x=3) [1::nat, 3, 5, 3, 1] = 1"
  apply simp
  done

lemma "first_pos (\<lambda>x. x>4) [1::nat, 3, 5, 3, 1] = 2"
  apply simp
  done

lemma "first_pos (\<lambda>x. (length x > 1)) [[], [1, 2], [3]] = 1"
  apply simp
  done

fun member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where
"member Nil x = False" | "member (y # xs) x = (if (x=y) then True else (member xs x))"

lemma [simp]: "\<not> (\<exists>x. member xs x \<and> P x) \<longrightarrow> ((first_pos P xs) = (length xs))"
  apply (induct xs)
   apply auto
  done

theorem "((first_pos P xs) = (length xs)) \<longrightarrow> \<not> (\<exists>x. member xs x \<and> P x)"
  apply simp
  done

lemma "list_all (\<lambda> x. \<not> P x) (take (first_pos P xs) xs)"
  apply (induct xs)
   apply auto
  done

fun min :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"min m n = (if m \<le> n then m else n)"

fun max :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"max m n = (if m \<ge> n then m else n)"

theorem "first_pos (\<lambda> x. P x \<or> Q x) xs = (min (first_pos P xs) (first_pos Q xs))"
  apply (induct xs)
   apply auto
  done

theorem "first_pos (\<lambda> x. P x \<and> Q x) xs = (max (first_pos P xs) (first_pos Q xs))"
  nitpick
  oops

theorem "\<forall>x. (P x \<longrightarrow> (Q x)) \<Longrightarrow> ((first_pos P xs) \<ge> (first_pos Q xs))"
  apply (induct xs)
   apply auto
  done

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

lemma [simp]: "count P (xs @ [a]) = (if (P a) then (Suc (count P xs)) else (count P xs))"
  apply (induct xs)
   apply auto
  done

theorem "count P xs = (count P (rev xs))"
  apply (induct xs)
   apply auto
  done

theorem "count P xs = (length (filter P xs))"
  apply (induct xs)
   apply auto
  done

end


theory Prefix
imports Main
begin

(*
  Prefixes and Prefix Closure of traces
*)
definition prefix :: "'e list \<Rightarrow> 'e list \<Rightarrow> bool" (infixl "\<preceq>" 100)
where
"(l1 \<preceq> l2) \<equiv> (\<exists>l3. l1 @ l3 = l2)"

definition prefixclosed :: "('e list) set \<Rightarrow> bool"
where
"prefixclosed tr \<equiv> (\<forall>l1 \<in> tr. \<forall>l2. l2 \<preceq> l1 \<longrightarrow> l2 \<in> tr)"

(* the empty list is a prefix of every list *)
lemma empty_prefix_of_all: "[] \<preceq> l"
  using prefix_def [of "[]" l] by simp

(* the empty list is in any non-empty prefix-closed set *)
lemma empty_trace_contained: "\<lbrakk> prefixclosed tr ; tr \<noteq> {} \<rbrakk> \<Longrightarrow> [] \<in> tr"
proof -
  assume 1: "prefixclosed tr" and
         2: "tr \<noteq> {}"
  then obtain l1 where "l1 \<in> tr"
    by auto
  with 1 have "\<forall>l2. l2 \<preceq> l1 \<longrightarrow> l2 \<in> tr"
    by (simp add: prefixclosed_def)
  thus "[] \<in> tr"
    by (simp add: empty_prefix_of_all)
qed

(* the prefix-predicate is transitive *)
lemma transitive_prefix: "\<lbrakk> l1 \<preceq> l2 ; l2 \<preceq> l3 \<rbrakk> \<Longrightarrow> l1 \<preceq> l3"
  by (auto simp add: prefix_def)

end


theory R01Sol

imports Main
begin

text {* Relación 1 *}

text {*
  ----------------------------------------------------------------------
  Ejercicio 1. [Cálculo con números naturales]
  Calcular el valor de las siguientes expresiones con números naturales:
  + 2 + 2
  + 2 * (3 + 1)
  + 3 * 4 - 2 * (7 + 1)
  ------------------------------------------------------------------- *}

value "2 + (2::nat)"

text {*
  El resultado es "Suc (Suc (Suc (Suc 0)))" *}

value "(2::nat) * (3 + 1)"

text {*
  El resultado es "Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 0)))))))" *}

value "(3::nat) * 4 - 2 * (7 + 1)"

text {*
  El resultado es "0" *}

text {*
  ----------------------------------------------------------------------
  Ejercicio 2 [Propiedades de los números naturales]

  Ejercicio 2.1. Demostrar que la suma de los naturales es conmutativa.
  ------------------------------------------------------------------- *}

lemma "x + y = y + (x::nat)"
apply auto
done

text {*
  ----------------------------------------------------------------------
  Ejercicio 2.2. Demostrar que la suma de los naturales es asociatativa.
  ------------------------------------------------------------------- *}

lemma "x + (y + z) = (x + y) + (z::nat)"
apply auto
done

text {*
  ----------------------------------------------------------------------
  Ejercicio 3. [Ocurrencias de un elemento en una lista]

  Ejercicio 3.1. Definir la función
     cuenta :: "'a list \<Rightarrow> 'a \<Rightarrow> nat"
  tal que (cuenta xs y) es el número de ocurrencia de y en xs. Por
  ejemplo,
     cuenta [3, 2] 4 = 0
     cuenta [3, 2] 3 = Suc 0
     cuenta [3, 3] 3 = Suc (Suc 0)
     cuenta []     3 = 0
*}

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

value "cuenta [3, 2] (4::nat)"
value "cuenta [3, 2] (3::nat)"
value "cuenta [3, 3] (3::nat)"
value "cuenta [] (3::nat)"

text{*
  ----------------------------------------------------------------------
  Ejercicio 3.2. Demostrar que el número de ocurrencia de cualquier
  elemento en una lista es menor o igual que la longitud de la lista.
  ------------------------------------------------------------------- *}

theorem "cuenta xs x \<le> length xs"
apply (induct xs)
apply auto
done

text {*
  ----------------------------------------------------------------------
  Ejercicio 4. [Añadiendo los elementos al final de la lista e inversa]

  Ejercicio 4.1. Definir, por recursión, la función
     snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
  tal que (snoc xs y) es la lista obtenida añadiendo y al final de xs.
  Por ejemplo,
     snoc [3,5,2] 7 = [3,5,2,7]
*}

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

value "snoc [3,5,2] (7::int)"

lemma "snoc [3,5,2] (7::int) = [3,5,2,7]"
by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 4.2. Definir, por recursión, la función
     inversa :: "'a list \<Rightarrow> 'a list"
  tal que (inversa xs) es la lista obtenida invirtiendo el orden de los
  elementos de xs. Por ejemplo,
     inversa [a, b, c] = [c, b, a]
  ------------------------------------------------------------------- *}

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

value "inversa [a, b, c]"

lemma "inversa [a, b, c] = [c, b, a]"
by simp

text {*
  ----------------------------------------------------------------------
  Ejercicio 4.3. Demostrar que
     inversa (inversa xs) = xs"
  Nota: Se necesita un lema relacionando las funciones inversa y snoc.
  ------------------------------------------------------------------- *}

lemma inversa_snoc: "inversa (snoc xs y) = y # inversa xs"
by (induct xs) auto

theorem "inversa (inversa xs) = xs"
by (induct xs) (auto simp add: inversa_snoc)

text {*
  ----------------------------------------------------------------------
  Ejercicio 4.4. Definir la función
     inversa_it :: "'a list \<Rightarrow> 'a list"
  tal que (inversa_it xs) es la inversa de xs calculada con un
  acumulador. Por ejemplo,
     inversa_it [a,b,c] = [c,b,a]
  ------------------------------------------------------------------- *}

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

fun inversa_it :: "'a list \<Rightarrow> 'a list" where
"inversa_it xs = inversa_it_aux [] xs"

value "inversa_it [a,b,c]"

text {*
  ----------------------------------------------------------------------
  Ejercicio 4.5. Demostrar que
     inversa_it (inversa_it xs) = xs"
  ------------------------------------------------------------------- *}

lemma inversa_it_aux_lemma:
  "\<forall>ys. inversa_it_aux [] (inversa_it_aux ys xs) = inversa_it_aux xs ys"
by (induct xs) auto

lemma "inversa_it (inversa_it xs) = xs"
by (simp add: inversa_it_aux_lemma)

end


theory EvenOdd
  imports Main
begin

thm ccontr

section "Using built-in odd predicate"

lemma
  assumes 0: "odd n"
  shows "odd (n * n)"
proof (rule ccontr)
  assume 1: "\<not> odd (n * n)"

  from 0 obtain a where 2: "n = 2 * a + 1"
    using oddE by auto

  let ?b = "2 * a * a + 2 * a"

  have "n * n = 2 * ?b + 1"
  proof -
    have "n * n = (2 * a + 1) * (2 * a + 1)"
      using 2 by simp
    moreover have "\<dots> = 4 * a * a + 4 * a + 1"
      using 0 1 by simp
    moreover have "\<dots> = 2 * (2 * a * a + 2 * a) + 1"
      using 0 1 by simp
    moreover have "\<dots> = 2 * ?b + 1"
      by simp
    ultimately show ?thesis
      using 0 1 by simp
  qed

  then have "odd (n * n)"
    by simp
  with 1 show False
    by simp
qed

section "Own predicate for odd numbers"

definition isOdd :: "int \<Rightarrow> bool" where
"isOdd n \<equiv> \<exists>a. n = 2 * a + 1"

lemma "isOdd 1"
  by (simp add: isOdd_def)

lemma
  assumes 0: "isOdd n"
  shows "isOdd (n * n)"
proof (rule ccontr)
  assume 1: "\<not> isOdd (n * n)"

  from 0 obtain a where 2: "n = 2 * a + 1"
    using isOdd_def by auto

  let ?b = "2 * a * a + 2 * a"

  have "n * n = 2 * ?b + 1"
  proof -
    have "n * n = (2 * a + 1) * (2 * a + 1)"
      using 2 by simp
    moreover have "\<dots> = 4 * a * a + 4 * a + 1"
      using 0 1 by (simp add: field_simps)
    moreover have "\<dots> = 2 * (2 * a * a + 2 * a) + 1"
      by simp
    moreover have "\<dots> = 2 * ?b + 1"
      by simp
    ultimately show ?thesis
      by simp
  qed

  then have "isOdd (n * n)"
    using isOdd_def by blast

  with 1 show False
    by simp
qed

end


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

section \<open>Sorted lists as representation of finite sets\<close>

theory Sorted_List
imports MainRLT
begin

text \<open>Merge function for two distinct sorted lists to get compound distinct sorted list\<close>

fun merge :: "('a::linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "merge (x#xs) (y#ys) =
  (if x < y then x # merge xs (y#ys) else (if x > y then y # merge (x#xs) ys else x # merge xs ys))"
| "merge xs [] = xs"
| "merge [] ys = ys"

text \<open>The function package does not derive automatically the more general rewrite rule as follows:\<close>
lemma merge_Nil[simp]: "merge [] ys = ys"
by (cases ys) auto

lemma set_merge[simp]: "set (merge xs ys) = set xs \<union> set ys"
by (induct xs ys rule: merge.induct, auto)

lemma sorted_merge[simp]:
     "List.sorted (merge xs ys) = (List.sorted xs \<and> List.sorted ys)"
by (induct xs ys rule: merge.induct, auto)

lemma distinct_merge[simp]: "\<lbrakk> distinct xs; distinct ys; List.sorted xs; List.sorted ys \<rbrakk> \<Longrightarrow> distinct (merge xs ys)"
by (induct xs ys rule: merge.induct, auto)

text \<open>The remove function removes an element from a sorted list\<close>

primrec remove :: "('a :: linorder) \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "remove a [] = []"
  |  "remove a (x#xs) = (if a > x then (x # remove a xs) else (if a = x then xs else x#xs))"

lemma remove': "sorted xs \<and> distinct xs \<Longrightarrow> sorted (remove a xs) \<and> distinct (remove a xs) \<and> set (remove a xs) = set xs - {a}"
apply (induct xs)
apply (auto)
done

lemma set_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> set (remove a xs) = set xs - {a}"
using remove' by auto

lemma sorted_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> sorted (remove a xs)"
using remove' by auto

lemma distinct_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> distinct (remove a xs)"
using remove' by auto

lemma remove_insort_cancel: "remove a (insort a xs) = xs"
apply (induct xs)
apply simp
apply auto
done

lemma remove_insort_commute: "\<lbrakk> a \<noteq> b; sorted xs \<rbrakk> \<Longrightarrow> remove b (insort a xs) = insort a (remove b xs)"
apply (induct xs)
apply auto
apply (case_tac xs)
apply auto
done

lemma notinset_remove: "x \<notin> set xs \<Longrightarrow> remove x xs = xs"
apply (induct xs)
apply auto
done

lemma remove1_eq_remove:
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow> remove1 x xs = remove x xs"
apply (induct xs)
apply (auto)
apply (subgoal_tac "x \<notin> set xs")
apply (simp add: notinset_remove)
apply fastforce
done

lemma sorted_remove1:
  "sorted xs \<Longrightarrow> sorted (remove1 x xs)"
apply (induct xs)
apply (auto)
done

subsection \<open>Efficient member function for sorted lists\<close>

primrec smember :: "'a list \<Rightarrow> 'a::linorder \<Rightarrow> bool" where
  "smember [] x \<longleftrightarrow> False"
| "smember (y#ys) x \<longleftrightarrow> x = y \<or> (x > y \<and> smember ys x)"

lemma "sorted xs \<Longrightarrow> smember xs x \<longleftrightarrow> (x \<in> set xs)"
  by (induct xs) (auto)

end


theory CS_Chap2

  imports Main

begin

(* EXERCISE 2.1 *)
value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

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

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

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

theorem add_commutative: "add m n = add n m"
  apply (induction m)
  apply auto
  done

theorem add_associative: "add a (add b c) = add (add a b) c"
  apply (induction a)
   apply (auto)
  done

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

lemma double_is_2add: "double n = add n n"
  apply (induction n)
   apply auto
  done

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

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

(* EXERCISE 2.4 *)
(* fun snoc: appends an element to the end of a list*)
fun snoc:: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc [] x = x # []" |
  "snoc (x # xs) y = x # (snoc xs y)"

value "snoc [a,b,c] d" (*it works!*)

(*
  We have to prove that length after snoc function is correct,
  so, in reverse function, length is preserved
*)
lemma snoc_length_correctness [simp]: "length(snoc xs x) = Suc(length xs)"
  apply (induction xs)
   apply auto
  done

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

value "reverse [a, b, c]" (* It works! *)

(*
  Now we need this lemma due to show that reverse function preserve
  the order even with a snoc applied
*)
lemma reverse_preserve [simp]: "reverse (snoc xs x) = x # (reverse xs)"
  apply (induction xs)
  apply auto
  done

(* The theorem follows easily *)
theorem "reverse (reverse xs) = xs"
  apply (induction xs)
   apply auto
  done

(* EXERCISE 2.5 *)
fun sum_upto:: "nat \<Rightarrow> nat" where
  "sum_upto 0 = 0" |
  "sum_upto n = n + sum_upto(n - 1)"

value "sum_upto 2"
value "sum_upto 5" (* It works! *)

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

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

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

value "contents (tree 2)"
value "snoc (contents (tree 2 3 4)) 2" (* it works! *)

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

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

value "sumtree (tree 1 2 3)"
value "sumlist [1, 2, 3]" (* It works! *)

theorem "sumtree t = sum_list(contents t)"
  apply (induction t)
   apply auto
  done

(* EXERCISE 2.7 *)

(* The first rule tells to store values in leaves as well*)
datatype 'a tree2 =
  Leaf 'a
  | Node "'a tree2" 'a "'a tree2"

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

lemma mirror_correctness [simp]: "mirror(mirror t) = t"
  apply (induction t)
   apply auto
  done

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
  "pre_order (Leaf 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 (Leaf x) = [x]" |
  "post_order (Node l x r) = post_order l @ post_order r @ [x]"

value "pre_order (tree2 1 2 3)"
value "post_order (tree2 1 2 3)"

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

(* EXERCISE 2.8 *)
(* This is a nice example of the using multiple hashtags *)
fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intersperse a [] = []" |
  "intersperse a (x # xs) = x # (a # intersperse a xs)"

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

(* EXERCISE 2.9 *)
(*
  This function is tail-recursive: the induction step
  begins with the function itself.
*)
fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "itadd 0 m = m" |
  "itadd (Suc m) n = itadd m (Suc n)"

value "itadd 1 2"
value "itadd 1 (itadd 1 1)" (* It works! *)

(* Arbitrary on n makes induction possible *)
theorem "itadd m n = add m n"
  apply (induction m arbitrary: n)
   apply auto
  done

(* EXERCISE 2.10 *)

datatype tree0 = Tip | Node tree0 tree0

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

value "nodes (tree0 Node 1 2)" (* It works *)

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

(*
  A n-factor explode is equivalent to expanding your current tree in n levels.
  Hence, you are adding 2^i nodes for each i-th level. This is basic induction
  over tree height, resulting in 2^n - 1
*)
value "explode 0 (tree0 Tip)" (* = 1 *)
value "explode 1 (tree0 Tip)" (* = 3 *)
value "explode 2 (tree0 Tip)" (* = 7 *)
value "explode 3 (tree0 Tip)" (* = 15 *)

(*
  However, when your initial tree already has T nodes, where T = nodes t,
  you need to count and explode then as well. Therefore, we need to add
  the explosion on each subtree: 2^n * T.
*)
value "explode 0 (tree0 Node l r)" (* = 3 *)
value "explode 1 (tree0 Node l r)" (* = 7 *)
value "explode 2 (tree0 Node l r)" (* = 15 *)
value "explode 3 (tree0 Node l r)" (* = 31 *)

(* Adding the two parts, we have: N = 2^n * T + 2^n - 1 *)
theorem "nodes (explode n t) = 2^n * nodes t + 2^n - 1"
  apply (induction n arbitrary: t)
   apply (auto simp add:algebra_simps)
  done

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

(*
  Note that this simply evaluates an expression and,
  if it has and variable, replaces it by the second argument
*)
fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
  "eval Var n = n" |
  "eval (Const k) n = k" |
  "eval (Add a b) n = eval a n + eval b n" |
  "eval (Mult a b) n = eval a n * eval b n"

value "eval (Add (Const 2) (Const 4)) 1"
value "eval (Add (Var) (Const 4)) 1"
value "eval (Add (Mult (Const 1) (Const 2)) Var) 2" (* It works! *)

(*
  In evalp, for each element on the list, we sum it with the product of n
  and the evalp with the rest of the list.
  The last iteration will always add 0.

  At the end, the expression will be composed by several products. If you
  transform them in operands, you will have the expected polynomial
*)
fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp [] n = 0" |
  "evalp (x # xs) n = x + n * evalp xs n"

value "evalp [1, 2, 4] 1" (* It works! *)

(*
  coeffs function translates an expression into our polynomial-list form.
  This means we convert each term of the expression in a list item. Hence,
  an expression like Add (Mult (Const 1) (Const 2) Var) will
  be converted in []. For every possible expression element:

  - For a constant k, we just add it to the list
  - For a variable, we
  - For an addition, we must sum all terms of the operands
    resulting in a one Const element list
  - For a product, we apply the same logic of addition, but using multiplication
*)

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

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

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

fun coeffs :: "exp \<Rightarrow> int list" where
  "coeffs Var = [0, 1]" |
  "coeffs (Const k) = [k]" |
  "coeffs (Add a b) = sumexp (coeffs a) (coeffs b)" |
  "coeffs (Mult a b) = multexp (coeffs a) (coeffs b)"

value "coeffs (Add (Const 2) (Var))"
value "coeffs (Mult Var Var)"
value "evalp (coeffs (Mult Var Var)) 2" (* It works! *)

lemma evalp_preserve_sum [simp]: "evalp (sumexp xs ys) n = evalp xs n + evalp ys n"
  apply (induction rule:sumexp.induct)
  apply (auto simp add:Int.int_distrib)
  done

lemma evalp_preserve_scalar_mult [simp]: "evalp (scalar_mult n xs) x = n * evalp xs x"
  apply (induction xs)
  apply (auto simp add:Int.int_distrib)
  done

lemma evalp_preserve_mult [simp]: "evalp (multexp xs ys) n = evalp xs n * evalp ys n"
  apply (induction xs)
  apply (auto simp add:Int.int_distrib)
  done

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

end


theory BExp imports AExp begin

subsection "Boolean Expressions"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

text_raw{*\snip{BExpbvaldef}{1}{2}{% *}
fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
  "bval (Bc v) s = v" |
  "bval (Not b) s = (\<not> bval b s)" |
  "bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
  "bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"
text_raw{*}%endsnip*}

value "bval (Less (V ''x'') (Plus (N 3) (V ''y'')))
            <''x'' := 3, ''y'' := 1>"

subsection "Constant Folding"

text{* Optimizing constructors: *}

text_raw{*\snip{BExplessdef}{0}{2}{% *}
fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "less (N n\<^sub>1) (N n\<^sub>2) = Bc(n\<^sub>1 < n\<^sub>2)" |
  "less a\<^sub>1 a\<^sub>2 = Less a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

(* exclusive or *)
fun xor :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
  "xor bl br = And (Not (And bl br)) (or bl br)"

lemma xor_commutative:"bval (xor x y) = bval (xor y x)"
  apply(induction x arbitrary: y)
  by auto

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
 "if2bexp (Bc2 v) = Bc v" |
 "if2bexp (If cond do_true do_false) = or (And (if2bexp cond) (if2bexp do_true)) (And (Not (if2bexp cond)) (if2bexp do_false))" |
 "if2bexp (Less2 a\<^sub>1 a\<^sub>2) = Less a\<^sub>1 a\<^sub>2"

fun b2ifexp::"bexp \<Rightarrow> ifexp" where
  "b2ifexp (Bc v) = Bc2 v" |
  "b2ifexp (Not bexp) = (If (b2ifexp bexp) (Bc2 False) (Bc2 True))" |
  "b2ifexp (And b\<^sub>l b\<^sub>r) = (If (b2ifexp b\<^sub>l) (b2ifexp b\<^sub>r) (Bc2 False))" |
  "b2ifexp (Less a\<^sub>1 a\<^sub>2) = Less2 a\<^sub>1 a\<^sub>2"

lemma "bval (if2bexp ifexp) s = ifval ifexp s"
  apply(induction ifexp)
  by auto

end


theory Exercise2
imports Main
begin

datatype MyNat = Zero | MySuc MyNat

fun myadd :: "MyNat => MyNat => MyNat" where
	"myadd Zero n = n"
	| "myadd (MySuc m) n = MySuc (myadd m n)"

fun double :: "MyNat \<Rightarrow> MyNat" where
  "double Zero = Zero"
  | "double (MySuc m) = MySuc (MySuc (double m))"

theorem myadd_associative [simp]: "myadd (myadd a b) c = myadd a (myadd b c)"
	apply (induction a)
	apply (auto)
done

lemma suc_add_distributivity [simp]: "MySuc (myadd a b) = myadd a (MySuc b)"
  apply (induction a)
  apply (auto)
done

lemma right_identity_zero_add [simp]: "myadd a Zero = a"
  apply (induction a)
  apply (auto)
done

theorem myadd_commutative [simp]: "myadd a b = myadd b a"
	apply (induction a)
	apply (auto)
done

theorem double_add_n_n [simp]: "double n = myadd n n"
  apply (induction n)
  apply (auto)
done

end