(*  Title:      ListSlice.thy
    Date:       Oct 2006
    Author:     David Trachtenherz
*)

section \<open>Additional definitions and results for lists\<close>

theory ListSlice
imports "List-Infinite.ListInf"
begin

subsection \<open>Slicing lists into lists of lists\<close>

definition ilist_slice  :: "'a ilist \<Rightarrow> nat \<Rightarrow> 'a list ilist"
  where "ilist_slice f k \<equiv> \<lambda>x. map f [x * k..<Suc x * k]"

primrec list_slice_aux :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list list"
where
  "list_slice_aux xs k 0 = []"
| "list_slice_aux xs k (Suc n) = take k xs # list_slice_aux (xs \<up> k) k n"

definition list_slice :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list list"
  where "list_slice xs k \<equiv> list_slice_aux xs k (length xs div k)"

definition list_slice2 :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list list"
  where "list_slice2 xs k \<equiv>
    list_slice xs k @ (if length xs mod k = 0 then [] else [xs \<up> (length xs div k * k)])"

text \<open>
  No function \<open>list_unslice\<close> for finite lists is needed
  because the corresponding functionality is already provided by \<open>concat\<close>.
  Therefore, only a \<open>ilist_unslice\<close> function for infinite lists is defined.\<close>

definition ilist_unslice  :: "'a list ilist \<Rightarrow> 'a ilist"
  where "ilist_unslice f \<equiv> \<lambda>n. f (n div length (f 0)) ! (n mod length (f 0))"

lemma list_slice_aux_length: "\<And>xs. length (list_slice_aux xs k n) = n"
by (induct n, simp+)

lemma list_slice_aux_nth: "
 \<And>m xs. m < n \<Longrightarrow> (list_slice_aux xs k n) ! m = (xs \<up> (m * k) \<down> k)"
apply (induct n)
 apply simp
