theory MyNat imports Main
begin

(* This is the first part of the workshop, introducing some basic concepts of
   Isabelle through some small examples about natural numbers *)

(*
   Unary natural numbers
*)

datatype mynat =
  M0
  | MS "mynat"

(* This looks simple, right? In fact, Isabelle is doing a lot of work behind the scenes
   to present us with the ability to define datatypes this way. Try querying "name:mynat"
   (without quotes) in the "find theorems" pane if you don't believe me :)
*)

fun mynatD :: "mynat \<Rightarrow> nat" where
"mynatD M0 = 0"
| "mynatD (MS m') = 1 + mynatD m'"

fun mynat_plus :: "mynat \<Rightarrow> mynat \<Rightarrow> mynat" where
"mynat_plus M0 x = x"
| "mynat_plus (MS x1) x2 = mynat_plus x1 (MS x2)"

fun mynat_minus :: "mynat \<Rightarrow> mynat \<Rightarrow> mynat" where
"mynat_minus M0 x2 = M0"
| "mynat_minus x1 (M0) = x1"
| "mynat_minus (MS x1) (MS x2) =
   mynat_minus x1 x2"

function (sequential) mynat_minus' :: "mynat \<Rightarrow> mynat \<Rightarrow> mynat" where
"mynat_minus' M0 x2 = M0"
| "mynat_minus' x1 (M0) = x1"
| "mynat_minus' (MS x1) (MS x2) =
   mynat_minus' x1 x2"
  by pat_completeness auto

(*termination by lexicographic_order*)
(* termination by size_change *)

termination
proof(relation "measure (\<lambda> (n1, n2) . mynatD n1)")
  show "wf (measure (\<lambda>(n1, n2). mynatD n1))"
    by auto
next
  fix x1 x2
  show "((x1, x2), MS x1, MS x2) \<in> measure (\<lambda>(n1, n2). mynatD n1)"
    by auto
qed

lemma mynat_plus_correct :
  "mynatD (mynat_plus x1 x2) =
   mynatD x1 + mynatD x2"
proof(induction x1 arbitrary: x2)
case M0
  then show ?case by(auto)