apply (simp add: nth_Cons' diff_mult_distrib)
done

lemma list_slice_length: "length (list_slice xs k) = length xs div k"
by (simp add: list_slice_def list_slice_aux_length)

lemma list_slice_0: "list_slice xs 0 = []"
by (simp add: list_slice_def)

lemma list_slice_1: "list_slice xs (Suc 0) = map (\<lambda>x. [x]) xs"
by (fastforce simp: list_eq_iff list_slice_def list_slice_aux_nth list_slice_aux_length)

lemma list_slice_less: "length xs < k \<Longrightarrow> list_slice xs k = []"
by (simp add: list_slice_def)

lemma list_slice_Nil: "list_slice [] k = []"
by (simp add: list_slice_def)

lemma list_slice_nth: "
  m < length xs div k \<Longrightarrow> list_slice xs k ! m = xs \<up> (m * k) \<down> k"
by (simp add: list_slice_def list_slice_aux_nth)

lemma list_slice_nth_length: "
  m < length xs div k \<Longrightarrow> length ((list_slice xs k) ! m) = k"
apply (case_tac "length xs < k")
 apply simp
apply (simp add: list_slice_nth)
thm less_div_imp_mult_add_divisor_le
apply (drule less_div_imp_mult_add_divisor_le)
apply simp
done

lemma list_slice_nth_eq_sublist_list: "
  m < length xs div k \<Longrightarrow> list_slice xs k ! m = sublist_list xs [m * k..<m * k + k]"
apply (simp add: list_slice_nth)
apply (rule take_drop_eq_sublist_list)
apply (rule less_div_imp_mult_add_divisor_le, assumption+)
done

lemma list_slice_nth_nth: "
  \<lbrakk> m < length xs div k; n < k \<rbrakk> \<Longrightarrow>
  (list_slice xs k) ! m ! n = xs ! (m * k + n)"
apply (frule list_slice_nth_length[of m xs k])
apply (simp add: list_slice_nth)
done

lemma list_slice_nth_nth_rev: "
  n < length xs div k * k \<Longrightarrow>
  (list_slice xs k) ! (n div k) ! (n mod k) = xs ! n"
apply (case_tac "k = 0", simp)
apply (simp add: list_slice_nth_nth div_less_conv)
done

lemma list_slice_eq_list_slice_take: "
  list_slice (xs \<down> (length xs div k * k)) k = list_slice xs k"
apply (case_tac "k = 0")
 apply (simp add: list_slice_0)
apply (simp add: list_eq_iff list_slice_length)
apply (simp add: div_mult_le min_eqR list_slice_nth)
apply (clarify, rename_tac i)
apply (subgoal_tac "k \<le> length xs div k * k - i * k")
 prefer 2
 apply (drule_tac m=i in Suc_leI)
 apply (drule mult_le_mono1[of _ _ k])
 apply simp
apply (subgoal_tac "length xs div k * k - i * k \<le> length xs - i * k")
 prefer 2
 apply (simp add: div_mult_cancel)
apply (simp add: min_eqR)
by (simp add: less_diff_conv)

lemma list_slice_append_mult: "
  \<And>xs. length xs = m * k \<Longrightarrow>
  list_slice (xs @ ys) k = list_slice xs k @ list_slice ys k"
apply (case_tac "k = 0")
 apply (simp add: list_slice_0)
apply (induct m)
 apply (simp add: list_slice_Nil)
apply (simp add: list_slice_def)
apply (simp add: list_slice_def add.commute[of _ "length ys"] add.assoc[symmetric])
done

lemma list_slice_append_mod: "
  length xs mod k = 0 \<Longrightarrow>
  list_slice (xs @ ys) k = list_slice xs k @ list_slice ys k"
  by (auto intro: list_slice_append_mult elim!: dvdE)

lemma list_slice_div_eq_1[rule_format]: "
  length xs div k = Suc 0 \<Longrightarrow> list_slice xs k = [take k xs]"
by (simp add: list_slice_def)

lemma list_slice_div_eq_Suc[rule_format]: "
  length xs div k = Suc n \<Longrightarrow>
  list_slice xs k = list_slice (xs \<down> (n * k)) k @ [xs \<up> (n * k) \<down> k]"
apply (case_tac "k = 0", simp)
apply (subgoal_tac "n * k < length xs")
 prefer 2
 apply (case_tac "length xs = 0", simp)
 apply (drule_tac arg_cong[where f="\<lambda>x. x - Suc 0"], drule sym)
 apply (simp add: diff_mult_distrib div_mult_cancel)
apply (insert list_slice_append_mult[of "take (n * k) xs" n k "drop (n * k) xs"])
apply (simp add: min_eqR)
apply (rule list_slice_div_eq_1)
apply (simp add: div_diff_mult_self1)
done

lemma list_slice2_mod_0: "
  length xs mod k = 0 \<Longrightarrow> list_slice2 xs k = list_slice xs k"
by (simp add: list_slice2_def)

lemma list_slice2_mod_gr0: "
  0 < length xs mod k \<Longrightarrow> list_slice2 xs k = list_slice xs k @ [xs \<up> (length xs div k * k)]"
by (simp add: list_slice2_def)

lemma list_slice2_length: "
  length (list_slice2 xs k) = (
  if length xs mod k = 0 then length xs div k else Suc (length xs div k))"
by (simp add: list_slice2_def list_slice_length)

lemma list_slice2_0: "
  list_slice2 xs 0 = (if (length xs = 0) then [] else [xs])"
by (simp add: list_slice2_def list_slice_0)

lemma list_slice2_1: "list_slice2 xs (Suc 0) = map (\<lambda>x. [x]) xs"
by (simp add: list_slice2_def list_slice_1)

lemma list_slice2_le: "
  length xs \<le> k \<Longrightarrow> list_slice2 xs k = (if length xs = 0 then [] else [xs])"
apply (case_tac "k = 0")
 apply (simp add: list_slice2_0)
apply (drule order_le_less[THEN iffD1], erule disjE)
 apply (simp add: list_slice2_def list_slice_def)
apply (simp add: list_slice2_def list_slice_div_eq_1)
done

lemma list_slice2_Nil: "list_slice2 [] k = []"
by (simp add: list_slice2_def list_slice_Nil)

lemma list_slice2_last: "
  \<lbrakk> length xs mod k > 0; m = length xs div k \<rbrakk> \<Longrightarrow>
  list_slice2 xs k ! m = xs \<up> (length xs div k * k)"
by (simp add: list_slice2_def nth_append list_slice_length)

lemma list_slice2_nth: "
  \<lbrakk> m < length xs div k \<rbrakk> \<Longrightarrow>
  list_slice2 xs k ! m = xs \<up> (m * k) \<down> k"
by (simp add: list_slice2_def list_slice_length nth_append list_slice_nth)

lemma list_slice2_nth_length_eq1: "
  m < length xs div k \<Longrightarrow> length (list_slice2 xs k ! m) = k"
by (simp add: list_slice2_def nth_append list_slice_length list_slice_nth_length)

lemma list_slice2_nth_length_eq2: "
  \<lbrakk> length xs mod k > 0; m = length xs div k \<rbrakk> \<Longrightarrow>
  length (list_slice2 xs k ! m) = length xs mod k"
by (simp add: list_slice2_def list_slice_length nth_append minus_div_mult_eq_mod [symmetric])

lemma list_slice2_nth_nth_eq1: "
  \<lbrakk> m < length xs div k; n < k \<rbrakk> \<Longrightarrow>
  (list_slice2 xs k) ! m ! n = xs ! (m * k + n)"
by (simp add: list_slice2_list_slice_nth list_slice_nth_nth)

lemma list_slice2_nth_nth_eq2: "
  \<lbrakk> m = length xs div k; n < length xs mod k \<rbrakk> \<Longrightarrow>
  (list_slice2 xs k) ! m ! n = xs ! (m * k + n)"
by (simp add: mult.commute[of _ k] minus_mod_eq_mult_div [symmetric] list_slice2_last)

lemma list_slice2_nth_nth_rev: "
  n < length xs \<Longrightarrow> (list_slice2 xs k) ! (n div k) ! (n mod k) = xs ! n"
apply (case_tac "k = 0")
 apply (clarsimp simp: list_slice2_0)
apply (case_tac "n div k < length xs div k")
 apply (simp add: list_slice2_nth_nth_eq1)
apply (frule div_le_mono[OF less_imp_le, of _ _ k])
apply simp
apply (drule sym)
apply (subgoal_tac "n mod k < length xs mod k")
 prefer 2
 apply (rule ccontr)
 apply (simp add: linorder_not_less)
 apply (drule less_mod_ge_imp_div_less[of n "length xs" k], simp+)
apply (simp add: list_slice2_nth_nth_eq2)
done

lemma list_slice2_append_mult: "
  length xs = m * k \<Longrightarrow>
  list_slice2 (xs @ ys) k = list_slice2 xs k @ list_slice2 ys k"
apply (case_tac "k = 0")
 apply (simp add: list_slice2_0)
apply (clarsimp simp: list_slice2_def list_slice_append_mult)
apply (simp add: add.commute[of "m * k"] add_mult_distrib)
done

lemma list_slice2_append_mod: "
  length xs mod k = 0 \<Longrightarrow>
  list_slice2 (xs @ ys) k = list_slice2 xs k @ list_slice2 ys k"
  by (auto intro: list_slice2_append_mult elim!: dvdE)

lemma ilist_slice_nth: "
  (ilist_slice f k) m = map f [m * k..<Suc m * k]"
by (simp add: ilist_slice_def)

lemma ilist_slice_nth_length: "length ((ilist_slice f k) m) = k"
by (simp add: ilist_slice_def)

lemma ilist_slice_nth_nth: "
  n < k \<Longrightarrow> (ilist_slice f k) m ! n = f (m * k + n)"
by (simp add: ilist_slice_def)

lemma ilist_slice_nth_nth_rev: "
  0 < k \<Longrightarrow> (ilist_slice f k) (n div k) ! (n mod k) = f n"
by (simp add: ilist_slice_nth_nth)

lemma list_slice_concat: "
  concat (list_slice xs k) = xs \<down> (length xs div k * k)"
  (is "?P xs k")
apply (case_tac "k = 0")
 apply (simp add: list_slice_0)
apply simp
apply (subgoal_tac "\<And>m. \<forall>xs. length xs div k = m \<longrightarrow> ?P xs k", simp)
apply (induct_tac m)
 apply (intro allI impI)
 apply (simp add: in_set_conv_nth div_eq_0_conv' list_slice_less)
apply clarify
apply (simp add: add.commute[of k])
apply (subgoal_tac "n * k + k \<le> length xs")
 prefer 2
 apply (simp add: le_less_div_conv[symmetric])
apply (simp add: list_slice_div_eq_Suc)
apply (drule_tac x="xs \<down> (n * k)" in spec)
apply (simp add: min_eqR)
apply (simp add: take_add)
done

lemma list_slice_unslice_mult: "
  length xs = m * k \<Longrightarrow> concat (list_slice xs k) = xs"
apply (case_tac "k = 0")
 apply (simp add: list_slice_Nil)
apply (simp add: list_slice_concat)
done

lemma ilist_slice_unslice: "0 < k \<Longrightarrow> ilist_unslice (ilist_slice f k) = f"
by (simp add: ilist_unslice_def ilist_slice_nth_length ilist_slice_nth_nth)

lemma i_take_ilist_slice_eq_list_slice: "
  0 < k \<Longrightarrow> ilist_slice f k \<Down> n = list_slice (f \<Down> (n * k)) k"
apply (simp add: list_eq_iff list_slice_length ilist_slice_nth list_slice_nth)
apply (clarify, rename_tac i)
apply (subgoal_tac "k \<le> n * k - i * k")
 prefer 2
 apply (drule_tac m=i in Suc_leI)
 apply (drule mult_le_mono1[of _ _ k])
 apply simp
apply simp
done

lemma list_slice_i_take_eq_i_take_ilist_slice: "
  list_slice (f \<Down> n) k = ilist_slice f k \<Down> (n div k)"
apply (case_tac "k = 0")
 apply (simp add: list_slice_0)
apply (simp add: i_take_ilist_slice_eq_list_slice)
apply (subst list_slice_eq_list_slice_take[of "f \<Down> n", symmetric])
apply (simp add: div_mult_le min_eqR)
done

lemma ilist_slice_i_append_mod: "
  length xs mod k = 0 \<Longrightarrow>
  ilist_slice (xs \<frown> f) k = list_slice xs k \<frown> ilist_slice f k"
apply (simp add: ilist_eq_iff ilist_slice_nth i_append_nth list_slice_length)
apply (clarsimp simp: mult.commute[of k] elim!: dvdE, rename_tac n i)
apply (intro conjI impI)
 apply (simp add: list_slice_nth)
 apply (subgoal_tac "k \<le> n * k - i * k")
  prefer 2
  apply (drule_tac m=i in Suc_leI)
  apply (drule mult_le_mono1[of _ _ k])
  apply simp
 apply (fastforce simp: list_eq_iff i_append_nth min_eqR)
apply (simp add: ilist_eq_iff list_eq_iff i_append_nth linorder_not_less)
apply (clarify, rename_tac j)
apply (subgoal_tac "n * k \<le> i * k + j")
 prefer 2
 apply (simp add: trans_le_add1)
apply (simp add: diff_mult_distrib)
done

corollary ilist_slice_append_mult: "
  length xs = m * k \<Longrightarrow>
  ilist_slice (xs \<frown> f) k = list_slice xs k \<frown> ilist_slice f k"
by (simp add: ilist_slice_i_append_mod)

end


theory Lists
imports Main
begin

section {* Lists *}
subsection {* Pairs of Numbers *}

datatype natprod = pair nat nat

value "pair 3 5"
  (* \<Longrightarrow> "pair (Suc (Suc (Suc 0))) (Suc (Suc (Suc (Suc (Suc 0)))))" :: "natprod" *)

fun fst :: "natprod \<Rightarrow> nat" where
  "fst (pair x _) = x"
fun snd :: "natprod \<Rightarrow> nat" where
  "snd (pair _ y) = y"
fun swap_pair :: "natprod \<Rightarrow> natprod" where
  "swap_pair (pair x y) = pair y x"

value "fst (pair 3 5)"
  (* \<Longrightarrow> "Suc (Suc (Suc 0))" :: "nat" *)

(* value "fst (3,5)" *)
  (* \<Longrightarrow> "Suc (Suc (Suc 0))" :: "nat" *)

theorem surjective_pairing': "\<forall>n m :: nat. pair n m = pair (fst (pair n m)) (snd (pair n m))" by simp
theorem surjective_pairing_stuck: "\<forall>(p :: natprod). p = pair (fst p) (snd p)"
apply auto by (case_tac p, simp)

(* Exercise: 1 star (snd_fst_is_swap) *)

theorem snd_fst_is_swap: "\<forall>(p :: natprod). pair (snd p) (fst p) = swap_pair p"
apply auto by (case_tac p, simp)

(* Exercise: 1 star, optional (fst_swap_is_snd) *)

theorem fst_swap_is_snd: "\<forall>(p :: natprod). fst (swap_pair p) = snd p"
apply auto by (case_tac p, simp)

subsection {* Lists of Numbers *}

datatype natlist = nil | cons nat natlist

definition "mylist \<equiv> cons 1 (cons 2 (cons 3 nil))"

no_notation
  List.Nil ("[]")

notation
  nil ("[]") and
  cons (infixr ";" 60)

no_syntax
  "_list" :: "args \<Rightarrow> 'a list" ("[(_)]")

syntax
  "_natlist" :: "args \<Rightarrow> natlist" ("[(_)]")

translations
  "[x; xs]" == "x;[xs]"
  "[x]" == "x;[]"

definition "mylist1 \<equiv> 1 ; (2 ; (3 ; nil))"
definition "mylist2 \<equiv> 1 ; 2 ; 3 ; nil"
definition "mylist3 \<equiv> [1;2;3]"

subsubsection {* Repeat *}

fun repeat :: "nat \<Rightarrow> nat \<Rightarrow> natlist" where
  "repeat n 0 = []"
  | "repeat n (Suc count) = n ; (repeat n count)"

subsubsection {* Length *}

fun length :: "natlist \<Rightarrow> nat" where
  "length nil = 0"
  | "length (h ; t) = Suc (length t)"

subsubsection {* Append *}

no_notation
  Map.map_add (infixl "++" 100)

fun app :: "natlist \<Rightarrow> natlist \<Rightarrow> natlist" (infixr "++" 80) where
  "app nil l2 = l2"
  | "app (h ; t) l2 = h ; (app t l2)"

lemma test_app1: "[1;2;3] ++ [4;5] = [1;2;3;4;5]" by simp
lemma test_app2: "nil ++ [4;5] = [4;5]" by simp
lemma test_app3: "[1;2;3] ++ nil = [1;2;3]" by simp

subsubsection {* Head (with default) and Tail *}

fun hd :: "nat \<Rightarrow> natlist \<Rightarrow> nat" where
  "hd d nil = d"
  | "hd _ (h ; t) = h"

fun tl :: "natlist \<Rightarrow> natlist" where
  "tl nil = nil"
  | "tl (h ; t) = t"

lemma test_hd1: "hd 0 [1;2;3] = 1" by simp
lemma test_hd2: "hd 0 [] = 0" by simp
lemma test_tl: "tl [1;2;3] = [2;3]" by simp

(* Exercise: 2 stars (list_funs) *)

fun nonzeros :: "natlist \<Rightarrow> natlist" where
  "nonzeros nil = nil"
  | "nonzeros (h ; t) = (if h = 0 then nonzeros t else h ; nonzeros t)"

lemma test_nonzeros: "nonzeros [0;1;0;2;3;0;0] = [1;2;3]" by simp

fun oddmembers :: "natlist \<Rightarrow> natlist" where
  "oddmembers nil = nil"
  | "oddmembers (h ; t) = (if h mod 2 = 0 then oddmembers t else h ; oddmembers t)"

lemma test_oddmembers: "oddmembers [0;1;0;2;3;0;0] = [1;3]" by simp

fun countoddmembers :: "natlist \<Rightarrow> nat" where
  "countoddmembers l = length (oddmembers l)"

lemma test_countoddmembers1: "countoddmembers [1;0;3;1;4;5] = 4" by simp
lemma test_countoddmembers2: "countoddmembers [0;2;4] = 0" by simp
lemma test_countoddmembers3: "countoddmembers nil = 0" by simp

(* Exercise: 3 stars, advanced (alternate) *)

fun alternate :: "natlist \<Rightarrow> natlist \<Rightarrow> natlist" where
  "alternate nil l2 = l2"
  | "alternate l1 nil = l1"
  | "alternate (h1;t1) (h2;t2) = h1 ; h2 ; alternate t1 t2"

lemma test_alternate1: "alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6]" by simp
lemma test_alternate2: "alternate [1] [4;5;6] = [1;4;5;6]" by simp
lemma test_alternate3: "alternate [1;2;3] [4] = [1;4;2;3]" by simp
lemma test_alternate4: "alternate [] [20;30] = [20;30]" by simp

subsubsection {* Bags via Lists *}

type_synonym bag = natlist

(* Exercise: 3 stars (bag_functions) *)

fun count :: "nat \<Rightarrow> bag \<Rightarrow> nat" where
  "count _ nil = 0"
  | "count a (h ; t) = (if a = h then 1 + count a t else count a t)"

lemma test_count1: "count 1 [1;2;3;1;4;1] = 3" by simp
lemma test_count2: "count 6 [1;2;3;1;4;1] = 0" by simp

fun sum :: "bag \<Rightarrow> bag \<Rightarrow> bag" where
  "sum l1 l2 = l1 ++ l2"

lemma test_sum1: "count 1 (sum [1;2;3] [1;4;1]) = 3" by simp

fun add :: "nat \<Rightarrow> bag \<Rightarrow> bag" where
  "add x xs = x ; xs"

lemma test_add1: "count 1 (add 1 [1;4;1]) = 3" by simp
lemma test_add2: "count 5 (add 1 [1;4;1]) = 0" by simp

fun member :: "nat \<Rightarrow> bag \<Rightarrow> bool" where
  "member x nil = False"
  | "member x (h; t) = (if x = h then True else member x t)"

lemma test_member1: "member 1 [1;4;1] = True" by simp
lemma test_member2: "member 2 [1;4;1] = False" by simp

(* Exercise: 3 stars, optional (bag_more_functions) *)

fun remove_one :: "nat \<Rightarrow> bag \<Rightarrow> bag" where
  "remove_one _ nil = nil"
  | "remove_one x (h;t) = (if x = h then t else h ; remove_one x t)"

lemma test_remove_one1: "count 5 (remove_one 5 [2;1;5;4;1]) = 0" by simp
lemma test_remove_one2: "count 5 (remove_one 5 [2;1;4;1]) = 0" by simp
lemma test_remove_one3: "count 4 (remove_one 5 [2;1;4;5;1;4]) = 2" by simp
lemma test_remove_one4: "count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1" by simp

fun remove_all :: "nat \<Rightarrow> bag \<Rightarrow> bag" where
  "remove_all _ nil = nil"
  | "remove_all x (h;t) = (if x = h then remove_all x t else h ; remove_all x t)"

lemma test_remove_all1: "count 5 (remove_all 5 [2;1;5;4;1]) = 0" by simp
lemma test_remove_all2: "count 5 (remove_all 5 [2;1;4;1]) = 0" by simp
lemma test_remove_all3: "count 4 (remove_all 5 [2;1;4;5;1;4]) = 2" by simp
lemma test_remove_all4: "count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0" by simp

fun subset :: "bag \<Rightarrow> bag \<Rightarrow> bool" where
  "subset nil _ = True"
  | "subset (x ; xs) ys = (if count x ys = 0 then False else subset xs (remove_one x ys))"

lemma test_subset1: "subset [1;2] [2;1;4;1] = True" by simp
lemma test_subset2: "subset [1;2;2] [2;1;4;1] = False" by simp

(* Exercise: 3 stars (bag_theorem) *)

subsection {* Reasoning About Lists *}

theorem nil_app: "\<forall>l::natlist. [] ++ l = l" by simp

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

theorem tl_length_pred: "\<forall>l::natlist. pred (length l) = length (tl l)"
apply auto by (case_tac l, auto)

subsubsection {* Micro-Sermon *}
subsubsection {* Induction on Lists *}

theorem app_assoc: "\<forall>l1 l2 l3 :: natlist. (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3)"
apply auto by (induct_tac l1, auto)

subsubsection {* Informal version *}

(* Informal version of the proof *)
theorem app_assoc_Isar: "\<forall>l1 l2 l3 :: natlist. (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3)"
proof (auto, induct_tac l1)
  (* case l1 = [] *)
  show "\<And>l1 l2 l3. ([] ++ l2) ++ l3 = [] ++ l2 ++ l3" by simp
next
  (* case l1 = nat ; natlist *)
  fix l1 l2 l3 nat natlist
  assume hyp: "(natlist ++ l2) ++ l3 = natlist ++ l2 ++ l3"
  show "((nat ; natlist) ++ l2) ++ l3 = (nat ; natlist) ++ l2 ++ l3"
    using hyp by simp
qed

subsubsection {* Another example *}

theorem app_length: "\<forall>l1 l2 :: natlist. length (l1 ++ l2) = (length l1) + (length l2)"
apply auto by (induct_tac l1, auto)

subsubsection {* Reversing a list *}

fun snoc :: "natlist \<Rightarrow> nat \<Rightarrow> natlist" where
  "snoc nil v = [v]"
  | "snoc (h;t) v = h ; (snoc t v)"

fun rev :: "natlist \<Rightarrow> natlist" where
  "rev nil = nil"
  | "rev (h ; t) = snoc (rev t) h"

lemma test_rev1: "rev [1;2;3] = [3;2;1]" by simp
lemma test_rev2: "rev nil = nil" by simp

subsubsection {* Proofs about reverse *}

theorem length_snoc: "\<forall>n :: nat. \<forall>l :: natlist. length (snoc l n) = Suc (length l)"
apply auto by (induct_tac l, auto)

theorem rev_length: "\<forall>l :: natlist. length (rev l) = length l"
apply auto by (induct_tac l, auto simp add: length_snoc)

theorem length_snoc_Isar: "\<forall>n :: nat. \<forall>l :: natlist. length (snoc l n) = Suc (length l)"
proof (auto, induct_tac l)
  (* case l = [] *)
  fix n l
  show "Lists.length (snoc [] n) = Suc (Lists.length [])" by simp
next
  (* case l = nat ; natlist *)
  fix n l nat natlist
  assume hyp: "Lists.length (snoc natlist n) = Suc (Lists.length natlist)"
  show "Lists.length (snoc (nat ; natlist) n) = Suc (Lists.length (nat ; natlist))"
    using hyp by simp
qed

(* theorem rev_length_Isar: "\<forall>l :: natlist. length (rev l) = length l" *)

subsubsection {* SearchAbout *}
subsubsection {* List Exercises, Part 1 *}

(* Exercise: 3 stars (list_exercises) *)

theorem app_nil_end: "\<forall>l :: natlist. l ++ [] = l"
apply auto by (induct_tac l, auto)

lemma rev_involutive_lem: "\<And>x :: nat. \<And>l :: natlist. rev (snoc l x) = x ; rev l"
by (induct_tac l, auto)

theorem rev_involutive: "\<forall>l :: natlist. rev (rev l) = l"
apply auto by (induct_tac l, auto simp add: rev_involutive_lem)

theorem app_assoc4: "\<forall>l1 l2 l3 l4 :: natlist. l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4"
apply auto by (induct_tac l1, auto simp add: app_assoc)

theorem snoc_append: "\<forall>(l::natlist) (n::nat). snoc l n = l ++ [n]"
apply auto by (induct_tac l, auto)

theorem distr_rev: "\<forall>l1 l2 :: natlist. rev (l1 ++ l2) = (rev l2) ++ (rev l1)"
apply auto by (induct_tac l1, auto simp add: app_nil_end snoc_append app_assoc)

lemma nonzeros_app: "\<forall>l1 l2 :: natlist. nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2)"
apply auto by (induct_tac l1, auto)

(* Exercise: 2 stars (beq_natlist) *)

fun beq_natlist :: "natlist \<Rightarrow> natlist \<Rightarrow> bool" where
  "beq_natlist nil nil = True"
  | "beq_natlist nil _ = False"
  | "beq_natlist _ nil = False"
  | "beq_natlist (h1;t1) (h2;t2) = (if h1 = h2 then beq_natlist t1 t2 else False)"

lemma test_beq_natlist1: "beq_natlist nil nil = True" by simp
lemma test_beq_natlist2: "beq_natlist [1;2;3] [1;2;3] = True" by simp
lemma test_beq_natlist3: "beq_natlist [1;2;3] [1;2;4] = False" by simp

theorem beq_natlist_refl: "\<forall>l::natlist. True = beq_natlist l l"
apply auto by (induct_tac l, auto)

subsubsection {* List Exercises, Part 2 *}

(* Exercise: 2 stars (list_design) *)
(* Exercise: 3 stars, advanced (bag_proofs) *)

(* ble_nat = \<le> *)
theorem count_member_nonzero: "\<forall>(s :: bag). 1 \<le> (count 1 (1 ; s)) = True" by simp

theorem ble_n_Sn : "\<forall>n. n \<le> (Suc n) = True" by simp

theorem remove_decreases_count: "\<forall>(s :: bag). count 0 (remove_one 0 s) \<le> count 0 s = True"
apply auto by (induct_tac s, auto)

(* Exercise: 3 stars, optional (bag_count_sum) *)
(* Exercise: 4 stars, advanced (rev_injective) *)

lemma rev_injective_lem: "\<And>l1 l2. rev (rev l1) = rev (rev l2) \<Longrightarrow> l1 = l2"
by (auto simp add: rev_involutive)

theorem rev_injective: "\<forall>l1 l2 :: natlist. rev l1 = rev l2 \<longrightarrow> l1 = l2"
apply auto by (auto simp add: rev_injective_lem)

(* a hard way? *)

subsection {* Options *}

datatype natoption = Some nat | None

fun index :: "nat \<Rightarrow> natlist \<Rightarrow> natoption" where
  "index n nil = None"
  | "index n (a ; l) = (if n = 0 then Some a else index (pred n) l)"

lemma test_index1: "index 0 [4;5;6;7] = Some 4" by simp
lemma test_index2: "index 3 [4;5;6;7] = Some 7"
proof -
  have 3: "3 = Suc (Suc 1)" by simp
  show ?thesis by (simp add: 3)
qed
lemma test_index3: "index 10 [4;5;6;7] = None"
proof -
  have 10: "10 = Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 1))))))))" by simp
  show ?thesis by (simp add: 10)
qed

fun option_elim :: "nat \<Rightarrow> natoption \<Rightarrow> nat" where
  "option_elim d (Some n) = n"
  | "option_elim d None = d"

(* Exercise: 2 stars (hd_opt) *)

fun hd_opt :: "natlist \<Rightarrow> natoption" where
  "hd_opt nil = None"
  | "hd_opt l = Some (hd 0 l)"

lemma test_hd_opt1: "hd_opt [] = None" by simp
lemma test_hd_opt2: "hd_opt [1] = Some 1" by simp
lemma test_hd_opt3: "hd_opt [5;6] = Some 5" by simp

(* Exercise: 1 star, optional (option_elim_hd) *)

theorem option_elim_hd: "\<forall>(l::natlist) (default::nat). hd default l = option_elim default (hd_opt l)"
apply auto by (induct_tac l, auto)

subsection {* Dictionaries *}

datatype dictionary = empty | record' nat nat dictionary

fun insert :: "nat \<Rightarrow> nat \<Rightarrow> dictionary \<Rightarrow> dictionary" where
  "insert key value d = record' key value d"

fun find :: "nat \<Rightarrow> dictionary \<Rightarrow> natoption" where
  "find key empty = None"
  | "find key (record' k v d) = (if key = k then Some v else find key d)"

(* Exercise: 1 star (dictionary_invariant1) *)

theorem dictionary_invariant1': "\<forall>(d :: dictionary) k (v :: nat). (find k (insert k v d)) = Some v"
by simp

(* Exercise: 1 star (dictionary_invariant2) *)

theorem dictionary_invariant2': "\<forall>(d :: dictionary) (m :: nat) n o'. m = n = False \<longrightarrow> find m d = find m (insert n o' d)"
by simp

end


(*  Title:      HOL/Examples/Knaster_Tarski.thy
    Author:     Makarius

Typical textbook proof example.
*)

section \<open>Textbook-style reasoning: the Knaster-Tarski Theorem\<close>

theory Knaster_Tarski
  imports Main
begin

unbundle lattice_syntax

subsection \<open>Prose version\<close>

text \<open>
  According to the textbook \<^cite>\<open>\<open>pages 93--94\<close> in "davey-priestley"\<close>, the
  Knaster-Tarski fixpoint theorem is as follows.\<^footnote>\<open>We have dualized the
  argument, and tuned the notation a little bit.\<close>

  \<^bold>\<open>The Knaster-Tarski Fixpoint Theorem.\<close> Let \<open>L\<close> be a complete lattice and
  \<open>f: L \<rightarrow> L\<close> an order-preserving map. Then \<open>\<Sqinter>{x \<in> L | f(x) \<le> x}\<close> is a fixpoint
  of \<open>f\<close>.

  \<^bold>\<open>Proof.\<close> Let \<open>H = {x \<in> L | f(x) \<le> x}\<close> and \<open>a = \<Sqinter>H\<close>. For all \<open>x \<in> H\<close> we have
  \<open>a \<le> x\<close>, so \<open>f(a) \<le> f(x) \<le> x\<close>. Thus \<open>f(a)\<close> is a lower bound of \<open>H\<close>, whence
  \<open>f(a) \<le> a\<close>. We now use this inequality to prove the reverse one (!) and
  thereby complete the proof that \<open>a\<close> is a fixpoint. Since \<open>f\<close> is
  order-preserving, \<open>f(f(a)) \<le> f(a)\<close>. This says \<open>f(a) \<in> H\<close>, so \<open>a \<le> f(a)\<close>.\<close>

subsection \<open>Formal versions\<close>

text \<open>
  The Isar proof below closely follows the original presentation. Virtually
  all of the prose narration has been rephrased in terms of formal Isar
  language elements. Just as many textbook-style proofs, there is a strong
  bias towards forward proof, and several bends in the course of reasoning.
\<close>

theorem Knaster_Tarski:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "\<exists>a. f a = a"
proof
  let ?H = "{u. f u \<le> u}"
  let ?a = "\<Sqinter>?H"
  show "f ?a = ?a"
  proof -
    {
      fix x
      assume "x \<in> ?H"
      then have "?a \<le> x" by (rule Inf_lower)
      with \<open>mono f\<close> have "f ?a \<le> f x" ..
      also from \<open>x \<in> ?H\<close> have "\<dots> \<le> x" ..
      finally have "f ?a \<le> x" .
    }
    then have "f ?a \<le> ?a" by (rule Inf_greatest)
    {
      also presume "\<dots> \<le> f ?a"
      finally (order_antisym) show ?thesis .
    }
    from \<open>mono f\<close> and \<open>f ?a \<le> ?a\<close> have "f (f ?a) \<le> f ?a" ..
    then have "f ?a \<in> ?H" ..
    then show "?a \<le> f ?a" by (rule Inf_lower)
  qed
qed

text \<open>
  Above we have used several advanced Isar language elements, such as explicit
  block structure and weak assumptions. Thus we have mimicked the particular
  way of reasoning of the original text.

  In the subsequent version the order of reasoning is changed to achieve
  structured top-down decomposition of the problem at the outer level, while
  only the inner steps of reasoning are done in a forward manner. We are
  certainly more at ease here, requiring only the most basic features of the
  Isar language.
\<close>

theorem Knaster_Tarski':
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "\<exists>a. f a = a"
proof
  let ?H = "{u. f u \<le> u}"
  let ?a = "\<Sqinter>?H"
  show "f ?a = ?a"
  proof (rule order_antisym)
    show "f ?a \<le> ?a"
    proof (rule Inf_greatest)
      fix x
      assume "x \<in> ?H"
      then have "?a \<le> x" by (rule Inf_lower)
      with \<open>mono f\<close> have "f ?a \<le> f x" ..
      also from \<open>x \<in> ?H\<close> have "\<dots> \<le> x" ..
      finally show "f ?a \<le> x" .
    qed
    show "?a \<le> f ?a"
    proof (rule Inf_lower)
      from \<open>mono f\<close> and \<open>f ?a \<le> ?a\<close> have "f (f ?a) \<le> f ?a" ..
      then show "f ?a \<in> ?H" ..
    qed
  qed
qed

end


(*
  File:     Complex_Lexorder.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>The lexicographic ordering on complex numbers\<close>
theory Complex_Lexorder
  imports Complex_Main "HOL-Library.Multiset"
begin

text \<open>
  We define a lexicographic order on the complex numbers, comparing first the real parts
  and, if they are equal, the imaginary parts. This ordering is of course not compatible with
  multiplication, but it is compatible with addition.
\<close>

definition less_eq_complex_lex (infix "\<le>\<^sub>\<complex>" 50)  where
  "less_eq_complex_lex x y \<longleftrightarrow> Re x < Re y \<or> Re x = Re y \<and> Im x \<le> Im y"

definition less_complex_lex (infix "<\<^sub>\<complex>" 50) where
  "less_complex_lex x y \<longleftrightarrow> Re x < Re y \<or> Re x = Re y \<and> Im x < Im y"

interpretation complex_lex:
  linordered_ab_group_add "(+)" 0 "(-)" "uminus" less_eq_complex_lex less_complex_lex
  by standard (auto simp: less_eq_complex_lex_def less_complex_lex_def complex_eq_iff)

lemmas [trans] =
  complex_lex.order.trans complex_lex.less_le_trans
  complex_lex.less_trans complex_lex.le_less_trans

lemma (in ordered_comm_monoid_add) sum_mono_complex_lex:
  "(\<And>i. i\<in>K \<Longrightarrow> f i \<le>\<^sub>\<complex> g i) \<Longrightarrow> (\<Sum>i\<in>K. f i) \<le>\<^sub>\<complex> (\<Sum>i\<in>K. g i)"
  by (induct K rule: infinite_finite_induct) (use complex_lex.add_mono in auto)

lemma sum_strict_mono_ex1_complex_lex:
  fixes f g :: "'i \<Rightarrow> complex"
  assumes "finite A"
    and "\<forall>x\<in>A. f x \<le>\<^sub>\<complex> g x"
    and "\<exists>a\<in>A. f a <\<^sub>\<complex> g a"
  shows "sum f A <\<^sub>\<complex> sum g A"
proof-
  from assms(3) obtain a where a: "a \<in> A" "f a <\<^sub>\<complex> g a" by blast
  have "sum f A = sum f ((A - {a}) \<union> {a})"
    by (simp add: insert_absorb[OF \<open>a \<in> A\<close>])
  also have "\<dots> = sum f (A - {a}) + sum f {a}"
    using \<open>finite A\<close> by (subst sum.union_disjoint) auto
  also have "\<dots> \<le>\<^sub>\<complex> sum g (A - {a}) + sum f {a}"
    by (intro complex_lex.add_mono sum_mono_complex_lex) (simp_all add: assms)
  also have "\<dots> <\<^sub>\<complex> sum g (A - {a}) + sum g {a}"
    using a by (intro complex_lex.add_strict_left_mono) auto
  also have "\<dots> = sum g ((A - {a}) \<union> {a})"
    using \<open>finite A\<close> by (subst sum.union_disjoint[symmetric]) auto
  also have "\<dots> = sum g A" by (simp add: insert_absorb[OF \<open>a \<in> A\<close>])
  finally show ?thesis
    by simp
qed

lemma sum_list_mono_complex_lex:
  assumes "list_all2 (\<le>\<^sub>\<complex>) xs ys"
  shows   "sum_list xs \<le>\<^sub>\<complex> sum_list ys"
  using assms by induction (auto intro: complex_lex.add_mono)

lemma sum_mset_mono_complex_lex:
  assumes "rel_mset (\<le>\<^sub>\<complex>) A B"
  shows   "sum_mset A \<le>\<^sub>\<complex> sum_mset B"
  using assms by (auto simp: rel_mset_def sum_mset_sum_list intro: sum_list_mono_complex_lex)

lemma rel_msetI:
  assumes "list_all2 R xs ys" "mset xs = A" "mset ys = B"
  shows   "rel_mset R A B"
  using assms by (auto simp: rel_mset_def)

lemma mset_replicate [simp]: "mset (replicate n x) = replicate_mset n x"
  by (induction n) auto

lemma rel_mset_replicate_mset_right:
  assumes "\<And>x. x \<in># A \<Longrightarrow> R x y" "size A = n"
  shows   "rel_mset R A (replicate_mset n y)"
proof -
  obtain xs where [simp]: "A = mset xs"
    by (metis ex_mset)
  from assms have "\<forall>x\<in>set xs. R x y"
    by auto
  hence "list_all2 R xs (replicate (length xs) y)"
    by (induction xs) auto
  with assms(2) show ?thesis
    by (intro rel_msetI[of R xs "replicate n y"]) auto
qed

end


theory "selection-sort"
  imports Main "HOL-Library.Multiset"
begin

text \<open>no tail-recursive\<close>

lemma remove_member: "y \<in> set (x#xs) \<Longrightarrow> length (remove1 y (x#xs)) < length (x#xs)"
proof(induct xs arbitrary: y x)
  case Nil
  have "length (remove1 y [x]) = length (remove1 x [x])" using Nil.prems by simp
  also have "length (remove1 x [x]) = length []" by simp
  also have "length [] < length [x]" by simp
  finally show "length (remove1 y [x]) < length [x]" by this
next
  case (Cons a xs)
  then show "length (remove1 y (x # a # xs)) < length (x # a # xs)"
  proof(cases "y \<in> set (a # xs)")
    case True
    have "length (remove1 y (x # a # xs)) = length (x#remove1 y (a # xs))" using One_nat_def Suc_pred True length_Cons length_pos_if_in_set length_remove1 remove1.simps(2)  by metis
    also have "... = length [x] + length (remove1 y (a # xs))"  by simp
    also have "... < length [x] + length (a # xs)" using Cons.hyps True by simp
    also have "... = length (x # a # xs)" by simp
    finally show "length (remove1 y (x # a # xs)) < length (x # a # xs)" by this
  next
    case False
    have "length (remove1 y (x # a # xs)) = length (remove1 x (x # a # xs))" using Cons.prems False by simp
    also have "... = length (a # xs)" by simp
    also have "... < length (x # a # xs)" by simp
    finally show "length (remove1 y (x # a # xs)) < length (x # a # xs)" by this
  qed
qed

function selection_sort:: "nat list \<Rightarrow> nat list" where
selection_sort_Null:  "selection_sort [] = []" |
selection_sort_Cons: "selection_sort (x#xs) = (let minimum = Min (set(x#xs)); rest = remove1 minimum (x#xs) in minimum#selection_sort(rest))"
by pat_completeness auto
termination
proof (relation "measure (\<lambda>(xs). length xs)")
  show "wf (measure length)"  by simp
next
  fix minimum x ::nat
  fix rest xs:: "nat list"
  assume a1: "minimum =  Min (set (x # xs))"
  assume a2: "rest = remove1 minimum (x # xs)"
  show "(rest, x # xs) \<in> measure length"
  proof (simp only: in_measure)
    have p1: "minimum \<in> set (x#xs)" using a1 eq_Min_iff by blast
    show "length rest < length (x # xs)" using a2 p1 by (simp only:remove_member)
  qed
qed

value "selection_sort [2,4,10,0,0]"

theorem selection_sort_permutation: "mset (selection_sort(xs)) = mset xs"
proof(induct xs rule: selection_sort.induct)
  case 1
  then show "mset (selection_sort []) = mset []" by simp
next
  case (2 x xs)
  let ?minimum = "Min (set (x # xs))"
  let ?rest = "remove1 ?minimum (x # xs)"
  have IH: "mset (selection_sort ?rest) = mset ?rest" using "2.hyps" by simp
  then show "mset (selection_sort (x # xs)) = mset (x # xs)"
  proof(cases "?minimum = x")
    case True
    have "mset (selection_sort (x # xs)) = mset(?minimum#selection_sort(?rest))" using True by simp
    also have "... = {#?minimum#} + mset(selection_sort(?rest))" by simp
    also have "... = {#?minimum#} + mset(?rest)" using IH by simp
    also have "... = {#?minimum#} + mset(remove1 x (x # xs))" using True by simp
    also have "... = {#?minimum#} + mset(xs)" by simp
    also have "... = {#x#} + mset(xs)" using True by simp
    also have "... = mset (x#xs)" by simp
    finally show "mset (selection_sort (x # xs)) = mset (x # xs)" by this
  next
    case False
    have c1: "mset (selection_sort (x # xs)) = mset(?minimum#selection_sort(?rest))" by (metis "selection-sort.selection_sort_Cons")
    also have c2:"... = {#?minimum#} + mset(selection_sort(?rest))" by simp
    also have c3:"... = {#?minimum#} + mset(?rest)" using IH by simp
    also have c4:"... = {#?minimum#} + mset(x # xs) - {#?minimum#}" by (metis List.finite_set Min_in diff_union_single_conv list.distinct(1) mset_remove1 set_empty set_mset_mset)
    also have c5:"... = mset (x # xs)" by simp
    finally show "mset (selection_sort (x # xs)) = mset (x # xs)" by this
  qed
qed

theorem selection_sort_order: "sorted (selection_sort(xs))"
proof(induct xs rule:selection_sort.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs)
  let ?minimum = "Min (set (x # xs))"
  let ?rest = "remove1 ?minimum (x # xs)"
  show "sorted (selection_sort (x # xs))"
  proof(simp only:selection_sort_Cons Let_def)
    show "sorted (?minimum # selection_sort (?rest))"
    proof (simp only:Let_def sorted.simps)
      show "Ball (set (selection_sort (?rest))) ((\<le>) (?minimum)) \<and> sorted (selection_sort (?rest))"
      proof (rule conjI)
        have p1: "mset(selection_sort(?rest)) = mset(x # xs) - {#?minimum#}"
        proof -
          have c1:"mset(selection_sort(?rest)) = mset(?rest)"  using selection_sort_permutation by blast
          also have c2:"... = mset(x # xs) - {#?minimum#}"  using c1 by simp
          finally show "mset(selection_sort(?rest)) = mset(x # xs) - {#?minimum#}" by this
        qed
        show "Ball (set (selection_sort (?rest))) ((\<le>) (?minimum))"  by (metis List.finite_set Min_le in_diffD p1 set_mset_mset)
      next
        have "sorted (selection_sort (?rest))" using "2.hyps" by simp
        then show "sorted (selection_sort (?rest))" by assumption
      qed
    qed
  qed
qed

text \<open>tail-recursive\<close>

lemma max_membership: "m = Max(set (x#xs)) \<Longrightarrow> m \<in> set (x#xs)"
proof(induct xs arbitrary: x m)
  case Nil
  have "m = Max (set [x])" using Nil.prems by simp
  also have "... \<in> set [x]" by simp
  finally show "m \<in> set [x]" by this
next
  case (Cons a xs)
   have "m = Max (set (x # a # xs))" using Cons.prems by simp
   also have "... \<in> set (x # a # xs)"  using Max_in by blast
   finally show "m \<in> set (x # a # xs)" by this
qed

function tr_selection_sort:: "nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
"tr_selection_sort [] accum = accum" |
"tr_selection_sort (x#xs) accum = (let max = Max (set(x#xs)); rest =remove1 max (x#xs) in tr_selection_sort(rest) (max#accum))"
by pat_completeness auto
termination
proof(relation "measure (\<lambda>(xs, accum). size xs)")
  show "wf (measure (\<lambda>(xs, accum). length xs))"  by simp
next
  fix maximum x ::nat
  fix rest xs accum:: "nat list"
  assume a1: "maximum =  Max (set (x # xs))"
  assume a2: "rest = remove1 maximum (x # xs)"
  show "((rest, maximum # accum), x # xs, accum) \<in> measure (\<lambda>(xs, accum). length xs)"
  proof (simp only: in_measure)
    show "(case (rest, maximum # accum) of (xs, accum) \<Rightarrow> length xs) < (case (x # xs, accum) of (xs, accum) \<Rightarrow> length xs)"
    proof(simp only: prod.case)
      have p1: "maximum \<in> set (x#xs)" using a1 by (simp only: max_membership)
      show "length rest < length (x # xs)" using a2 p1 by (simp only:remove_member)
    qed
  qed
qed

value "tr_selection_sort [2,4,10,0,0] []"

theorem tr_selection_sort_output_sorted: "\<lbrakk>sorted (ACCUM);  \<forall>A e. A \<in> (set ACCUM) \<and> e \<in> set xs \<and> e \<le> A\<rbrakk>\<Longrightarrow> sorted (tr_selection_sort xs ACCUM)"
proof(induct xs arbitrary: ACCUM rule:tr_selection_sort.induct)
  case (1 zs)
  then show ?case  by (simp add: sorted01)
next
  case (2 v va zs)
  then show "sorted (tr_selection_sort zs ACCUM)"  by (simp add: sorted01)
qed

theorem tr_selection_sort_is_permutation_of_input: "\<lbrakk>sorted (ACCUM); \<forall>A e. A \<in> (set ACCUM) \<and> e \<in> set xs \<and> e \<le> A\<rbrakk>  \<Longrightarrow> mset (tr_selection_sort xs ACCUM) = mset xs + mset ACCUM"
proof(induct xs arbitrary: ACCUM)
  case Nil
  show ?case by simp
next
  case (Cons a xs)
  show "mset (tr_selection_sort (a # xs) ACCUM) = mset (a # xs) + mset ACCUM"  using Cons.prems(2) by blast
qed


theory pascalsIdentity
  imports Main "HOL-Number_Theory.Number_Theory"
begin

fun comb :: "nat ⇒ nat ⇒ real" where
  "comb n k = (if n < k then 0 else fact n / (fact k * fact (n - k)))"

theorem pascals_identity:
  fixes n k :: nat
  assumes "n > 0 ∧ k > 0"
  shows "comb n k = comb (n - 1) (k - 1) + comb (n - 1) k"
proof cases
  {
    assume nLessThank: "n < k"
    then have lessThanRule: "n - 1 < k - 1" using assms by linarith
    thus ?thesis by auto
  }
next
  {
  assume nNotLessk:"¬ n < k"
  hence "n ≥ k" by auto
  show ?thesis
  proof cases
    {
      assume nEqualk: "n = k"
      thus ?thesis using assms by auto
    }
  next
    {
      assume "¬ n = k"
      hence nGreaterk: "n > k" using nNotLessk by auto

      have "comb n k = fact n / (fact k * fact (n - k))"
        by (simp add: nNotLessk)

      also have "fact n / (fact k * fact (n - k)) = fact(n - 1) * n  / (fact k * fact (n - k))"
        by (simp add: assms fact_reduce semiring_normalization_rules(7))

      also have "fact(n - 1) * n  / (fact k * fact (n - k)) =
                 fact(n - 1) * ((n - k) / (fact k * fact (n - k)) + k / (fact k * fact (n - k)))"
        by (metis (no_types, hide_lams) ‹k ≤ n› add_divide_distrib le_add_diff_inverse2 of_nat_add of_nat_fact of_nat_mult times_divide_eq_right)

      also have "fact(n - 1) * ((n - k) / (fact k * fact (n - k)) + k / (fact k * fact (n - k))) =
                    fact (n - 1) * (1 / (fact k * fact (n - k - 1)) + 1 / (fact (k - 1) * fact (n - k)))"
      proof -
        have part1: " (n - k) / (fact k * fact (n - k)) = (n - k) / fact (n - k) / fact k" by auto
        have part2: "(n - k) / fact(n - k) = 1 / fact(n - k - 1)"
          by (metis ‹k ≤ n› ‹n ≠ k› diff_is_0_eq divide_divide_eq_left divide_self_if fact_reduce le_antisym nGreaterk of_nat_eq_0_iff zero_less_diff)
        have part3: "k / (fact k * fact (n - k)) =  1 / (fact (k - 1) * fact (n - k))"
          by (metis (no_types, lifting) assms divide_divide_eq_left divide_self_if fact_reduce neq0_conv of_nat_eq_0_iff)
        show ?thesis using part1 part2 part3 by auto
      qed

      also have "fact (n - 1) * (1 / (fact k * fact (n - k - 1)) + 1 / (fact (k - 1) * fact (n - k))) =
                       fact (n - 1) * 1 / (fact k * fact (n - k - 1)) + fact (n - 1) * 1 / (fact (k - 1) * fact (n - k))"
      proof -
        show ?thesis sorry
      qed

      also have "fact (n - 1) * 1 / (fact k * fact (n - k - 1)) + fact (n - 1) * 1 / (fact (k - 1) * fact (n - k)) =
                fact (n - 1) / (fact k * fact (n - k - 1)) + fact (n - 1) / (fact (k - 1) * fact (n - k))"
        by auto

      also have "fact (n - 1) / (fact k * fact (n - k - 1)) + fact (n - 1) / (fact (k - 1) * fact (n - k)) =
                 comb (n - 1) (k - 1) + comb (n - 1) k"
        using ‹n ≠ k› assms nNotLessk by auto

      finally show ?thesis by auto
    }
qed
}
end


theory Demo
imports "$HIPSTER_HOME/IsaHipster"
begin

(* Normal list datatype *)
datatype 'a Lst =
   Nil
  | Cons "'a" "'a Lst" (infix ";" 65)

(* The append function. Syntactic sugar: we use +++ instead of Haskell's ++ *)
fun app :: "'a Lst \<Rightarrow> 'a Lst \<Rightarrow> 'a Lst" (infix "+++" 60)
where
  "Nil +++ xs = xs"
| "(x;xs) +++ ys = x;(xs +++ ys)"

(* The reverse function *)
fun rev :: "'a Lst \<Rightarrow> 'a Lst"
where
  "rev Nil = Nil"
| "rev (x;xs) = (rev xs) +++ (x;Nil)"

(* Datatype for binary trees from your exercises *)
datatype 'a Tree =
  Empty
  | Node "'a" "'a Tree" "'a Tree"

(* The swap function: swaps the left and right subtree. *)
fun swap :: "'a Tree => 'a Tree"
where
  "swap Empty = Empty"
| "swap (Node data l r) = Node data (swap r) (swap l)"

(* The flatten function: turn a tree into a list *)
fun flatten :: "'a Tree \<Rightarrow> 'a Lst"
where
  "flatten Empty = Nil"
| "flatten (Node data l r) =  ((flatten l) +++ (data;Nil)) +++ (flatten r)"

hipster app rev
lemma lemma_a [thy_expl]: "y +++ Lst.Nil = y"
apply (induct y)
by simp_all

lemma lemma_aa [thy_expl]: "(y +++ z) +++ x2 = y +++ (z +++ x2)"
apply (induct y arbitrary: x2 z)
by simp_all

lemma lemma_ab [thy_expl]: "Demo.rev z +++ Demo.rev y = Demo.rev (y +++ z)"
apply (induct y arbitrary: z)
apply (simp_all add: Demo.lemma_a)
by (metis lemma_aa)

lemma lemma_ac [thy_expl]: "Demo.rev (Demo.rev y) = y"
apply (induct y)
apply simp_all
by (metis Demo.rev.simps(1) Demo.rev.simps(2) Lst.distinct(1) app.elims app.simps(2) lemma_ab)

hipster swap flatten
lemma lemma_ad [thy_expl]: "swap (swap y) = y"
apply (induct y)
by simp_all

(* Last week's exercise 10 *)
theorem exercise10: "flatten (swap p) = rev (flatten p)"
(*  apply hipster_induct *)
  apply (induct p)
  apply simp_all
  by (metis Demo.rev.simps(1) Demo.rev.simps(2) lemma_a lemma_aa lemma_ab)

(* Hard exercise (optional) *)
fun qrev :: "'a Lst \<Rightarrow> 'a Lst \<Rightarrow> 'a Lst"
where
  "qrev Nil acc  = acc"
| "qrev (x;xs) acc = qrev xs (x;acc)"

hipster qrev rev
lemma lemma_ae [thy_expl]: "Demo.rev y +++ z = qrev y z"
  apply (induct y arbitrary: z)
  apply simp_all
  by (metis Demo.rev.simps(2) app.simps(1) lemma_aa lemma_ab lemma_ac)

theorem hardExercise: "rev xs = qrev xs Nil"
sledgehammer
  by (metis lemma_a lemma_ae)

(* The spine function: turns a list into a tree. *)
fun spine :: "'a Lst \<Rightarrow> 'a Tree"
where
  "spine Nil = Empty"
| "spine (x;xs) = Node x Empty (spine xs)"

hipster spine flatten
lemma lemma_af [thy_expl]: "flatten (spine y) = y"
  apply (induct y)
  by simp_all

(* Example: Histering a buggy rot function *)
fun rot :: "nat \<Rightarrow> 'a Lst \<Rightarrow> 'a Lst"
  where
    "rot 0 xs = xs"
  | "rot (Suc n) Nil = Nil"
  | "rot (Suc n) (x;xs) = rot n (xs+++(Cons x Nil))"
 (* | "rot (Suc n) (x;xs) = rot n xs+++(Cons x Nil)" <--- This is the buggy version*)

fun len :: "'a Lst \<Rightarrow> nat"
  where
    "len Nil = 0"
  | "len (x;xs) = Suc(len xs)"

hipster rot len

(* Properties discovered  for the buggy definition of rot. Note the first one, indicates that
  rotating around the length is reversing!

lemma lemma_ag [thy_expl]: "rot (len y) y = Demo.rev y"
apply (induct y)
apply simp
apply simp
done

lemma lemma_ah [thy_expl]: "rot (Suc (len y)) y = Demo.rev y"
apply (induct y)
apply simp
apply simp
done

lemma lemma_ai [thy_expl]: "rot (len z) (z +++ y) = y +++ Demo.rev z"
apply (induct z arbitrary: y)
apply simp
apply (simp add: lemma_a)
apply simp
using lemma_aa apply blast
done

lemma lemma_aj [thy_expl]: "rot (len (z +++ y)) z = Demo.rev z"
apply (induct z arbitrary: y)
apply simp
apply (metis rot.elims rot.simps(2))
apply simp
done

*)

end


section \<open>Specification\<close>

theory Goodstein_Lambda
  imports Main "Eval_Base.Eval_Base"
begin

subsection \<open>Hereditary base representation\<close>

text \<open>We define a data type of trees and an evaluation function that sums siblings and
  exponentiates with respect to the given base on nesting.\<close>

datatype C = C (unC: "C list")

fun evalC where
  "evalC b (C []) = 0"
| "evalC b (C (x # xs)) = b^evalC b x + evalC b (C xs)"

value "evalC 2 (C [])" \<comment> \<open>$0$\<close>
value "evalC 2 (C [C []])" \<comment> \<open>$2^0 = 1$\<close>
value "evalC 2 (C [C [C []]])" \<comment> \<open>$2^1 = 2$\<close>
value "evalC 2 (C [C [], C []])" \<comment> \<open>$2^0 + 2^0 = 2^0 \cdot 2 = 2$; not in hereditary base $2$\<close>

text \<open>The hereditary base representation is characterized as trees (i.e., nested lists) whose
  lists have monotonically increasing evaluations, with fewer than @{term "b"} repetitions for
  each value. We will show later that this representation is unique.\<close>

inductive_set hbase for b where
  "C [] \<in> hbase b"
| "i \<noteq> 0 \<Longrightarrow> i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow>
   C ms \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
   C (replicate i n @ ms) \<in> hbase b"

text \<open>We can convert to and from natural numbers as follows.\<close>

definition H2N where
  "H2N b n = evalC b n"

text \<open>As we will show later, @{term "H2N b"} restricted to @{term "hbase n"} is bijective
  if @{prop "b \<ge> (2 :: nat)"}, so we can convert from natural numbers by taking the inverse.\<close>

definition N2H where
  "N2H b n = inv_into (hbase b) (H2N b) n"

subsection \<open>The Goodstein function\<close>

text \<open>We define a function that computes the length of the Goodstein sequence whose $c$-th element
  is $g_c = n$. Termination will be shown later, thereby establishing Goodstein's theorem.\<close>

function (sequential) goodstein :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "goodstein 0 n = 0"
  \<comment> \<open>we start counting at 1; also note that the initial base is @{term "c+1 :: nat"} and\<close>
  \<comment> \<open>hereditary base 1 makes no sense, so we have to avoid this case\<close>
| "goodstein c 0 = c"
| "goodstein c n = goodstein (c+1) (H2N (c+2) (N2H (c+1) n) - 1)"
  by pat_completeness auto

abbreviation \<G> where
  "\<G> n \<equiv> goodstein (Suc 0) n"

section \<open>Ordinals\<close>

text \<open>The following type contains countable ordinals, by the usual case distinction into 0,
  successor ordinal, or limit ordinal; limit ordinals are given by their fundamental sequence.
  Hereditary base @{term "b"} representations carry over to such ordinals by replacing each
  occurrence of the base by @{term "\<omega>"}.\<close>

datatype Ord = Z | S Ord | L "nat \<Rightarrow> Ord"

text \<open>Note that the following arithmetic operations are not correct for all ordinals. However, they
  will only be used in cases where they actually correspond to the ordinal arithmetic operations.\<close>

primrec addO where
  "addO n Z = n"
| "addO n (S m) = S (addO n m)"
| "addO n (L f) = L (\<lambda>i. addO n (f i))"

primrec mulO where
  "mulO n Z = Z"
| "mulO n (S m) = addO (mulO n m) n"
| "mulO n (L f) = L (\<lambda>i. mulO n (f i))"

definition \<omega> where
  "\<omega> = L (\<lambda>n. (S ^^ n) Z)"

primrec exp\<omega> where
  "exp\<omega> Z = S Z"
| "exp\<omega> (S n) = mulO (exp\<omega> n) \<omega>"
| "exp\<omega> (L f) = L (\<lambda>i. exp\<omega> (f i))"

subsection \<open>Evaluation\<close>

text \<open>Evaluating an ordinal number at base $b$ is accomplished by taking the $b$-th element of
  all fundamental sequences and interpreting zero and successor over the natural numbers.\<close>

primrec evalO where
  "evalO b Z = 0"
| "evalO b (S n) = Suc (evalO b n)"
| "evalO b (L f) = evalO b (f b)"

subsection \<open>Goodstein function and sequence\<close>

text \<open>We can define the Goodstein function very easily, but proving correctness will take a while.\<close>

primrec goodsteinO where
  "goodsteinO c Z = c"
| "goodsteinO c (S n) = goodsteinO (c+1) n"
| "goodsteinO c (L f) = goodsteinO c (f (c+2))"

primrec stepO where
  "stepO c Z = Z"
| "stepO c (S n) = n"
| "stepO c (L f) = stepO c (f (c+2))"

text \<open>We can compute a few values of the Goodstein sequence starting at $4$.\<close>

definition g4O where
  "g4O n = fold stepO [1..<Suc n] ((exp\<omega> ^^ 3) Z)"

value "map (\<lambda>n. evalO (n+2) (g4O n)) [0..<10]"
\<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>

subsection \<open>Properties of evaluation\<close>

lemma evalO_addO [simp]:
  "evalO b (addO n m) = evalO b n + evalO b m"
  apply2 (induct m) by auto

lemma evalO_mulO [simp]:
  "evalO b (mulO n m) = evalO b n * evalO b m"
  apply2 (induct m) by auto

lemma evalO_n [simp]:
  "evalO b ((S ^^ n) Z) = n"
  apply2 (induct n) by auto

lemma evalO_\<omega> [simp]:
  "evalO b \<omega> = b"
  by (auto simp: \<omega>_def)

lemma evalO_exp\<omega> [simp]:
  "evalO b (exp\<omega> n) = b^(evalO b n)"
  apply2 (induct n) by auto

text \<open>Note that evaluation is useful for proving that @{type "Ord"} values are distinct:\<close>
notepad begin
  have "addO n (exp\<omega> m) \<noteq> n" for n m by (auto dest: arg_cong[of _ _ "evalO 1"])
end

subsection \<open>Arithmetic properties\<close>

lemma addO_Z [simp]:
  "addO Z n = n"
  apply2 (induct n) by auto

lemma addO_assoc [simp]:
  "addO n (addO m p) = addO (addO n m) p"
  apply2 (induct p) by auto

lemma mul0_distrib [simp]:
  "mulO n (addO p q) = addO (mulO n p) (mulO n q)"
  apply2 (induct q) by auto

lemma mulO_assoc [simp]:
  "mulO n (mulO m p) = mulO (mulO n m) p"
  apply2 (induct p) by auto

section \<open>Cantor normal form\<close>

text \<open>The previously introduced tree type @{type C} can be used to represent Cantor normal forms;
  they are trees (evaluated at base @{term \<omega>}) such that siblings are in non-decreasing order.
  One can think of this as hereditary base @{term \<omega>}. The plan is to mirror selected operations on
  ordinals in Cantor normal forms.\<close>

subsection \<open>Conversion to and from the ordinal type @{type Ord}\<close>

fun C2O where
  "C2O (C []) = Z"
| "C2O (C (n # ns)) = addO (C2O (C ns)) (exp\<omega> (C2O n))"

definition O2C where
  "O2C = inv C2O"

text \<open>We show that @{term C2O} is injective, meaning the inverse is unique.\<close>

lemma addO_exp\<omega>_inj:
  assumes "addO n (exp\<omega> m) = addO n' (exp\<omega> m')"
  shows "n = n'" and "m = m'"
proof -
  have "addO n (exp\<omega> m) = addO n' (exp\<omega> m') \<Longrightarrow> n = n'"
    apply2 (induct m arbitrary: m') by(case_tac m';
      force simp: \<omega>_def dest!: fun_cong[of _ _ 1])+
  moreover have "addO n (exp\<omega> m) = addO n (exp\<omega> m') \<Longrightarrow> m = m'"
    apply2 (induct m arbitrary: n m'; case_tac m')
    apply (auto 0 3 simp: \<omega>_def intro: rangeI
      dest: arg_cong[of _ _ "evalO 1"] fun_cong[of _ _ 0] fun_cong[of _ _ 1])[8] (* 1 left *)
    by simp (meson ext rangeI)
  ultimately show "n = n'" and "m = m'" using assms by simp_all
qed

lemma C2O_inj:
  "C2O n = C2O m \<Longrightarrow> n = m"
  apply2 (induct n arbitrary: m rule: C2O.induct; case_tac m rule: C2O.cases)
    by (auto dest: addO_exp\<omega>_inj arg_cong[of _ _ "evalO 1"])

lemma O2C_C2O [simp]:
  "O2C (C2O n) = n"
  by (auto intro!: inv_f_f simp: O2C_def inj_def C2O_inj)

lemma O2C_Z [simp]:
  "O2C Z = C []"
  using O2C_C2O[of "C []", unfolded C2O.simps] .

lemma C2O_replicate:
  "C2O (C (replicate i n)) = mulO (exp\<omega> (C2O n)) ((S ^^ i) Z)"
  apply2 (induct i) by auto

lemma C2O_app:
  "C2O (C (xs @ ys)) = addO (C2O (C ys)) (C2O (C xs))"
  apply2 (induct xs arbitrary: ys) by auto

subsection \<open>Evaluation\<close>

lemma evalC_def':
  "evalC b n = evalO b (C2O n)"
  apply2 (induct n rule: C2O.induct) by auto

lemma evalC_app [simp]:
  "evalC b (C (ns @ ms)) = evalC b (C ns) + evalC b (C ms)"
  apply2 (induct ns) by auto

lemma evalC_replicate [simp]:
  "evalC b (C (replicate c n)) = c * evalC b (C [n])"
  apply2 (induct c) by auto

subsection \<open>Transfer of the @{type Ord} induction principle to @{type C}\<close>

fun funC where \<comment> \<open>@{term funC} computes the fundamental sequence on @{type C}\<close>
  "funC (C []) = (\<lambda>i. [C []])"
| "funC (C (C [] # ns)) = (\<lambda>i. replicate i (C ns))"
| "funC (C (n # ns)) = (\<lambda>i. [C (funC n i @ ns)])"

lemma C2O_cons:
  "C2O (C (n # ns)) =
    (if n = C [] then S (C2O (C ns)) else L (\<lambda>i. C2O (C (funC n i @ ns))))"
  apply2 (induct n arbitrary: ns rule: funC.induct)
  by (simp_all add: \<omega>_def C2O_replicate C2O_app flip: exp\<omega>_addO)

lemma C_Ord_induct:
  assumes "P (C [])"
  and "\<And>ns. P (C ns) \<Longrightarrow> P (C (C [] # ns))"
  and "\<And>n ns ms. (\<And>i. P (C (funC (C (n # ns)) i @ ms))) \<Longrightarrow>
    P (C (C (n # ns) # ms))"
  shows "P n"
proof -
  have "\<forall>n. C2O n = m \<longrightarrow> P n" for m
    apply2 (induct m; intro allI; case_tac n rule: funC.cases)
  by (auto simp: C2O_cons simp del: C2O.simps(2) intro: assms)
  then show ?thesis by simp
qed

subsection \<open>Goodstein function and sequence on @{type C}\<close>

function (domintros) goodsteinC where
  "goodsteinC c (C []) = c"
| "goodsteinC c (C (C [] # ns)) = goodsteinC (c+1) (C ns)"
| "goodsteinC c (C (C (n # ns) # ms)) =
    goodsteinC c (C (funC (C (n # ns)) (c+2) @ ms))"
  by pat_completeness auto

termination
proof -
  have "goodsteinC_dom (c, n)" for c n
    apply2 (induct n arbitrary: c rule: C_Ord_induct) by(auto intro: goodsteinC.domintros)
  then show ?thesis by simp
qed

lemma goodsteinC_def':
  "goodsteinC c n = goodsteinO c (C2O n)"
  apply2 (induct c n rule: goodsteinC.induct) by(simp_all add: C2O_cons del: C2O.simps(2))

function (domintros) stepC where
  "stepC c (C []) = C []"
| "stepC c (C (C [] # ns)) = C ns"
| "stepC c (C (C (n # ns) # ms)) =
    stepC c (C (funC (C (n # ns)) (Suc (Suc c)) @ ms))"
  by pat_completeness auto

termination
proof -
  have "stepC_dom (c, n)" for c n
    apply2 (induct n arbitrary: c rule: C_Ord_induct) by(auto intro: stepC.domintros)
  then show ?thesis by simp
qed

definition g4C where
  "g4C n = fold stepC [1..<Suc n] (C [C [C [C []]]])"

value "map (\<lambda>n. evalC (n+2) (g4C n)) [0..<10]"
\<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>

subsection \<open>Properties\<close>

lemma stepC_def':
  "stepC c n = O2C (stepO c (C2O n))"
  apply2 (induct c n rule: stepC.induct) by(simp_all add: C2O_cons del: C2O.simps(2))

lemma funC_ne [simp]:
  "funC m (Suc n) \<noteq> []"
  by (cases m rule: funC.cases) simp_all

lemma evalC_funC [simp]:
  "evalC b (C (funC n b)) = evalC b (C [n])"
  apply2 (induct n rule: funC.induct) by simp_all

lemma stepC_app [simp]:
  "n \<noteq> C [] \<Longrightarrow> stepC c (C (unC n @ ns)) = C (unC (stepC c n) @ ns)"
  apply2 (induct n arbitrary: ns rule: stepC.induct) by simp_all

lemma stepC_cons [simp]:
  "ns \<noteq> [] \<Longrightarrow> stepC c (C (n # ns)) = C (unC (stepC c (C [n])) @ ns)"
  using stepC_app[of "C[n]" c ns] by simp

lemma stepC_dec:
  "n \<noteq> C [] \<Longrightarrow> Suc (evalC (Suc (Suc c)) (stepC c n)) = evalC (Suc (Suc c)) n"
  apply2 (induct c n rule: stepC.induct) by simp_all

lemma stepC_dec':
  "n \<noteq> C [] \<Longrightarrow> evalC (c+3) (stepC c n) < evalC (c+3) n"
proof2 (induct c n rule: stepC.induct)
  case (3 c n ns ms)
  have "evalC (c+3) (C (funC (C (n # ns)) (Suc (Suc c)))) \<le>
      (c+3) ^ ((c+3) ^ evalC (c+3) n + evalC (c+3) (C ns))"
    apply2 (induct n rule: funC.induct) by(simp_all add: distrib_right)
  then show ?case using 3 by simp
qed simp_all

section \<open>Hereditary base @{term b} representation\<close>

text \<open>We now turn to properties of the @{term "hbase b"} subset of trees.\<close>

subsection \<open>Uniqueness\<close>

text \<open>We show uniqueness of the hereditary base representation by showing that @{term "evalC b"}
  restricted to @{term "hbase b"} is injective.\<close>

lemma hbaseI2:
  "i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow> C m \<in> hbase b \<Longrightarrow>
    (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
    C (replicate i n @ m) \<in> hbase b"
  by (cases i) (auto intro: hbase.intros simp del: replicate.simps(2))

lemmas hbase_singletonI =
  hbase.intros(2)[of 1 "Suc (Suc b)" for b, OF _ _ _ hbase.intros(1), simplified]

lemma hbase_hd:
  "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> hd ns \<in> hbase b"
  by (cases rule: hbase.cases) auto

lemmas hbase_hd' [dest] = hbase_hd[of "n # ns" for n ns, simplified]

lemma hbase_tl:
  "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
  by (cases "C ns" b rule: hbase.cases) (auto intro: hbaseI2)

lemmas hbase_tl' [dest] = hbase_tl[of "n # ns" for n ns, simplified]

lemma hbase_elt [dest]:
  "C ns \<in> hbase b \<Longrightarrow> n \<in> set ns \<Longrightarrow> n \<in> hbase b"
  apply2 (induct ns) by auto

lemma evalC_sum_list:
  "evalC b (C ns) = sum_list (map (\<lambda>n. b^evalC b n) ns)"
  apply2 (induct ns) by auto

lemma sum_list_replicate:
  "sum_list (replicate n x) = n * x"
  apply2 (induct n) by auto

lemma base_red:
  fixes b :: nat
  assumes n: "\<And>n'. n' \<in> set ns \<Longrightarrow> n < n'" "i < b" "i \<noteq> 0"
  and m: "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
  and s: "i * b^n + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
  shows "i = j \<and> n = m"
  using n(1) m(1) s
proof2 (induct n arbitrary: m ns ms)
  { fix ns ms :: "nat list" and i j m :: nat
    assume n': "\<And>n'. n' \<in> set ns \<Longrightarrow> 0 < n'" "i < b" "i \<noteq> 0"
    assume m': "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
    assume s': "i * b^0 + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
    obtain x where [simp]: "sum_list (map ((^) b) ns) = x*b"
      using n'(1)
      by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ns)"])
        (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
    obtain y where [simp]: "sum_list (map ((^) b) ms) = y*b"
      using order.strict_trans1[OF le0 m'(1)]
      by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ms)"])
        (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
    have [simp]: "m = 0"
      using s' n'(2,3)
      by (cases m, simp_all)
        (metis Groups.mult_ac(2) Groups.mult_ac(3) Suc_pred div_less mod_div_mult_eq
          mod_mult_self2 mod_mult_self2_is_0 mult_zero_right nat.simps(3))
    have "i = j \<and> 0 = m" using s' n'(2,3) m'(2,3)
      by simp (metis div_less mod_div_mult_eq mod_mult_self1)
  } note BASE = this
  {
    case 0 show ?case by (rule BASE; fact)
  next
    case (Suc n m')
    have "j = i \<and> 0 = Suc n" if "m' = 0" using Suc(2-4)
      by (intro BASE[of ms j ns "Suc n" i]) (simp_all add: ac_simps that n(2,3) m(2,3))
    then obtain m where m' [simp]: "m' = Suc m"
      by (cases m') auto
    obtain ns' where [simp]: "ns = map Suc ns'" "\<And>n'. n' \<in> set ns' \<Longrightarrow> n < n'"
      using Suc(2) less_trans[OF zero_less_Suc Suc(2)]
      by (intro that[of "map (\<lambda>n. n-1) ns"]; force cong: map_cong)
    obtain ms' where [simp]: "ms = map Suc ms'" "\<And>m'. m' \<in> set ms' \<Longrightarrow> m < m'"
      using Suc(3)[unfolded m'] less_trans[OF zero_less_Suc Suc(3)[unfolded m']]
      by (intro that[of "map (\<lambda>n. n-1) ms"]; force cong: map_cong)
    have *: "b * x = b * y \<Longrightarrow> x = y" for x y using n(2) by simp
    have "i = j \<and> n = m"
    proof (rule Suc(1)[of "map (\<lambda>n. n-1) ns" "map (\<lambda>n. n-1) ms" m, OF _ _ *], goal_cases)
      case 3 show ?case using Suc(4) unfolding add_mult_distrib2
        by (simp add: comp_def ac_simps flip: sum_list_const_mult)
    qed simp_all
    then show ?case by simp
  }
qed

lemma evalC_inj_on_hbase:
  "n \<in> hbase b \<Longrightarrow> m \<in> hbase b \<Longrightarrow> evalC b n = evalC b m \<Longrightarrow> n = m"
proof2 (induct n arbitrary: m rule: hbase.induct)
  case 1
  then show ?case by (cases m rule: hbase.cases) simp_all
next
  case (2 i n ns m')
  obtain j m ms where [simp]: "m' = C (replicate j m @ ms)" and
    m: "j \<noteq> 0" "j < b" "m \<in> hbase b" "C ms \<in> hbase b" "\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b m < evalC b m'"
    using 2(8,1,2,9) by (cases m' rule: hbase.cases) simp_all
  have "i = j \<and> evalC b n = evalC b m" using 2(1,2,7,9) m(1,2,5)
    by (intro base_red[of "map (evalC b) ns" _ _ b "map (evalC b) ms"])
      (auto simp: comp_def evalC_sum_list sum_list_replicate)
  then show ?case
    using 2(4)[OF m(3)] 2(6)[OF m(4)] 2(9) by simp
qed

subsection \<open>Correctness of @{const stepC}\<close>

text \<open>We show that @{term "stepC c"} preserves hereditary base @{term "c + 2 :: nat"}
  representations. In order to cover intermediate results produced by @{const stepC}, we extend
  the hereditary base representation to allow the least significant digit to be equal to @{term b},
  which essentially means that we may have an extra sibling in front on every level.\<close>

inductive_set hbase_ext for b where
  "n \<in> hbase b \<Longrightarrow> n \<in> hbase_ext b"
| "n \<in> hbase_ext b \<Longrightarrow>
   C m \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n \<le> evalC b m') \<Longrightarrow>
   C (n # m) \<in> hbase_ext b"

lemma hbase_ext_hd' [dest]:
  "C (n # ns) \<in> hbase_ext b \<Longrightarrow> n \<in> hbase_ext b"
  by (cases rule: hbase_ext.cases) (auto intro: hbase_ext.intros(1))

lemma hbase_ext_tl:
  "C ns \<in> hbase_ext b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
  by (cases "C ns" b rule: hbase_ext.cases; cases ns) (simp_all add: hbase_tl')

lemmas hbase_ext_tl' [dest] = hbase_ext_tl[of "n # ns" for n ns, simplified]

lemma hbase_funC:
  "c \<noteq> 0 \<Longrightarrow> C (n # ns) \<in> hbase_ext (Suc c) \<Longrightarrow>
    C (funC n (Suc c) @ ns) \<in> hbase_ext (Suc c)"
proof2 (induct n arbitrary: ns rule: funC.induct)
  case (2 ms)
  have [simp]: "evalC (Suc c) (C ms) < evalC (Suc c) m'" if "m' \<in> set ns" for m'
    using 2(2)
  proof (cases rule: hbase_ext.cases)
    case 1 then show ?thesis using that
      by (cases rule: hbase.cases, case_tac i) (auto intro: Suc_lessD)
  qed (auto simp: Suc_le_eq that)
  show ?case using 2
    by (auto 0 4 intro: hbase_ext.intros hbase.intros(2) order.strict_implies_order)
next
  case (3 m ms ms')
  show ?case
    unfolding funC.simps append_Cons append_Nil
  proof (rule hbase_ext.intros(2), goal_cases 31 32 33)
    case (33 m')
    show ?case using 3(3)
    proof (cases rule: hbase_ext.cases)
      case 1 show ?thesis using 1 3(1,2) 33
        by (cases rule: hbase.cases, case_tac i) (auto intro: less_or_eq_imp_le)
    qed (insert 33, simp)
  qed (insert 3, blast+)
qed auto

lemma stepC_sound:
  "n \<in> hbase_ext (Suc (Suc c)) \<Longrightarrow> stepC c n \<in> hbase (Suc (Suc c))"
proof2 (induct c n rule: stepC.induct)
  case (3 c n ns ms)
  show ?case using 3(2,1)
    by (cases rule: hbase_ext.cases; unfold stepC.simps) (auto intro: hbase_funC)
qed (auto intro: hbase.intros)

subsection \<open>Surjectivity of @{const evalC}\<close>

text \<open>Note that the base must be at least @{term "2 :: nat"}.\<close>

lemma evalC_surjective:
  "\<exists>n' \<in> hbase (Suc (Suc b)). evalC (Suc (Suc b)) n' = n"
proof2 (induct n)
  case 0 then show ?case by (auto intro: bexI[of _ "C []"] hbase.intros)
next
  have [simp]: "Suc x \<le> Suc (Suc b)^x" for x apply2 (induct x) by auto
  case (Suc n)
  then guess n' by (rule bexE)
  then obtain n' j where n': "Suc n \<le> j" "j = evalC (Suc (Suc b)) n'" "n' \<in> hbase (Suc (Suc b))"
    by (intro that[of _ "C [n']"])
      (auto intro!: intro: hbase.intros(1) dest!: hbaseI2[of 1 "b+2" n' "[]", simplified])
  then show ?case
  proof2 (induct rule: inc_induct)
    case (step m)
    guess n' using step(3)[OF step(4,5)] by (rule bexE)
    then show ?case using stepC_dec[of n' "b"]
      by (cases n' rule: C2O.cases) (auto intro: stepC_sound hbase_ext.intros(1))
  qed blast
qed

subsection \<open>Monotonicity of @{const hbase}\<close>

text \<open>Here we show that every hereditary base @{term "b :: nat"} number is also a valid hereditary
  base @{term "b+1 :: nat"} number. This is not immediate because we have to show that monotonicity
  of siblings is preserved.\<close>

lemma hbase_evalC_mono:
  assumes "n \<in> hbase b" "m \<in> hbase b" "evalC b n < evalC b m"
  shows "evalC (Suc b) n < evalC (Suc b) m"
proof (cases "b < 2")
  case True show ?thesis using assms(2,3) True by (cases rule: hbase.cases) simp_all
next
  case False
  then obtain b' where [simp]: "b = Suc (Suc b')"
    by (auto simp: numeral_2_eq_2 not_less_eq dest: less_imp_Suc_add)
  show ?thesis using assms(3,1,2)
  proof2 (induct "evalC b n" "evalC b m" arbitrary: n m rule: less_Suc_induct)
    case 1 then show ?case using stepC_sound[of m b', OF hbase_ext.intros(1)]
      stepC_dec[of m b'] stepC_dec'[of m b'] evalC_inj_on_hbase
      by (cases m rule: C2O.cases) (fastforce simp: eval_nat_numeral)+
  next
    case (2 j) then show ?case
      using evalC_surjective[of b' j] less_trans by fastforce
  qed
qed

lemma hbase_mono:
  "n \<in> hbase b \<Longrightarrow> n \<in> hbase (Suc b)"
  apply2 (induct n rule: hbase.induct) by(auto 0 3 intro: hbase.intros hbase_evalC_mono)

subsection \<open>Conversion to and from @{type nat}\<close>

text \<open>We have previously defined @{term "H2N b = evalC b"} and @{term "N2H b"} as its inverse.
  So we can use the injectivity and surjectivity of @{term "evalC b"} for simplification.\<close>

lemma N2H_inv:
  "n \<in> hbase b \<Longrightarrow> N2H b (H2N b n) = n"
  using evalC_inj_on_hbase
  by (auto simp: N2H_def H2N_def[abs_def] inj_on_def intro!: inv_into_f_f)

lemma N2H_eqI:
  "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
   H2N (Suc (Suc b)) n = m \<Longrightarrow> N2H (Suc (Suc b)) m = n"
  using N2H_inv by blast

lemma N2H_neI:
  "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
   H2N (Suc (Suc b)) n \<noteq> m \<Longrightarrow> N2H (Suc (Suc b)) m \<noteq> n"
  using H2N_inv by blast

lemma N2H_0 [simp]:
  "N2H (Suc (Suc c)) 0 = C []"
  using H2N_def N2H_inv hbase.intros(1) by fastforce

lemma N2H_nz [simp]:
  "0 < n \<Longrightarrow> N2H (Suc (Suc c)) n \<noteq> C []"
  by (metis N2H_0 H2N_inv neq0_conv)

section \<open>The Goodstein function revisited\<close>

text \<open>We are now ready to prove termination of the Goodstein function @{const goodstein} as well
  as its relation to @{const goodsteinC} and @{const goodsteinO}.\<close>

lemma goodstein_aux:
  "goodsteinC (Suc c) (N2H (Suc (Suc c)) (Suc n)) =
    goodsteinC (c+2) (N2H (c+3) (H2N (c+3) (N2H (c+2) (n+1)) - 1))"
proof -
  have [simp]: "n \<noteq> C [] \<Longrightarrow> goodsteinC c n = goodsteinC (c+1) (stepC c n)" for c n
    apply2 (induct c n rule: stepC.induct) by simp_all
  have [simp]: "stepC (Suc c) (N2H (Suc (Suc c)) (Suc n)) \<in> hbase (Suc (Suc (Suc c)))"
    by (metis H2N_def N2H_inv evalC_surjective hbase_ext.intros(1) hbase_mono stepC_sound)
  show ?thesis
    using arg_cong[OF stepC_dec[of "N2H (c+2) (n+1)" "c+1", folded H2N_def], of "\<lambda>n. N2H (c+3) (n-1)"]
    by (simp add: eval_nat_numeral N2H_inv)
qed

termination goodstein
proof (relation "measure (\<lambda>(c, n). goodsteinC c (N2H (c+1) n) - c)", goal_cases _ 1)
  case (1 c n)
  have *: "goodsteinC c n \<ge> c" for c n
    apply2 (induct c n rule: goodsteinC.induct) by simp_all
  show ?case by (simp add: goodstein_aux eval_nat_numeral) (meson Suc_le_eq diff_less_mono2 lessI *)
qed simp

lemma goodstein_def':
  "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinC c (N2H (c+1) n)"
  apply2 (induct c n rule: goodstein.induct) by(simp_all add: goodstein_aux eval_nat_numeral)

lemma goodstein_impl:
  "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinO c (C2O (N2H (c+1) n))"
  \<comment> \<open>but note that @{term N2H} is not executable as currently defined\<close>
  using goodstein_def'[unfolded goodsteinC_def'] .

lemma goodstein_16:
  "\<G> 16 = goodsteinO 1 (exp\<omega> (exp\<omega> (exp\<omega> (exp\<omega> Z))))"
proof -
  have "N2H (Suc (Suc 0)) 16 = C [C [C [C [C []]]]]"
    by (auto simp: H2N_def intro!: N2H_eqI hbase_singletonI hbase.intros(1))
  then show ?thesis by (simp add: goodstein_impl)
qed

section \<open>Translation to $\lambda$-calculus\<close>

text \<open>We define Church encodings for @{type nat} and @{type Ord}. Note that we are basically in a
  Hindley-Milner type system, so we cannot use a proper polymorphic type. We can still express
  Church encodings as folds over values of the original type.\<close>

abbreviation Z\<^sub>N where "Z\<^sub>N \<equiv> (\<lambda>s z. z)"
abbreviation S\<^sub>N where "S\<^sub>N \<equiv> (\<lambda>n s z. s (n s z))"

primrec fold_nat ("\<langle>_\<rangle>\<^sub>N") where
  "\<langle>0\<rangle>\<^sub>N = Z\<^sub>N"
| "\<langle>Suc n\<rangle>\<^sub>N = S\<^sub>N \<langle>n\<rangle>\<^sub>N"

lemma one\<^sub>N:
  "\<langle>1\<rangle>\<^sub>N = (\<lambda>x. x)"
  by simp

abbreviation Z\<^sub>O where "Z\<^sub>O \<equiv> (\<lambda>z s l. z)"
abbreviation S\<^sub>O where "S\<^sub>O \<equiv> (\<lambda>n z s l. s (n z s l))"
abbreviation L\<^sub>O where "L\<^sub>O \<equiv> (\<lambda>f z s l. l (\<lambda>i. f i z s l))"

primrec fold_Ord ("\<langle>_\<rangle>\<^sub>O") where
  "\<langle>Z\<rangle>\<^sub>O = Z\<^sub>O"
| "\<langle>S n\<rangle>\<^sub>O = S\<^sub>O \<langle>n\<rangle>\<^sub>O"
| "\<langle>L f\<rangle>\<^sub>O = L\<^sub>O (\<lambda>i. \<langle>f i\<rangle>\<^sub>O)"

text \<open>The following abbreviations and lemmas show how to implement the arithmetic functions and
  the Goodstein function on a Church-encoded @{type Ord} in lambda calculus.\<close>

abbreviation (input) add\<^sub>O where
  "add\<^sub>O n m \<equiv> (\<lambda>z s l. m (n z s l) s l)"

lemma add\<^sub>O:
  "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
  apply2 (induct m) by simp_all

abbreviation (input) mul\<^sub>O where
  "mul\<^sub>O n m \<equiv> (\<lambda>z s l. m z (\<lambda>m. n m s l) l)"

lemma mul\<^sub>O:
  "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
  apply2 (induct m) by(simp_all add: add\<^sub>O)

abbreviation (input) \<omega>\<^sub>O where
  "\<omega>\<^sub>O \<equiv> (\<lambda>z s l. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N s z))"

lemma \<omega>\<^sub>O:
  "\<langle>\<omega>\<rangle>\<^sub>O = \<omega>\<^sub>O"
proof -
  have [simp]: "\<langle>(S ^^ i) Z\<rangle>\<^sub>O z s l = \<langle>i\<rangle>\<^sub>N s z" for i z s l apply2 (induct i) by simp_all
  show ?thesis by (simp add: \<omega>_def)
qed

abbreviation (input) exp\<omega>\<^sub>O where
  "exp\<omega>\<^sub>O n \<equiv> (\<lambda>z s l. n s (\<lambda>x z. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N x z)) (\<lambda>f z. l (\<lambda>n. f n z)) z)"

lemma exp\<omega>\<^sub>O:
  "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
  apply2 (induct n) by (simp_all add: mul\<^sub>O \<omega>\<^sub>O)

abbreviation (input) goodstein\<^sub>O where
  "goodstein\<^sub>O \<equiv> (\<lambda>c n. n (\<lambda>x. x) (\<lambda>n m. n (m + 1)) (\<lambda>f m. f (m + 2) m) c)"

lemma goodstein\<^sub>O:
  "goodsteinO c n = goodstein\<^sub>O c \<langle>n\<rangle>\<^sub>O"
  apply2 (induct n arbitrary: c) by simp_all

text \<open>Note that modeling Church encodings with folds is still limited. For example, the meaningful
  expression @{text "\<langle>n\<rangle>\<^sub>N exp\<omega>\<^sub>O Z\<^sub>O"} cannot be typed in Isabelle/HOL, as that would require rank-2
  polymorphism.\<close>

subsection \<open>Alternative: free theorems\<close>

text \<open>The following is essentially the free theorem for Church-encoded @{type Ord} values.\<close>

lemma freeOrd:
  assumes "\<And>n. h (s n) = s' (h n)" and "\<And>f. h (l f) = l' (\<lambda>i. h (f i))"
  shows "h (\<langle>n\<rangle>\<^sub>O z s l) = \<langle>n\<rangle>\<^sub>O (h z) s' l'"
  apply2 (induct n) by(simp_all add: assms)

text \<open>Each of the following proofs first states a naive definition of the corresponding function
  (which is proved correct by induction), from which we then derive the optimized version using
  the free theorem, by (conditional) rewriting (without induction).\<close>

lemma add\<^sub>O':
  "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>addO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O \<langle>n\<rangle>\<^sub>O S\<^sub>O L\<^sub>O"
    apply2 (induct m) by simp_all
  show ?thesis
    by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
qed

lemma mul\<^sub>O':
  "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>mulO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O Z\<^sub>O (\<lambda>m. add\<^sub>O m \<langle>n\<rangle>\<^sub>O) L\<^sub>O"
    apply2 (induct m) by(simp_all add: add\<^sub>O)
  show ?thesis
    by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
qed

lemma exp\<omega>\<^sub>O':
  "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>exp\<omega> n\<rangle>\<^sub>O = \<langle>n\<rangle>\<^sub>O (S\<^sub>O Z\<^sub>O) (\<lambda>m. mul\<^sub>O m \<omega>\<^sub>O) L\<^sub>O"
    apply2 (induct n) by(simp_all add: mul\<^sub>O \<omega>\<^sub>O)
  show ?thesis
    by (intro ext) (simp add: fun_cong[OF freeOrd[where h = "\<lambda>n z. n z _ _"]])
qed

end