next
  case (MS x1)
    (*  then show ?case by auto *)

    (* let's be pedantic and look at a more manual argument. *)
  show ?case
    unfolding mynat_plus.simps
    using MS.prems MS.IH[of "MS x2"]
    unfolding mynatD.simps
    by simp (* Isabelle's arithmetic automation handles things from here. *)
qed

fun mynat_times :: "mynat \<Rightarrow> mynat \<Rightarrow> mynat" where
"mynat_times M0 _ = M0"
| "mynat_times (MS x) y = mynat_plus y (mynat_times x y)"

(* checking results of a computation is easy!
   (We can generate Haskell/ML code using a related mechanism) *)
(* 2 * 3 = 6 *)
value "mynatD (mynat_times (MS (MS (MS M0))) (MS (MS M0)))"

(*
 * Inductive predicates: evenness and oddness
 *)

(* other uses of induction in isabelle: inductive predicates! *)
inductive myeven :: "mynat \<Rightarrow> bool" and
          myodd :: "mynat \<Rightarrow> bool" where
"myeven M0"
| "myeven x \<Longrightarrow> myodd (MS x)"
| "myodd x \<Longrightarrow> myeven (MS x)"

(* an example of an apply-style proof -
   good for experimentation, but less maintainable. *)
lemma three_odd : "myodd (MS (MS (MS (M0))))"
  apply(rule myeven_myodd.intros)
  apply(rule myeven_myodd.intros)
  apply(rule myeven_myodd.intros)
  apply(rule myeven_myodd.intros)
  done

(* or, more automated: *)
lemma three_odd' : "myodd (MS (MS (MS (M0))))"
  by(auto intro: myeven_myodd.intros)

definition mynat_two :: "mynat" where
"mynat_two = MS (MS (M0))"

(* we could have defined even and odd differently: *)

(* definition is used for defining non-recursive things *)
definition myeven' :: "mynat \<Rightarrow> bool" where
"myeven' x =  (\<exists> x' . x = mynat_times mynat_two x')"

definition myodd' :: "mynat \<Rightarrow> bool" where
"myodd' x = (\<exists> x' . x = MS (mynat_times mynat_two x'))"

(* which is better? the non-inductive definitions tend to be easier to
   compute with, but at the cost of potentially obscuring the inductive structure
   of the predicates, which may complicate some proofs *)

(* exercise, possibly annoying: show these definitions are equivalent *)

(*
 * Rational numbers: a taste of Isabelle typedefs
 *)

(* Originally I was going to try to show this proof using the natural numbers developed
   above, but the details of the proof got annoying. *)

(* isabelle's answer to dependent types: subset types!
   all types (even mynat, e.g.), except for some extremely basic ones,
   are defined "under the hood" as
   nonempty subsets of different
   existing types *)

definition coprime :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"coprime x y =
  (\<forall> n x' y' . n * x' = x \<longrightarrow> n * y' = y \<longrightarrow> n = 1)"

(* convenience lemma for more easily applying coprime in Isabelle proof scripts (see below)
   "E" stands for eliminator (though this might technically be a destructor)
 *)
lemma coprimeE :
  assumes H : "coprime x y"
  assumes Hx : "n * x' = x"
  assumes Hy : "n * y' = y"
  shows "n = 1" using assms
  unfolding coprime_def by auto

lemma mul_bound :
  fixes a b c :: nat
  assumes H1 : "a * b = c"
  assumes H2 : "c \<noteq> 0"
  shows "a \<le> c" using assms
proof-

  have Bnz : "1 \<le> b" using H1 H2
    by(cases b; auto)

  hence "1 * a \<le> b * a" by auto

  thus "a \<le> c" using H1 by  auto
qed

typedef myrat = "{xy :: (nat * nat) .
                  (case xy of (x, y) \<Rightarrow> coprime x y)}"
(* cool, but now we need to show this set isn't empty
   (no, there is no empty/False type in Isabelle's logic - another key
    difference from CiC/dependent types based systems.)
*)
proof-
  have "coprime 2 3" unfolding coprime_def
  proof(step+)
    fix n x' y' :: nat
    assume Hx : "n * x' = 2"
    assume Hy : "n * y' = 3"

    have Xnz : "0 < x'" using Hx by (cases x'; auto)
    have Ynz : "0 < y'" using Hy by (cases y'; auto)
    have Nnz : "0 < n" using Hy by (cases n; auto)

    have Bound : "n \<le> 2" using mul_bound[OF Hx] by auto

    show "n = 1"
    proof(cases n)
      case 0
      then show ?thesis using Nnz by auto
    next
      case Suc1 : (Suc n')
      then show ?thesis
      proof(cases n')
        case 0 (* n = 1 *)
        then show ?thesis using Suc1 by auto
      next
        case Suc2 : (Suc n'')
        then show ?thesis
        proof(cases n'')
          case 0 (* n = 2 is the only interesting case really *)

          hence N2 : "n = 2" using Suc1 Suc2 by auto

          have Hy' : "y' * n = 3" using Hy by(simp add: mult.commute)

          have Bound' : "y' \<le> 3" using mul_bound[OF Hy'] by auto

          (* out of laziness i am not going to write out the full case analysis on y here *)
          then show ?thesis using N2 Hy'
            by(cases y'; auto)
        next
          case Suc3 : (Suc n''')
          then show ?thesis using Suc1 Suc2 Suc3 Bound by auto
        qed
      qed
    qed
  qed

  then show "\<exists>x. x \<in> {xy. case xy of (x, y) \<Rightarrow> MyNat.coprime x y}"
    by auto
qed

(* luckily Isabelle provides primitives for working with typedef'd types more
   conveniently - handles a lot of annoying bookkeeping that comes with converting
   between (nat * nat) and myrat, which while the same structurally are
   different types from Isabelle's point of view. *)
setup_lifting type_definition_myrat

(* an example of an "admitted" theorem.
   be careful with these, you can "prove" absurdities!
   proving this may be annoying because we may need to show a bunch of basic
   mathematical identities. As we'll see below, Isabelle's standard library
   contains such theorems, which is a good reason to use the standard natural
   numbers (and other datatypes too) instead of rolling your own
*)
lemma coprime_square : "coprime a b \<Longrightarrow> coprime (a * a) (b * b)" sorry

definition rat_square' :: "(nat * nat) \<Rightarrow> (nat * nat)" where
"rat_square' xy =
  (case xy of (x, y) \<Rightarrow> ((x * x), (y * y)))"

(* a lifted definition, giving us a function we can use on the typedef'd type *)
lift_definition rat_square :: "myrat \<Rightarrow> myrat" is rat_square'
  using coprime_square unfolding rat_square'_def
  by(auto)

(*
 * A (sort of) interesting theorem: square root of 2 is irrational
 *)

(* we could use what we developed above to prove that sqrt(2) is irrational, but let's simplify
   things again and just express this directly on natural numbers.
   this will let us use some library theorems.

   note the number of library lemmas we end up using here
   (a fun exercise might be seeing if the automation can get through parts of this proof
    with less hand-holding - although arguably the result would be a less clear proof)
*)

lemma sqrt2_irrational :
  fixes x :: nat
  fixes y :: nat
  assumes Coprime : "coprime x y"
  assumes Hxy : "x * x = 2 * y * y"
  shows False
proof-
  have  "(2 * y * y) mod 2 = 0" using Hxy mod_mult_self2_is_0[of "y * y" 2] by auto
  hence "x * x mod 2 = 0" using Hxy by auto

  hence Xeven : "x mod 2 = 0" using sym[OF mod_mult_eq[of x 2 x]] by auto

  obtain x' where X' : "x = 2 * x'"
    using mod_eq_0D[OF Xeven] by auto

  then have "4 * x' * x' = 2 * y * y" using Hxy by auto

  then have Hxy' : "2 * x' * x' = y * y" by auto

(* now we repeat the above argument to show y must be even and derive a contradiction *)
  have  "(2 * x' * x') mod 2 = 0" using Hxy mod_mult_self2_is_0[of "x' * x'" 2] by auto
  hence "y * y mod 2 = 0" using Hxy' by auto

  hence Yeven : "y mod 2 = 0" using sym[OF mod_mult_eq[of x 2 x]] by auto

  obtain y' where Y' : "y = 2 * y'"
    using mod_eq_0D[OF Yeven] by auto

  (* unfolding the definition of Coprime into Isabelle's meta-logic in order to
     make it easier to work with here - this could be done as a separate lemma
     (in fact there's probably automation for it, I just don't know how to use it. *)
  show False using coprimeE[OF Coprime, of 2 x' y'] X' Y' by auto
qed

end


section \<open>Challenge 1.B\<close>
theory Challenge1B
  imports Challenge1A "HOL-Library.Multiset"
begin

(* TODO: Move *)
lemma mset_concat:
  "mset (concat xs) = fold (+) (map mset xs) {#}"
proof -
  have "mset (concat xs) + a = fold (+) (map mset xs) a" for a
  proof2 (induction xs arbitrary: a)
    case Nil
    then show ?case
      by auto
  next
    case (Cons x xs)
    show ?case
      using Cons.IH[of "mset x + a", symmetric] by simp
  qed
  from this[of "{#}"] show ?thesis
    by auto
qed

subsection \<open>Merging Two Segments\<close>

fun merge :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "merge [] l2 = l2"
 | "merge l1 [] = l1"
 | "merge (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then x1 # (merge l1 (x2 # l2)) else x2 # (merge (x1 # l1) l2))"

lemma merge_correct:
  assumes "sorted l1"
  assumes "sorted l2"
  shows "
    sorted (merge l1 l2)
  \<and> mset (merge l1 l2) = mset l1 + mset l2
  \<and> set (merge l1 l2) = set l1 \<union> set l2"
  using assms
proof2 (induction l1 arbitrary: l2)
  case Nil thus ?case
    by simp
next
  case (Cons x1 l1 l2)
  note IH = Cons.IH

  show ?case
    using Cons.prems
  proof2 (induction l2)
    case Nil then show ?case
      by simp
  next
    case (Cons x2 l2)
    then show ?case
      using IH by (force split: if_split_asm)
  qed
qed

subsection \<open>Merging a List of Segments\<close>

function merge_list :: "'a::{linorder} list list \<Rightarrow> 'a list list \<Rightarrow> 'a list" where
   "merge_list [] [] = []"
 | "merge_list [] [l] = l"
 | "merge_list (la # acc2) [] = merge_list [] (la # acc2)"
 | "merge_list (la # acc2) [l] = merge_list [] (l # la # acc2)"
 | "merge_list acc2 (l1 # l2 # ls) =
    merge_list ((merge l1 l2) # acc2) ls"
by pat_completeness simp_all
termination by (relation "measure (\<lambda>(acc, ls). 3 * length acc + 2 * length ls)"; simp)

lemma merge_list_correct:
assumes "\<And>l. l \<in> set ls \<Longrightarrow> sorted l"
assumes "\<And>l. l \<in> set as \<Longrightarrow> sorted l"
shows "
  sorted (merge_list as ls)
\<and> mset (merge_list as ls) = mset (concat (as @ ls))
\<and> set (merge_list as ls) = set (concat (as @ ls))"
using assms
proof2 (induction as ls rule: merge_list.induct)
next
  case (4 la acc2 l)
  then show ?case
    by (auto simp: algebra_simps)
next
  case (5 acc2 l1 l2 ls)
  have "sorted (merge_list (merge l1 l2 # acc2) ls)
    \<and> mset (merge_list (merge l1 l2 # acc2) ls) = mset (concat ((merge l1 l2 # acc2) @ ls))
    \<and> set (merge_list (merge l1 l2 # acc2) ls) = set (concat ((merge l1 l2 # acc2) @ ls))"
    using 5(2-) merge_correct[of l1 l2] by (intro 5(1)) auto
  then show ?case
    using merge_correct[of l1 l2] 5(2-) by auto
qed simp+

subsection \<open>GHC-Sort\<close>

definition
  "ghc_sort xs = merge_list [] (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs))"

lemma decr_sorted:
  assumes "decr xs"
  shows "sorted (rev xs)"
  using assms apply2 (induction xs rule: decr.induct) by(auto simp: sorted_append)

lemma incr_sorted:
  assumes "incr xs"
  shows "sorted xs"
  using assms apply2 (induction xs rule: incr.induct) by auto

lemma reverse_phase_sorted:
  "\<forall>ys \<in> set (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs)). sorted ys"
  using cuts_incr_decr by (auto intro: decr_sorted incr_sorted)

lemma reverse_phase_elements:
  "set (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs))) = set xs"
proof -
  have "set (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs)))
    = set (concat (cuts xs))"
    by auto
  also have "\<dots> = set xs"
    by (simp add: concat_cuts)
  finally show ?thesis .
qed

lemma reverse_phase_permutation:
  "mset (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs))) = mset xs"
proof -
  have "mset (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs)))
    = mset (concat (cuts xs))"
    unfolding mset_concat by (auto simp: comp_def intro!: arg_cong2[where f = "fold (+)"])
  also have "\<dots> = mset xs"
    by (simp add: concat_cuts)
  finally show ?thesis .
qed

subsection \<open>Correctness Lemmas\<close>
text \<open>The result is sorted and a permutation of the original elements.\<close>

theorem sorted_ghc_sort:
  "sorted (ghc_sort xs)"
  unfolding ghc_sort_def using reverse_phase_sorted
  by (intro merge_list_correct[THEN conjunct1]) auto

theorem permutation_ghc_sort:
  "mset (ghc_sort xs) = mset xs"
  unfolding ghc_sort_def
  apply (subst merge_list_correct[THEN conjunct2])
  subgoal
    using reverse_phase_sorted by auto
  subgoal
    using reverse_phase_sorted by auto
  apply (subst (2) reverse_phase_permutation[symmetric])
  apply simp
  done

corollary elements_ghc_sort: "set (ghc_sort xs) = set xs"
  using permutation_ghc_sort by (metis set_mset_mset)

subsection \<open>Executable Code\<close>
(*
export_code ghc_sort checking SML Scala OCaml? Haskell?
*)
value [code] "ghc_sort [1,2,7,3,5,6,9,8,4]"

end


theory Chapter4
imports "~~/src/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{*
\section*{Chapter 4}

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

inductive palindrome :: "'a list \<Rightarrow> bool" where
palindromeE: "palindrome []" |
palindromeSS: "palindrome xs \<Longrightarrow> palindrome (x # xs @ [x])"

text {* and prove *}

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

text{*
\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:
*}

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
  n: "aval_rel (N n) s n" |
  v: "aval_rel (V v) s (s v)" |
  p: "\<lbrakk>aval_rel a\<^sub>1 s v\<^sub>1; aval_rel a\<^sub>2 s v\<^sub>2\<rbrakk> \<Longrightarrow> aval_rel (Plus a\<^sub>1 a\<^sub>2) s (v\<^sub>1 + v\<^sub>2)"

lemma aval_rel_aval: "aval_rel a s v \<Longrightarrow> aval a s = v"
  apply (induction rule:"aval_rel.induct")
  apply simp
  apply simp
  apply simp
done

lemma aval_aval_rel: "aval a s = v \<Longrightarrow> aval_rel a s v"
  apply (induction a arbitrary: s v)
  apply auto
  apply (rule aval_rel.n)
  apply (rule aval_rel.v)
  apply (rule aval_rel.p)
  apply auto
done

corollary "aval_rel a s v \<longleftrightarrow> aval a s = v"
  apply auto
  apply (rule aval_rel_aval)
  apply simp
  apply (rule aval_aval_rel)
  apply simp
done

text{*
\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
*}

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
(* your definition/proof here *)

text{*
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: *}

lemma "ok 0 [LOAD x] (Suc 0)"
(* your definition/proof here *)

lemma "ok 0 [LOAD x, LOADI v, ADD] (Suc 0)"
(* your definition/proof here *)

lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
(* your definition/proof here *)

text {* Prove that @{text ok} correctly computes the final stack size: *}

lemma "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"
(* your definition/proof here *)

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

end


(*  Title:      HOL/Induct/ABexp.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section {* Arithmetic and boolean expressions *}

theory ABexp
imports Main
begin

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

text {* \medskip Evaluation of arithmetic and boolean expressions *}

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

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

text {* \medskip Substitution on arithmetic and boolean expressions *}

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

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

lemma subst1_aexp:
  "evala env (substa (Var (v := a')) a) = evala (env (v := evala env a')) a"
and subst1_bexp:
  "evalb env (substb (Var (v := a')) b) = evalb (env (v := evala env a')) b"
    --  {* one variable *}
  by (induct a and b) simp_all

lemma subst_all_aexp:
  "evala env (substa s a) = evala (\<lambda>x. evala env (s x)) a"
and subst_all_bexp:
  "evalb env (substb s b) = evalb (\<lambda>x. evala env (s x)) b"
  by (induct a and b) auto

end


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

  A sorting algorithm that sorts values according to a key function and groups equivalent
  elements using a commutative and associative binary operation.
*)
section \<open>Sorting and grouping factors\<close>

theory Group_Sort
imports Main "HOL-Library.Multiset"
begin

text \<open>
  For the reification of products of powers of primitive functions such as
  @{term "\<lambda>x. x * ln x ^2"} into a canonical form, we need to be able to sort the factors
  according to the growth of the primitive function it contains and merge terms with the same
  function by adding their exponents. The following locale defines such an operation in a
  general setting; we can then instantiate it for our setting.

  The locale takes as parameters a key function @{term "f"} that sends list elements into a
  linear ordering that determines the sorting order, a @{term "merge"} function to merge to
  equivalent (w.r.t. @{term "f"}) elements into one, and a list reduction function @{term "g"}
  that reduces a list to a single value. This function must be invariant w.r.t. the order of
  list elements and be compatible with merging of equivalent elements. In our case, this list
  reduction function will be the product of all list elements.
\<close>

locale groupsort =
  fixes f :: "'a \<Rightarrow> ('b::linorder)"
  fixes merge :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  fixes g :: "'a list \<Rightarrow> 'c"
  assumes f_merge: "f x = f y \<Longrightarrow> f (merge x y) = f x"
  assumes g_cong: "mset xs = mset ys \<Longrightarrow> g xs = g ys"
  assumes g_merge: "f x = f y \<Longrightarrow> g [x,y] = g [merge x y]"
  assumes g_append_cong: "g xs1 = g xs2 \<Longrightarrow> g ys1 = g ys2 \<Longrightarrow> g (xs1 @ ys1) = g (xs2 @ ys2)"
begin

context
begin

private function part_aux ::
  "'b \<Rightarrow> 'a list \<Rightarrow> ('a list) \<times> ('a list) \<times> ('a list) \<Rightarrow> ('a list) \<times> ('a list) \<times> ('a list)"
where
  "part_aux p [] (ls, eq, gs) = (ls, eq, gs)"
| "f x < p \<Longrightarrow> part_aux p (x#xs) (ls, eq, gs) = part_aux p xs (x#ls, eq, gs)"
| "f x > p \<Longrightarrow> part_aux p (x#xs) (ls, eq, gs) = part_aux p xs (ls, eq, x#gs)"
| "f x = p \<Longrightarrow> part_aux p (x#xs) (ls, eq, gs) = part_aux p xs (ls, eq@[x], gs)"
proof (clarify, goal_cases)
  case prems: (1 P p xs ls eq gs)
  show ?case
  proof (cases xs)
    fix x xs' assume "xs = x # xs'"
    thus ?thesis using prems by (cases "f x" p rule: linorder_cases) auto
  qed (auto intro: prems(1))
qed simp_all
termination by (relation "Wellfounded.measure (size \<circ> fst \<circ> snd)") simp_all

private lemma groupsort_locale: "groupsort f merge g" by unfold_locales

private lemmas part_aux_induct = part_aux.induct[split_format (complete), OF groupsort_locale]

private definition part where "part p xs = part_aux (f p) xs ([], [p], [])"

private lemma part:
  "part p xs = (rev (filter (\<lambda>x. f x < f p) xs),
     p # filter (\<lambda>x. f x = f p) xs, rev (filter (\<lambda>x. f x > f p) xs))"
proof-
  {
    fix p xs ls eq gs
    have "fst (part_aux p xs (ls, eq, gs)) = rev (filter (\<lambda>x. f x < p) xs) @ ls"
      by (induction p xs ls eq gs rule: part_aux_induct) simp_all
  } note A = this
  {
    fix p xs ls eq gs
    have "snd (snd (part_aux p xs (ls, eq, gs))) = rev (filter (\<lambda>x. f x > p) xs) @ gs"
      by (induction p xs ls eq gs rule: part_aux_induct) simp_all
  } note B = this
  {
    fix p xs ls eq gs
    have "fst (snd (part_aux p xs (ls, eq, gs))) = eq @ filter (\<lambda>x. f x = p) xs"
      by (induction p xs ls eq gs rule: part_aux_induct) auto
  } note C = this
  note ABC = A B C
  from ABC[of "f p" xs "[]" "[p]" "[]"] show ?thesis unfolding part_def
    by (intro prod_eqI) simp_all
qed

private function sort :: "'a list \<Rightarrow> 'a list" where
  "sort [] = []"
| "sort (x#xs) = (case part x xs of (ls, eq, gs) \<Rightarrow> sort ls @ eq @ sort gs)"
by pat_completeness simp_all
termination by (relation "Wellfounded.measure length") (simp_all add: part less_Suc_eq_le)

private lemma filter_mset_union:
  assumes "\<And>x. x \<in># A \<Longrightarrow> P x \<Longrightarrow> Q x \<Longrightarrow> False"
  shows "filter_mset P A + filter_mset Q A = filter_mset (\<lambda>x. P x \<or> Q x) A" (is "?lhs = ?rhs")
  using assms by (auto simp add: count_eq_zero_iff intro!: multiset_eqI) blast

private lemma multiset_of_sort: "mset (sort xs) = mset xs"
proof (induction xs rule: sort.induct)
  case (2 x xs)
  let ?M = "\<lambda>oper. {#y:# mset xs. oper (f y) (f x)#}"
  from 2 have "mset (sort (x#xs)) = ?M (<) + ?M (=) + ?M (>) + {#x#}"
    by (simp add: part Multiset.union_assoc mset_filter)
  also have "?M (<) + ?M (=) + ?M (>) = mset xs"
    by ((subst filter_mset_union, force)+, subst multiset_eq_iff, force)
  finally show ?case by simp
qed simp

private lemma g_sort: "g (sort xs) = g xs"
  by (intro g_cong multiset_of_sort)

private lemma set_sort: "set (sort xs) = set xs"
  using arg_cong[OF multiset_of_sort[of xs], of "set_mset"] by (simp only: set_mset_mset)

private

private lemma sorted_sort: "sorted (map f (sort xs))"
apply (induction xs rule: sort.induct)
apply simp
apply (simp only: sorted_append sort.simps part map_append split)
apply (intro conjI TrueI)
using sorted_map_same by (auto simp: set_sort)

private fun group where
  "group [] = []"
| "group (x#xs) = (case partition (\<lambda>y. f y = f x) xs of (xs', xs'') \<Rightarrow>
                     fold merge xs' x # group xs'')"

private lemma f_fold_merge: "(\<And>y. y \<in> set xs \<Longrightarrow> f y = f x) \<Longrightarrow> f (fold merge xs x) = f x"
  by (induction xs rule: rev_induct) (auto simp: f_merge)

private lemma f_group: "x \<in> set (group xs) \<Longrightarrow> \<exists>x'\<in>set xs. f x = f x'"
proof (induction xs rule: group.induct)
  case (2 x' xs)
  hence "x = fold merge [y\<leftarrow>xs . f y = f x'] x' \<or> x \<in> set (group [xa\<leftarrow>xs . f xa \<noteq> f x'])"
    by (auto simp: o_def)
  thus ?case
  proof
    assume "x = fold merge [y\<leftarrow>xs . f y = f x'] x'"
    also have "f ... = f x'" by (rule f_fold_merge) simp
    finally show ?thesis by simp
  next
    assume "x \<in> set (group [xa\<leftarrow>xs . f xa \<noteq> f x'])"
    from 2(1)[OF _ this] have "\<exists>x'\<in>set [xa\<leftarrow>xs . f xa \<noteq> f x']. f x = f x'" by (simp add: o_def)
    thus ?thesis by force
  qed
qed simp

private lemma sorted_group: "sorted (map f xs) \<Longrightarrow> sorted (map f (group xs))"
proof (induction xs rule: group.induct)
  case (2 x xs)
  {
    fix x' assume x': "x' \<in> set (group [y\<leftarrow>xs . f y \<noteq> f x])"
    with f_group obtain x'' where x'': "x'' \<in> set xs" "f x' = f x''" by force
    have "f (fold merge [y\<leftarrow>xs . f y = f x] x) = f x"
      by (subst f_fold_merge) simp_all
    also from 2(2) x'' have "... \<le> f x'" by (auto)
    finally have "f (fold merge [y\<leftarrow>xs . f y = f x] x) \<le> f x'" .
  }
  moreover from 2(2) have "sorted (map f (group [xa\<leftarrow>xs . f xa \<noteq> f x]))"
    by (intro 2 sorted_filter) (simp_all add: o_def)
  ultimately show ?case by (simp add: o_def)
qed simp_all

private lemma distinct_group: "distinct (map f (group xs))"
proof (induction xs rule: group.induct)
  case (2 x xs)
  have "distinct (map f (group [xa\<leftarrow>xs . f xa \<noteq> f x]))" by (intro 2) (simp_all add: o_def)
  moreover have "f (fold merge [y\<leftarrow>xs . f y = f x] x) \<notin> set (map f (group [xa\<leftarrow>xs . f xa \<noteq> f x]))"
    by (rule notI, subst (asm) f_fold_merge) (auto dest: f_group)
  ultimately show ?case by (simp add: o_def)
qed simp

private lemma g_fold_same:
  assumes "\<And>z. z \<in> set xs \<Longrightarrow> f z = f x"
  shows   "g (fold merge xs x # ys) = g (x#xs@ys)"
using assms
proof (induction xs arbitrary: x)
  case (Cons y xs)
  have "g (x # y # xs @ ys) = g (y # x # xs @ ys)" by (intro g_cong) (auto simp: add_ac)
  also have "y # x # xs @ ys = [y,x] @ xs @ ys" by simp
  also from Cons.prems have "g ... = g ([merge y x] @ xs @ ys)"
    by (intro g_append_cong g_merge) auto
  also have "[merge y x] @ xs @ ys = merge y x # xs @ ys" by simp
  also from Cons.prems have "g ... = g (fold merge xs (merge y x) # ys)"
    by (intro Cons.IH[symmetric]) (auto simp: f_merge)
  also have "... = g (fold merge (y # xs) x # ys)" by simp
  finally show ?case by simp
qed simp

private lemma g_group: "g (group xs) = g xs"
proof (induction xs rule: group.induct)
  case (2 x xs)
  have "g (group (x#xs)) = g (fold merge [y\<leftarrow>xs . f y = f x] x # group [xa\<leftarrow>xs . f xa \<noteq> f x])"
    by (simp add: o_def)
  also have "... = g (x # [y\<leftarrow>xs . f y = f x] @ group [y\<leftarrow>xs . f y \<noteq> f x])"
    by (intro g_fold_same) simp_all
  also have "... = g ((x # [y\<leftarrow>xs . f y = f x]) @ group [y\<leftarrow>xs . f y \<noteq> f x])" (is "_ = ?A") by simp
  also from 2 have "g (group [y\<leftarrow>xs . f y \<noteq> f x]) = g [y\<leftarrow>xs . f y \<noteq> f x]" by (simp add: o_def)
  hence "?A = g ((x # [y\<leftarrow>xs . f y = f x]) @ [y\<leftarrow>xs . f y \<noteq> f x])"
    by (intro g_append_cong) simp_all
  also have "... = g (x#xs)" by (intro g_cong) (simp_all)
  finally show ?case .
qed simp

function group_part_aux ::
  "'b \<Rightarrow> 'a list \<Rightarrow> ('a list) \<times> 'a \<times> ('a list) \<Rightarrow> ('a list) \<times> 'a \<times> ('a list)"
where
  "group_part_aux p [] (ls, eq, gs) = (ls, eq, gs)"
| "f x < p \<Longrightarrow> group_part_aux p (x#xs) (ls, eq, gs) = group_part_aux p xs (x#ls, eq, gs)"
| "f x > p \<Longrightarrow> group_part_aux p (x#xs) (ls, eq, gs) = group_part_aux p xs (ls, eq, x#gs)"
| "f x = p \<Longrightarrow> group_part_aux p (x#xs) (ls, eq, gs) = group_part_aux p xs (ls, merge x eq, gs)"
proof (clarify, goal_cases)
  case prems: (1 P p xs ls eq gs)
  show ?case
  proof (cases xs)
    fix x xs' assume "xs = x # xs'"
    thus ?thesis using prems by (cases "f x" p rule: linorder_cases) auto
  qed (auto intro: prems(1))
qed simp_all
termination by (relation "Wellfounded.measure (size \<circ> fst \<circ> snd)") simp_all

private lemmas group_part_aux_induct =
  group_part_aux.induct[split_format (complete), OF groupsort_locale]

definition group_part where "group_part p xs = group_part_aux (f p) xs ([], p, [])"

private lemma group_part:
  "group_part p xs = (rev (filter (\<lambda>x. f x < f p) xs),
     fold merge (filter (\<lambda>x. f x = f p) xs) p, rev (filter (\<lambda>x. f x > f p) xs))"
proof-
  {
    fix p xs ls eq gs
    have "fst (group_part_aux p xs (ls, eq, gs)) = rev (filter (\<lambda>x. f x < p) xs) @ ls"
      by (induction p xs ls eq gs rule: group_part_aux_induct) simp_all
  } note A = this
  {
    fix p xs ls eq gs
    have "snd (snd (group_part_aux p xs (ls, eq, gs))) = rev (filter (\<lambda>x. f x > p) xs) @ gs"
      by (induction p xs ls eq gs rule: group_part_aux_induct) simp_all
  } note B = this
  {
    fix p xs ls eq gs
    have "fst (snd (group_part_aux p xs (ls, eq, gs))) =
            fold merge (filter (\<lambda>x. f x = p) xs) eq"
      by (induction p xs ls eq gs rule: group_part_aux_induct) auto
  } note C = this
  note ABC = A B C
  from ABC[of "f p" xs "[]" "p" "[]"] show ?thesis unfolding group_part_def
    by (intro prod_eqI) simp_all
qed

function group_sort :: "'a list \<Rightarrow> 'a list" where
  "group_sort [] = []"
| "group_sort (x#xs) = (case group_part x xs of (ls, eq, gs) \<Rightarrow> group_sort ls @ eq # group_sort gs)"
by pat_completeness simp_all
termination by (relation "Wellfounded.measure length") (simp_all add: group_part less_Suc_eq_le)

private lemma group_append:
  assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> f x \<noteq> f y"
  shows   "group (xs @ ys) = group xs @ group ys"
using assms
proof (induction xs arbitrary: ys rule: length_induct)
  case (1 xs')
  hence IH: "\<And>x xs ys. length xs < length xs' \<Longrightarrow> (\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> f x \<noteq> f y)
                \<Longrightarrow> group (xs @ ys) = group xs @ group ys" by blast
  show ?case
  proof (cases xs')
    case (Cons x xs)
    note [simp] = this
    have "group (xs' @ ys) = fold merge [y\<leftarrow>xs@ys . f y = f x] x #
            group ([xa\<leftarrow>xs . f xa \<noteq> f x] @ [xa\<leftarrow>ys . f xa \<noteq> f x])" by (simp add: o_def)
    also from 1(2) have "[y\<leftarrow>xs@ys . f y = f x] = [y\<leftarrow>xs . f y = f x]"
      by (force simp: filter_empty_conv)
    also from 1(2) have "[xa\<leftarrow>ys . f xa \<noteq> f x] = ys" by (force simp: filter_id_conv)
    also have "group ([xa\<leftarrow>xs . f xa \<noteq> f x] @ ys) =
               group [xa\<leftarrow>xs . f xa \<noteq> f x] @ group ys" using 1(2)
      by (intro IH) (simp_all add: less_Suc_eq_le)
    finally show ?thesis by (simp add: o_def)
  qed simp
qed

private lemma group_empty_iff [simp]: "group xs = [] \<longleftrightarrow> xs = []"
  by (induction xs rule: group.induct) auto

lemma group_sort_correct: "group_sort xs = group (sort xs)"
proof (induction xs rule: group_sort.induct)
  case (2 x xs)
  have "group_sort (x#xs) =
          group_sort (rev [xa\<leftarrow>xs . f xa < f x]) @ group (x#[xa\<leftarrow>xs . f xa = f x]) @
          group_sort (rev [xa\<leftarrow>xs . f x < f xa])" by (simp add: group_part)
  also have "group_sort (rev [xa\<leftarrow>xs . f xa < f x]) = group (sort (rev [xa\<leftarrow>xs . f xa < f x]))"
    by (rule 2) (simp_all add: group_part)
  also have "group_sort (rev [xa\<leftarrow>xs . f xa > f x]) = group (sort (rev [xa\<leftarrow>xs . f xa > f x]))"
    by (rule 2) (simp_all add: group_part)
  also have "group (x#[xa\<leftarrow>xs . f xa = f x]) @ group (sort (rev [xa\<leftarrow>xs . f xa > f x])) =
             group ((x#[xa\<leftarrow>xs . f xa = f x]) @ sort (rev [xa\<leftarrow>xs . f xa > f x]))"
    by (intro group_append[symmetric]) (auto simp: set_sort)
  also have "group (sort (rev [xa\<leftarrow>xs . f xa < f x])) @ ... =
             group (sort (rev [xa\<leftarrow>xs . f xa < f x]) @ (x#[xa\<leftarrow>xs . f xa = f x]) @
                 sort (rev [xa\<leftarrow>xs . f xa > f x]))"
    by (intro group_append[symmetric]) (auto simp: set_sort)
  also have "sort (rev [xa\<leftarrow>xs . f xa < f x]) @ (x#[xa\<leftarrow>xs . f xa = f x]) @
                 sort (rev [xa\<leftarrow>xs . f xa > f x]) = sort (x # xs)" by (simp add: part)
  finally show ?case .
qed simp

lemma sorted_group_sort: "sorted (map f (group_sort xs))"
  by (auto simp: group_sort_correct intro!: sorted_group sorted_sort)

lemma g_group_sort: "g (group_sort xs) = g xs"
  by (simp add: group_sort_correct g_group g_sort)

lemmas [simp del] = group_sort.simps group_part_aux.simps

end
end

end


theory Ex1_8
  imports Main
begin

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

lemma helper : "ListSum (xs @ ys) = ListSum xs + ListSum ys" by (induct xs; simp)

theorem "2 * ListSum [0 ..<n+1] = n * (n + 1)"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  assume hyp:" 2 * ListSum [0..<n + 1] = n * (n + 1)"
  then show ?case by (auto simp add : helper)
qed

theorem "ListSum (replicate n a) = n * a" using helper by (induct n; simp)

primrec ListSumTAux :: "nat list \<Rightarrow> nat \<Rightarrow> nat" where
  "ListSumTAux [] res = res"|
  "ListSumTAux (x#xs) res = ListSumTAux xs (res + x)"

definition ListSumT :: "nat list \<Rightarrow> nat " where
  "ListSumT ls = ListSumTAux ls 0"

lemma "ListSumTAux xs n  = n + ListSumTAux xs 0"
proof (induct xs arbitrary : n)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  note hyp =  this
  have " n + ListSumTAux (a # xs) 0  = n + ListSumTAux xs a"  by (simp)
  also have "\<dots> =  n + a + ListSumTAux xs 0" by (subst hyp, simp)
  finally have tmp:" n + ListSumTAux (a # xs) 0  = n + a + ListSumTAux xs 0" by assumption

  have "ListSumTAux (a # xs) n = ListSumTAux xs (n + a)" by (simp)
  also have "\<dots> =n + a + ListSumTAux xs 0" by (subst hyp, rule refl)
  finally have tmp2:"ListSumTAux (a # xs) n = n + a + ListSumTAux xs 0" by simp

  from tmp and tmp2 show ?case by simp
qed

lemma helper2 : "ListSumTAux xs n  = n + ListSumTAux xs 0"
proof (induct xs  arbitrary : n)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case  by (metis ListSumTAux.simps(2) semiring_normalization_rules(25) semiring_normalization_rules(5))
qed

theorem "ListSum xs = ListSumT xs"
proof (induct xs)
  case Nil
  then show ?case by (simp add : ListSumT_def)
next
  case (Cons a xs)
  assume hyp:"ListSum xs = ListSumT xs"
  then show ?case by (metis ListSum.simps(2) ListSumTAux.simps(2) ListSumT_def add_cancel_left_left helper2)
qed

theorem "ListSum xs = ListSumT xs"
proof (induct xs)
  case Nil
  then show ?case by (simp add : ListSumT_def)
next
  case (Cons a xs)
  assume hyp:"ListSum xs = ListSumT xs"
  have " ListSum (a#xs) = a + ListSum xs" by simp
  also have "\<dots> = a + ListSumT xs" using hyp by simp
  also have "\<dots> = a + ListSumTAux xs 0" by (simp add: ListSumT_def)
  also have "\<dots> = ListSumTAux xs a" by (subst helper2, rule refl)
  also have "\<dots> = ListSumTAux (a#xs) 0 " by (simp)
  also have "\<dots> = ListSumT (a#xs)" by (simp only : ListSumT_def)
  finally show ?case by assumption
qed


theory fol
  imports Main
begin

thm exI
thm allI
thm exE
thm allE

thm impE

(*
exI: ?P ?x \<Longrightarrow> \<exists>x. ?P x
allI: (\<And>x. ?P x) \<Longrightarrow> \<forall>x. ?P x
exE: \<exists>x. ?P x \<Longrightarrow> (\<And>x. ?P x \<Longrightarrow> ?Q) \<Longrightarrow> ?Q
allE: \<forall>x. ?P x \<Longrightarrow> (?P ?x \<Longrightarrow> ?R) \<Longrightarrow> ?R
*)

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

lemma ex2: "(\<forall>x.\<forall>y. P x \<longrightarrow> Q y) \<longrightarrow> ( (\<exists>x. P x)\<longrightarrow>(\<forall>y. Q y) )"
  apply (rule impI)
  apply (rule impI)
  apply (rule allI) (* introduces \<and>y for Q y in final goal *)
  apply (rule_tac P = "\<lambda>x. P x" in exE) (* introduces \<and>x for the existential to have P x *)
   apply assumption
  apply (rule_tac P = "\<lambda>x. \<forall>y. P x \<longrightarrow> Q y" and x = "x" in allE)
   apply assumption
  apply (rule_tac P = "\<lambda>y. P x \<longrightarrow> Q y" and x = "y" in allE)
  (* apply (rule allE) *)
   apply assumption
  apply (erule impE)
   apply assumption
  apply assumption
  done

(* TODO do same proof as above but let isabelle unify for you *)

lemma ex3: "(\<forall>x. \<forall>y. P x \<and> P y) \<longrightarrow> ( (\<forall> x. P x) \<and> (\<forall>y. P y) )"
  apply (rule impI)
  thm conjI
  apply (rule conjI)
   apply (rule allI)
   apply (rule_tac P = "\<lambda> x. \<forall>y. P x \<and> P y" and x = "x" in allE)
    apply assumption
   apply (rule_tac P = "\<lambda>y. P x \<and> P y" and x = "x" in allE)
    apply assumption
   apply (erule conjE)
   apply assumption
  apply (rule allI)
  apply (rule_tac P = "\<lambda>x. \<forall> y. P x \<and> P y" and x = "y" in allE)
   apply assumption
  apply (rule_tac P = "\<lambda>ya. P y \<and> P ya" and x = "y" in allE)
   apply assumption
  apply (erule conjE)
  apply assumption


theory Demo
imports Datatype
begin

text {*
 Note: to avoid name clashes with the existing type of lists we build
 on top of Datatype rather than Main. This is an exception!
*}

datatype 'a list = Nil | Cons 'a "'a list"

primrec app :: "'a list => 'a list => 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

primrec rev :: "'a list => 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

value "rev(Cons True (Cons False Nil))"

value "rev(Cons a (Cons b Nil))"

text {*
  Simple proofs:

  Command 'lemma' / 'theorem': state a proposition
  Attribute 'simp': use this theorem as a simplification rule in future proofs
  Method 'induct': structural induction
  Method 'auto':  automatic proof (mostly by simplification)
  Command 'done':  end of proof
*}

lemma app_Nil2[simp]: "app xs Nil = xs"
apply (induct xs)
apply auto
done

lemma app_assoc[simp]: "app (app xs ys) zs = app xs (app ys zs)"
apply (induct xs)
apply auto
done

lemma rev_app[simp]: "rev (app xs ys) = app (rev ys) (rev xs)"
apply (induct xs)
apply auto
done

theorem rev_rev[simp]: "rev (rev xs) = xs"
apply (induct xs)
apply auto
done

(* Hint for demo:
   do the proof top down, discovering the lemmas one by one,
   as described in LNCS2283.
*)

end


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

subsection{*Case Study: Boolean Expressions*}

text{*\label{sec:boolex}\index{boolean expressions example|(}
The aim of this case study is twofold: it shows how to model boolean
expressions and some algorithms for manipulating them, and it demonstrates
the constructs introduced above.
*}

subsubsection{*Modelling Boolean Expressions*}

text{*
We want to represent boolean expressions built up from variables and
constants by negation and conjunction. The following datatype serves exactly
that purpose:
*}

datatype boolex = Const bool | Var nat | Neg boolex
                | And boolex boolex

text{*\noindent
The two constants are represented by @{term"Const True"} and
@{term"Const False"}. Variables are represented by terms of the form
@{term"Var n"}, where @{term"n"} is a natural number (type @{typ"nat"}).
For example, the formula $P@0 \land \neg P@1$ is represented by the term
@{term"And (Var 0) (Neg(Var 1))"}.

\subsubsection{The Value of a Boolean Expression}

The value of a boolean expression depends on the value of its variables.
Hence the function @{text"value"} takes an additional parameter, an
\emph{environment} of type @{typ"nat => bool"}, which maps variables to their
values:
*}

primrec "value" :: "boolex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool" where
"value (Const b) env = b" |
"value (Var x)   env = env x" |
"value (Neg b)   env = (\<not> value b env)" |
"value (And b c) env = (value b env \<and> value c env)"

text{*\noindent
\subsubsection{If-Expressions}

An alternative and often more efficient (because in a certain sense
canonical) representation are so-called \emph{If-expressions} built up
from constants (@{term"CIF"}), variables (@{term"VIF"}) and conditionals
(@{term"IF"}):
*}

datatype ifex = CIF bool | VIF nat | IF ifex ifex ifex

text{*\noindent
The evaluation of If-expressions proceeds as for @{typ"boolex"}:
*}

primrec valif :: "ifex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool" where
"valif (CIF b)    env = b" |
"valif (VIF x)    env = env x" |
"valif (IF b t e) env = (if valif b env then valif t env
                                        else valif e env)"

text{*
\subsubsection{Converting Boolean and If-Expressions}

The type @{typ"boolex"} is close to the customary representation of logical
formulae, whereas @{typ"ifex"} is designed for efficiency. It is easy to
translate from @{typ"boolex"} into @{typ"ifex"}:
*}

primrec bool2if :: "boolex \<Rightarrow> ifex" where
"bool2if (Const b) = CIF b" |
"bool2if (Var x)   = VIF x" |
"bool2if (Neg b)   = IF (bool2if b) (CIF False) (CIF True)" |
"bool2if (And b c) = IF (bool2if b) (bool2if c) (CIF False)"

text{*\noindent
At last, we have something we can verify: that @{term"bool2if"} preserves the
value of its argument:
*}

lemma "valif (bool2if b) env = value b env"

txt{*\noindent
The proof is canonical:
*}

apply(induct_tac b)
apply(auto)
done

text{*\noindent
In fact, all proofs in this case study look exactly like this. Hence we do
not show them below.

More interesting is the transformation of If-expressions into a normal form
where the first argument of @{term"IF"} cannot be another @{term"IF"} but
must be a constant or variable. Such a normal form can be computed by
repeatedly replacing a subterm of the form @{term"IF (IF b x y) z u"} by
@{term"IF b (IF x z u) (IF y z u)"}, which has the same value. The following
primitive recursive functions perform this task:
*}

primrec normif :: "ifex \<Rightarrow> ifex \<Rightarrow> ifex \<Rightarrow> ifex" where
"normif (CIF b)    t e = IF (CIF b) t e" |
"normif (VIF x)    t e = IF (VIF x) t e" |
"normif (IF b t e) u f = normif b (normif t u f) (normif e u f)"

primrec norm :: "ifex \<Rightarrow> ifex" where
"norm (CIF b)    = CIF b" |
"norm (VIF x)    = VIF x" |
"norm (IF b t e) = normif b (norm t) (norm e)"

text{*\noindent
Their interplay is tricky; we leave it to you to develop an
intuitive understanding. Fortunately, Isabelle can help us to verify that the
transformation preserves the value of the expression:
*}

theorem "valif (norm b) env = valif b env"(*<*)oops(*>*)

text{*\noindent
The proof is canonical, provided we first show the following simplification
lemma, which also helps to understand what @{term"normif"} does:
*}

theorem "valif (norm b) env = valif b env"
apply(induct_tac b)
by(auto)
(*>*)
text{*\noindent
Note that the lemma does not have a name, but is implicitly used in the proof
of the theorem shown above because of the @{text"[simp]"} attribute.

But how can we be sure that @{term"norm"} really produces a normal form in
the above sense? We define a function that tests If-expressions for normality:
*}

primrec normal :: "ifex \<Rightarrow> bool" where
"normal(CIF b) = True" |
"normal(VIF x) = True" |
"normal(IF b t e) = (normal t \<and> normal e \<and>
     (case b of CIF b \<Rightarrow> True | VIF x \<Rightarrow> True | IF x y z \<Rightarrow> False))"

text{*\noindent
Now we prove @{term"normal(norm b)"}. Of course, this requires a lemma about
normality of @{term"normif"}:
*}

lemma [simp]: "\<forall>t e. normal(normif b t e) = (normal t \<and> normal e)"
(*<*)
apply(induct_tac b)
by(auto)

theorem "normal(norm b)"
apply(induct_tac b)
by(auto)
(*>*)

text{*\medskip
How do we come up with the required lemmas? Try to prove the main theorems
without them and study carefully what @{text auto} leaves unproved. This
can provide the clue.  The necessity of universal quantification
(@{text"\<forall>t e"}) in the two lemmas is explained in
\S\ref{sec:InductionHeuristics}

\begin{exercise}
  We strengthen the definition of a @{const normal} If-expression as follows:
  the first argument of all @{term IF}s must be a variable. Adapt the above
  development to this changed requirement. (Hint: you may need to formulate
  some of the goals as implications (@{text"\<longrightarrow>"}) rather than
  equalities (@{text"="}).)
\end{exercise}
\index{boolean expressions example|)}
*}
(*<*)

primrec normif2 :: "ifex => ifex => ifex => ifex" where
"normif2 (CIF b)    t e = (if b then t else e)" |
"normif2 (VIF x)    t e = IF (VIF x) t e" |
"normif2 (IF b t e) u f = normif2 b (normif2 t u f) (normif2 e u f)"

primrec norm2 :: "ifex => ifex" where
"norm2 (CIF b)    = CIF b" |
"norm2 (VIF x)    = VIF x" |
"norm2 (IF b t e) = normif2 b (norm2 t) (norm2 e)"

primrec normal2 :: "ifex => bool" where
"normal2(CIF b) = True" |
"normal2(VIF x) = True" |
"normal2(IF b t e) = (normal2 t & normal2 e &
     (case b of CIF b => False | VIF x => True | IF x y z => False))"

lemma [simp]:
  "ALL t e. valif (normif2 b t e) env = valif (IF b t e) env"
apply(induct b)
by(auto)

theorem "valif (norm2 b) env = valif b env"
apply(induct b)
by(auto)

lemma [simp]: "ALL t e. normal2 t & normal2 e --> normal2(normif2 b t e)"
apply(induct b)
by(auto)

theorem "normal2(norm2 b)"
apply(induct b)
by(auto)

end
(*>*)