theory P09
  imports Main
begin

function  p09_1  :: "'a list \<Rightarrow> ('a list) list" where
"p09_1 [] = []"|
"p09_1 (a#xs) = (a #takeWhile (op = a) xs )# p09_1 (dropWhile (op = a) xs)"  by pat_completeness auto
termination
  apply (relation "measure (\<lambda> ls . length ls)")
   apply simp
  apply auto
  apply (induct_tac xs)
   apply simp
  apply auto
  done

lemma "(p09_1 [1,2,3::nat]) = [[1],[2],[3::nat]]" by simp

lemma "p09_1 [1,2,1,1,3,2,2,5,5,5::nat] = [[1],[2],[1,1],[3],[2,2],[5,5,5]] " by simp

lemma helper:"length (dropWhile (op = a) xs) \<le> length xs"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons aa xs)
  then show ?case by (cases "a = aa" ; auto)
qed

theorem "length (p09_1 ls) \<le> length ls"
proof (induction ls rule : p09_1.induct)
  case 1
  then show ?case by simp
next
  case (2 a xs)
  then show ?case using helper[of a xs] by simp
qed

theorem "ls =  concat (p09_1 ls)"
proof (induction ls rule : p09_1.induct)
  case 1
  then show ?case by simp
next
  case (2 a xs)
  assume hyp:"dropWhile (op = a) xs = concat (p09_1 (dropWhile (op = a) xs))"
  from hyp show ?case by simp
qed

lemma helper2:"i \<in> set (takeWhile (op = a) xs) \<Longrightarrow> i = a"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons aa xs)
  then show ?case by (cases "a = aa"; auto)
qed

theorem "i \<in> set (p09_1 ls) \<Longrightarrow> (\<forall>x y . x \<in> set i \<and> y \<in> set i \<longrightarrow> x = y)"
proof (induction ls rule : p09_1.induct)
  case 1
  then show ?case by simp
next
  case (2 a xs)
  let ?tmp = "takeWhile (op = a) xs"
  let ?tmp2 = "dropWhile (op = a) xs"
  have "(i \<in> set (p09_1 (a # xs))) = (i \<in> set  ((a # ?tmp) # p09_1 ?tmp2))" by simp
  also have "\<dots> = ((i \<in> set ([a#?tmp])) \<or> (i \<in> set (p09_1 ?tmp2)))" by simp
  finally have tmp:"(i \<in> set (p09_1 (a # xs))) = (i \<in> set [a # ?tmp] \<or> i \<in> set (p09_1 ?tmp2)) " by simp
  show ?case
  proof (cases "i \<in> set ([a#?tmp])")
    case True
    then show ?thesis using helper2[of _ a _] by auto
  next
    case False
    with 2(2) tmp have tmp2:"i \<in> set (p09_1 ?tmp2)" by simp
    with 2(1) show ?thesis by simp
  qed
qed

theorem "length ls = sum_list (map length (p09_1 ls))"
proof (induction ls rule : p09_1.induct)
  case 1
  then show ?case by simp
next
  case (2 a xs)
  let ?tmp="takeWhile (op = a) xs"
  let ?tmp2="dropWhile (op = a) xs"
  have "sum_list (map length (p09_1 (a # xs))) = sum_list (length (a#?tmp) # map length (p09_1  ?tmp2))" by simp
  also have "\<dots> = length (a#?tmp) + sum_list (map length (p09_1 ?tmp2))" by simp
  also have "\<dots> = 1 + length (?tmp) + length (dropWhile (op = a) xs)" using 2 by simp
  also have "\<dots> = 1 + length xs" using takeWhile_dropWhile_id[of "op = a" xs] length_append[symmetric , of ?tmp ?tmp2] by simp
  finally show ?case by simp
qed


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Omega\<close>

theory OrdinalOmega
imports OrdinalFix
begin

subsection \<open>Embedding naturals in the ordinals\<close>

primrec ordinal_of_nat :: "nat \<Rightarrow> ordinal"
where
  "ordinal_of_nat 0 = 0"
| "ordinal_of_nat (Suc n) = oSuc (ordinal_of_nat n)"

lemma strict_mono_ordinal_of_nat: "strict_mono ordinal_of_nat"
  by (simp add: strict_mono_natI)

lemma not_limit_ordinal_nat: "\<not> limit_ordinal (ordinal_of_nat n)"
  by (induct n) simp_all

lemma ordinal_of_nat_eq [simp]:
  "(ordinal_of_nat x = ordinal_of_nat y) = (x = y)"
  by (rule strict_mono_cancel_eq[OF strict_mono_ordinal_of_nat])

lemma ordinal_of_nat_less [simp]:
  "(ordinal_of_nat x < ordinal_of_nat y) = (x < y)"
  by (rule strict_mono_cancel_less[OF strict_mono_ordinal_of_nat])

lemma ordinal_of_nat_le [simp]:
  "(ordinal_of_nat x \<le> ordinal_of_nat y) = (x \<le> y)"
  by (rule strict_mono_cancel_le[OF strict_mono_ordinal_of_nat])

lemma ordinal_of_nat_plus [simp]:
  "ordinal_of_nat x + ordinal_of_nat y = ordinal_of_nat (x + y)"
  by (induct y) simp_all

lemma ordinal_of_nat_times [simp]:
  "ordinal_of_nat x * ordinal_of_nat y = ordinal_of_nat (x * y)"
  by (induct y) (simp_all add: add.commute)

lemma ordinal_of_nat_exp [simp]:
  "ordinal_of_nat x ** ordinal_of_nat y = ordinal_of_nat (x ^ y)"
  by (induct y, cases x) (simp_all add: mult.commute)

lemma oSuc_plus_ordinal_of_nat:
  "oSuc x + ordinal_of_nat n = oSuc (x + ordinal_of_nat n)"
  by (induct n) simp_all

lemma less_ordinal_of_nat:
  "(x < ordinal_of_nat n) = (\<exists>m. x = ordinal_of_nat m \<and> m < n)"
  by (induction n) (use less_oSuc_eq_le in force)+

lemma le_ordinal_of_nat:
  "(x \<le> ordinal_of_nat n) = (\<exists>m. x = ordinal_of_nat m \<and> m \<le> n)"
  by (auto simp add: order_le_less less_ordinal_of_nat)

subsection \<open>Omega, the least limit ordinal\<close>

definition
  omega :: "ordinal"  ("\<omega>") where
  "omega = oLimit ordinal_of_nat"

lemma less_omegaD: "x < \<omega> \<Longrightarrow> \<exists>n. x = ordinal_of_nat n"
  by (metis less_oLimitD less_ordinal_of_nat omega_def)

lemma omega_leI: "\<forall>n. ordinal_of_nat n \<le> x \<Longrightarrow> \<omega> \<le> x"
  by (simp add: oLimit_leI omega_def)

lemma nat_le_omega [simp]: "ordinal_of_nat n \<le> \<omega>"
  by (simp add: oLimit_leI omega_def)

lemma nat_less_omega [simp]: "ordinal_of_nat n < \<omega>"
  by (simp add: omega_def strict_mono_less_oLimit strict_mono_ordinal_of_nat)

lemma zero_less_omega [simp]: "0 < \<omega>"
  using nat_less_omega ordinal_neq_0 by fastforce

lemma limit_ordinal_omega: "limit_ordinal \<omega>"
  by (metis limit_ordinal_oLimitI nat_less_omega omega_def)

lemma Least_limit_ordinal: "(LEAST x. limit_ordinal x) = \<omega>"
proof (rule Least_equality)
  show "\<And>y. limit_ordinal y \<Longrightarrow> \<omega> \<le> y"
    by (metis leI less_omegaD not_limit_ordinal_nat)
qed (rule limit_ordinal_omega)

lemma "range f = range ordinal_of_nat \<Longrightarrow> oLimit f = \<omega>"
  by (metis le_oLimit oLimit_leI omega_def order_antisym rangeE rangeI)

subsection \<open>Arithmetic properties of @{term \<omega>}\<close>

lemma oSuc_less_omega [simp]: "(oSuc x < \<omega>) = (x < \<omega>)"
  by (rule oSuc_less_limit_ordinal[OF limit_ordinal_omega])

lemma oSuc_plus_omega [simp]: "oSuc x + \<omega> = x + \<omega>"
proof -
  have "\<And>n. \<exists>m. oSuc x + ordinal_of_nat n \<le> x + ordinal_of_nat m"
    using oSuc_le_eq_less oSuc_plus_ordinal_of_nat by auto
  moreover
  have "\<And>n. \<exists>m. x + ordinal_of_nat n \<le> oSuc x + ordinal_of_nat m"
    using dual_order.order_iff_strict oSuc_plus_ordinal_of_nat by auto
  ultimately show ?thesis
    by (simp add: oLimit_eqI omega_def)
qed

lemma ordinal_of_nat_plus_omega [simp]:
  "ordinal_of_nat n + \<omega> = \<omega>"
  by (induct n) simp_all

lemma ordinal_of_nat_times_omega [simp]:
  assumes "k > 0" shows "ordinal_of_nat k * \<omega> = \<omega>"
proof -
  have "\<exists>m. ordinal_of_nat n \<le> ordinal_of_nat (k * m)"
    by (metis assms le_add1 mult_eq_if not_less_zero ordinal_of_nat_le)
  then have "oLimit (\<lambda>n. ordinal_of_nat (k * n)) = oLimit ordinal_of_nat"
    by (metis assms oLimit_eqI gr0_conv_Suc le_add1 mult_Suc ordinal_of_nat_le)
  then show ?thesis
    by (simp add: omega_def)
qed

lemma ordinal_plus_times_omega: "x + x * \<omega> = x * \<omega>"
  by (metis oSuc_plus_omega ordinal_0_plus ordinal_times_1 ordinal_times_distrib)

lemma ordinal_plus_absorb: "x * \<omega> \<le> y \<Longrightarrow> x + y = y"
  by (metis ordinal_plus_assoc ordinal_plus_minus2 ordinal_plus_times_omega)

lemma ordinal_less_plusL:
  assumes "y < x * \<omega>" shows "y < x + y"
proof (cases "x = 0")
  case True
  with assms show ?thesis by auto
next
  case False
  then obtain n where n: "ordinal_of_nat n = y div x"
    using assms less_omegaD ordinal_div_less by metis
  then have "y < x * (1 + ordinal_of_nat n)"
    using n unfolding ordinal_one_def oSuc_plus_ordinal_of_nat
    by (metis False ordinal_0_plus ordinal_less_times_div_plus ordinal_neq_0 ordinal_times_oSuc)
  also have "... \<le> x + y"
    using n by (simp add: ordinal_times_distrib ordinal_times_div_le)
  finally show ?thesis .
qed

lemma ordinal_plus_absorb_iff: "(x + y = y) = (x * \<omega> \<le> y)"
  by (metis linorder_linear order_le_less order_less_irrefl ordinal_less_plusL ordinal_plus_absorb)

lemma ordinal_less_plusL_iff: "(y < x + y) = (y < x * \<omega>)"
  by (metis leI linorder_neq_iff ordinal_less_plusL ordinal_plus_absorb)

subsection \<open>Additive principal ordinals\<close>

locale additive_principal =
  fixes a :: ordinal
  assumes not_0:  "0 < a"
  assumes sum_eq: "\<And>b. b < a \<Longrightarrow> b + a = a"

lemma (in additive_principal) sum_less:
  "\<lbrakk>x < a; y < a\<rbrakk> \<Longrightarrow> x + y < a"
  by (metis ordinal_plus_strict_monoR sum_eq)

lemma (in additive_principal) times_nat_less:
  "x < a \<Longrightarrow> x * ordinal_of_nat n < a"
  by (induct n) (auto simp: not_0 sum_less)

lemma not_additive_principal_0: "\<not> additive_principal 0"
  by (simp add: additive_principal_def)

lemma additive_principal_oSuc:
  "additive_principal (oSuc a) = (a = 0)"
  unfolding additive_principal_def
  by (metis less_oSuc0 ordinal_plus_0 ordinal_plus_left_cancel_less ordinal_plus_oSuc)

lemma additive_principal_intro2 [rule_format]:
  assumes not_0: "0 < a" and lessa: "(\<forall>x<a. \<forall>y<a. x + y < a)"
  shows "additive_principal a"
proof -
  have "\<forall>b<a. b + a = a"
    using lessa
  proof (induction a rule: oLimit_induct)
    case zero
    then show ?case by auto
  next
    case (suc x)
    then show ?case
      by (metis le_oSucE less_oSuc linorder_not_le ordinal_le_plusL ordinal_plus_oSuc)
  next
    case (lim f)
    then show ?case
      by (metis leD order_le_less ordinal_le_plusL ordinal_plus_minus2)
  qed
  then show ?thesis
    by (simp add: additive_principal_def not_0)
qed

lemma additive_principal_1: "additive_principal (oSuc 0)"
  by (simp add: additive_principal_def)

lemma additive_principal_omega: "additive_principal \<omega>"
  using additive_principal.intro less_omegaD ordinal_of_nat_plus_omega zero_less_omega by blast

lemma additive_principal_times_omega:
  assumes "0 < x" shows "additive_principal (x * \<omega>)"
proof (rule additive_principal.intro)
  fix b
  assume "b < x * \<omega>"
  then obtain k where k: "b < x * ordinal_of_nat k"
    by (metis less_oLimitD omega_def ordinal_times_oLimit)
  then have "b + x * ordinal_of_nat n \<le> x * ordinal_of_nat (k + n)" for n
    by (metis order_less_imp_le ordinal_of_nat_plus ordinal_plus_monoL ordinal_times_distrib)
  then show "b + x * \<omega> = x * \<omega>"
    by (metis oLimit_eqI omega_def ordinal_le_plusL ordinal_plus_oLimit ordinal_times_oLimit)
qed (use assms in auto)

lemma additive_principal_oLimit:
  assumes "\<forall>n. additive_principal (f n)"
  shows "additive_principal (oLimit f)"
proof (rule additive_principal.intro)
  show "0 < oLimit f"
    by (metis assms less_oLimitI not_additive_principal_0 ordinal_neq_0)
next
  fix b
  assume "b < oLimit f"
  then obtain k where "b < f k"
    using less_oLimitD by auto
  then have "\<exists>m. b + f n \<le> f m" for n
    by (metis additive_principal.sum_eq assms order.trans leI order_less_imp_le ordinal_plus_left_cancel_le)
  then show "b + oLimit f = oLimit f"
    by (metis \<open>b < f k\<close> additive_principal_def assms le_oLimit ordinal_plus_assoc ordinal_plus_minus2)
qed

lemma additive_principal_omega_exp: "additive_principal (\<omega> ** x)"
  by (induction x rule: oLimit_induct)
     (auto simp: additive_principal_1 additive_principal_times_omega additive_principal_oLimit)

lemma (in additive_principal) omega_exp: "\<exists>x. a = \<omega> ** x"
proof -
  have "\<exists>x. \<omega> ** x \<le> a \<and> a < \<omega> ** (oSuc x)"
    by (metis not_0 oSuc_less_omega ordinal_exp_oLog_le ordinal_exp_oSuc ordinal_less_exp_oLog zero_less_omega)
  then show ?thesis
    by (metis leD order_le_imp_less_or_eq ordinal_exp_oSuc ordinal_plus_absorb_iff sum_eq)
qed

lemma additive_principal_iff:
  "additive_principal a = (\<exists>x. a = \<omega> ** x)"
  using additive_principal.omega_exp additive_principal_omega_exp by blast

lemma absorb_omega_exp:
  "x < \<omega> ** a \<Longrightarrow> x + \<omega> ** a = \<omega> ** a"
  by (rule additive_principal.sum_eq[OF additive_principal_omega_exp])

lemma absorb_omega_exp2: "a < b \<Longrightarrow> \<omega> ** a + \<omega> ** b = \<omega> ** b"
  by (rule absorb_omega_exp, simp add: ordinal_exp_strict_monoR)

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

lemma cnf_lemma: "x > 0 \<Longrightarrow> x - \<omega> ** oLog \<omega> x < x"
  by (simp add: ordinal_exp_oLog_le ordinal_less_exp_oLog ordinal_less_plusL)

primrec from_cnf where
  "from_cnf []       = 0"
| "from_cnf (x # xs) = \<omega> ** x + from_cnf xs"

function to_cnf where
  [simp del]: "to_cnf x = (if x = 0 then [] else
    oLog \<omega> x # to_cnf (x - \<omega> ** oLog \<omega> x))"
  by pat_completeness auto

termination by (relation "{(x, y). x < y}")
    (simp_all add: wf cnf_lemma)

lemma to_cnf_0 [simp]: "to_cnf 0 = []"
  by (simp add: to_cnf.simps)

lemma to_cnf_not_0:
  "0 < x \<Longrightarrow> to_cnf x = oLog \<omega> x # to_cnf (x - \<omega> ** oLog \<omega> x)"
  by (simp add: to_cnf.simps[of x])

lemma to_cnf_eq_Cons: "to_cnf x = a # list \<Longrightarrow> a = oLog \<omega> x"
  by (case_tac "x = 0", simp, simp add: to_cnf_not_0)

lemma to_cnf_inverse: "from_cnf (to_cnf x) = x"
  using wf
proof (induction rule: wf_induct_rule)
  case (less x)
  then have IH: "\<forall>y<x. from_cnf (to_cnf y) = y"
    by simp
  show ?case
  proof (cases "x = 0")
    case False
    with cnf_lemma show ?thesis
      by (simp add: ordinal_exp_oLog_le to_cnf_not_0 IH)
  qed auto
qed

primrec normalize_cnf where
  normalize_cnf_Nil: "normalize_cnf [] = []"
| normalize_cnf_Cons: "normalize_cnf (x # xs) =
      (case xs of [] \<Rightarrow> [x] | y # ys \<Rightarrow>
        (if x < y then [] else [x]) @ normalize_cnf xs)"

lemma from_cnf_normalize_cnf: "from_cnf (normalize_cnf xs) = from_cnf xs"
proof (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  have "\<And>x y. a < x \<Longrightarrow> \<omega> ** x + from_cnf y = \<omega> ** a + (\<omega> ** x + from_cnf y)"
    by (metis absorb_omega_exp2 from_cnf.simps(2) ordinal_plus_assoc)
  with Cons show ?case
    by simp (auto simp del: normalize_cnf_Cons split: list.split)
qed

lemma normalize_cnf_to_cnf: "normalize_cnf (to_cnf x) = to_cnf x"
  using wf
proof (induction rule: wf_induct_rule)
  case (less x)
  then have IH: "\<forall>y<x. normalize_cnf (to_cnf y) = to_cnf y"
    by simp
  show ?case
  proof (cases "x = 0")
    case False
    then have \<section>: "normalize_cnf (to_cnf (x - \<omega> ** oLog \<omega> x)) = to_cnf (x - \<omega> ** oLog \<omega> x)"
      using IH cnf_lemma by blast
    with False show ?thesis
      apply (simp add: to_cnf_not_0)
      apply (case_tac "to_cnf (x - \<omega> ** oLog \<omega> x)", simp_all)
      by (metis cnf_lemma linorder_not_le order_le_less ordinal_oLog_monoR to_cnf_eq_Cons)
  qed auto
qed

text "alternate form of CNF"

lemma cnf2_lemma:
  "0 < x \<Longrightarrow> x mod \<omega> ** oLog \<omega> x < x"
  by (meson oSuc_less_omega order_less_le_trans ordinal_exp_not_0 ordinal_exp_oLog_le ordinal_mod_less zero_less_omega)

primrec from_cnf2 where
  "from_cnf2 []       = 0"
| "from_cnf2 (x # xs) = \<omega> ** fst x * ordinal_of_nat (snd x) + from_cnf2 xs"

function to_cnf2 where
  [simp del]: "to_cnf2 x = (if x = 0 then [] else
    (oLog \<omega> x, inv ordinal_of_nat (x div (\<omega> ** oLog \<omega> x)))
      # to_cnf2 (x mod (\<omega> ** oLog \<omega> x)))"
  by pat_completeness auto

termination by (relation "{(x,y). x < y}")
    (simp_all add: wf cnf2_lemma)

lemma to_cnf2_0 [simp]: "to_cnf2 0 = []"
  by (simp add: to_cnf2.simps)

lemma to_cnf2_not_0:
  "0 < x \<Longrightarrow> to_cnf2 x = (oLog \<omega> x, inv ordinal_of_nat (x div (\<omega> ** oLog \<omega> x)))
                       # to_cnf2 (x mod (\<omega> ** oLog \<omega> x))"
  by (simp add: to_cnf2.simps[of x])

lemma to_cnf2_eq_Cons: "to_cnf2 x = (a,b) # list \<Longrightarrow> a = oLog \<omega> x"
  by (metis Pair_inject list.discI list.inject to_cnf2.elims)

lemma ordinal_of_nat_of_ordinal:
  "x < \<omega> \<Longrightarrow> ordinal_of_nat (inv ordinal_of_nat x) = x"
  by (simp add: f_inv_into_f image_def less_omegaD)

lemma to_cnf2_inverse: "from_cnf2 (to_cnf2 x) = x"
  using wf
proof (induction x rule: wf_induct_rule)
  case (less x)
  show ?case
  proof (cases "x > 0")
    case True
    then show ?thesis
      by (simp add: cnf2_lemma less ordinal_div_exp_oLog_less ordinal_div_plus_mod ordinal_of_nat_of_ordinal to_cnf2_not_0)
  qed auto
qed

primrec is_normalized2 where
  is_normalized2_Nil: "is_normalized2 [] = True"
| is_normalized2_Cons: "is_normalized2 (x # xs) =
      (case xs of [] \<Rightarrow> True | y # ys \<Rightarrow> fst y < fst x \<and> is_normalized2 xs)"

lemma is_normalized2_to_cnf2: "is_normalized2 (to_cnf2 x)"
  using wf
proof (induction x rule: wf_induct_rule)
  case (less x)
  show ?case
  proof (cases "x > 0")
    case True
    then have *: "is_normalized2 (to_cnf2 (x mod \<omega> ** oLog \<omega> x))"
      using cnf2_lemma less by blast
    show ?thesis
    proof (cases "x mod \<omega> ** oLog \<omega> x = 0")
      case True
      with to_cnf2_not_0 \<open>x > 0\<close> show ?thesis by simp
    next
      case False
      with \<open>x > 0\<close> * show ?thesis
        by (simp add: ordinal_mod_less ordinal_oLog_less to_cnf2_not_0)
    qed
  qed auto
qed

subsection \<open>Epsilon 0\<close>

definition epsilon0 :: ordinal  ("\<epsilon>\<^sub>0") where
  "epsilon0 = oFix ((**) \<omega>) 0"

lemma less_omega_exp: "x < \<epsilon>\<^sub>0 \<Longrightarrow> x < \<omega> ** x"
  by (simp add: epsilon0_def less_oFix_0D normal.mono normal_exp)

lemma omega_exp_epsilon0: "\<omega> ** \<epsilon>\<^sub>0 = \<epsilon>\<^sub>0"
  by (simp add: continuous_exp epsilon0_def oFix_fixed)

lemma oLog_omega_less: "\<lbrakk>0 < x; x < \<epsilon>\<^sub>0\<rbrakk> \<Longrightarrow> oLog \<omega> x < x"
  by (simp add: less_omega_exp ordinal_oLog_less)

end


theory BinarySearch
  imports Auto2_HOL.Auto2_Main
begin

fun avg :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "avg l r = (l + r) div 2"

function binarysearch_fun :: "nat \<Rightarrow> nat \<Rightarrow> 'a::linorder \<Rightarrow> 'a list \<Rightarrow> bool" where
  "binarysearch_fun l r x xs =
   (if l \<ge> r then False
    else if l + 1 \<ge> r then xs ! l = x
    else let m = avg l r in
      if xs ! m = x then True
      else if xs ! m < x then binarysearch_fun (m + 1) r x xs
      else binarysearch_fun l m x xs)"
by pat_completeness auto
termination by (relation "Wellfounded.measure (\<lambda>(l,r,a,f). r-l)") auto

setup \<open>register_wellform_data ("binarysearch_fun l r x xs", ["l \<le> r", "r \<le> length xs"])\<close>
setup \<open>add_prfstep_check_req ("binarysearch_fun l r x xs", "l \<le> r \<and> r \<le> length xs")\<close>

lemma avg_between [backward]:
  "l + 1 < r \<Longrightarrow> r > avg l r"
  "l + 1 < r \<Longrightarrow> avg l r > l" by auto

lemma binarysearch_fun_correct [rewrite]:
  "sorted xs \<Longrightarrow> l \<le> r \<Longrightarrow> r \<le> length xs \<Longrightarrow>
   binarysearch_fun l r x xs \<longleftrightarrow> (\<exists>i. l \<le> i \<and> i < r \<and> xs ! i = x)"
@proof @fun_induct "binarysearch_fun l r x xs"
  @unfold "binarysearch_fun l r x xs"
  @case "l \<ge> r" @case "l + 1 \<ge> r"
  @have "avg l r + 1 \<le> r"
@qed

end


theory Partial_Equivalence_Relation
imports Main
begin

subsection {* Partial Equivalence Relations *}
text {*
  The abstract datatype for a union-find structure is a partial equivalence
  relation.
*}

definition "part_equiv R \<equiv> sym R \<and> trans R"

lemma part_equivI[intro?]: "\<lbrakk>sym R; trans R\<rbrakk> \<Longrightarrow> part_equiv R"
  by (simp add: part_equiv_def)

lemma part_equiv_refl:
  "part_equiv R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (x,x)\<in>R"
  "part_equiv R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (y,y)\<in>R"
  by (metis part_equiv_def symD transD)+

lemma part_equiv_sym: "part_equiv R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (y,x)\<in>R"
  by (metis part_equiv_def symD)

lemma part_equiv_trans: "part_equiv R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (y,z)\<in>R \<Longrightarrow> (x,z)\<in>R"
  by (metis part_equiv_def transD)

lemma part_equiv_trans_sym:
  "\<lbrakk> part_equiv R; (a,b)\<in>R; (c,b)\<in>R \<rbrakk> \<Longrightarrow> (a,c)\<in>R"
  "\<lbrakk> part_equiv R; (a,b)\<in>R; (a,c)\<in>R \<rbrakk> \<Longrightarrow> (b,c)\<in>R"
  apply (metis part_equiv_sym part_equiv_trans)+
  done

text {* We define a shortcut for symmetric closure. *}
definition "symcl R \<equiv> R \<union> R\<inverse>"

text {* We also define a shortcut for melding the equivalence classes of
  two given elements *}
definition per_union where "per_union R a b \<equiv> R \<union>
  { (x,y). (x,a)\<in>R \<and> (y,b)\<in>R } \<union> { (y,x). (x,a)\<in>R \<and> (y,b)\<in>R }"

lemma union_part_equivp:
  "part_equiv R \<Longrightarrow> part_equiv (per_union R a b)"
  apply rule
  unfolding per_union_def
  apply (rule symI)
  apply (auto dest: part_equiv_sym) []

  apply (rule transI)
  apply (auto dest: part_equiv_trans part_equiv_trans_sym)
  done

lemma per_union_cmp:
  "\<lbrakk> part_equiv R; (l,j)\<in>R \<rbrakk> \<Longrightarrow> per_union R l j = R"
  unfolding per_union_def by (auto dest: part_equiv_trans_sym)

lemma per_union_same[simp]: "part_equiv R \<Longrightarrow> per_union R l l = R"
  unfolding per_union_def by (auto dest: part_equiv_trans_sym)

lemma per_union_commute[simp]: "per_union R i j = per_union R j i"
  unfolding per_union_def by auto

lemma per_union_dom[simp]: "Domain (per_union R i j) = Domain R"
  unfolding per_union_def by auto

lemma per_classes_dj:
  "\<lbrakk>part_equiv R; (i,j)\<notin>R\<rbrakk> \<Longrightarrow> R``{i} \<inter> R``{j} = {}"
  by (auto dest: part_equiv_trans_sym)

lemma per_class_in_dom: "\<lbrakk>part_equiv R\<rbrakk> \<Longrightarrow> R``{i} \<subseteq> Domain R"
  by (auto dest: part_equiv_trans_sym)

end


(*
    File:      Divisor_Count.thy
    Author:    Manuel Eberl, TU München
*)
section \<open>The divisor functions\<close>
theory Divisor_Count
imports
  Complex_Main
  "HOL-Number_Theory.Number_Theory"
  Dirichlet_Series
  More_Totient
  Moebius_Mu
begin

subsection \<open>The general divisor function\<close>

definition divisor_sigma :: "'a :: nat_power \<Rightarrow> nat \<Rightarrow> 'a" where
  "divisor_sigma x n = (\<Sum>d | d dvd n. nat_power d x)"

lemma divisor_sigma_0 [simp]: "divisor_sigma x 0 = 0"
  by (simp add: divisor_sigma_def)

lemma divisor_sigma_Suc_0 [simp]: "divisor_sigma x (Suc 0) = 1"
  by (simp add: divisor_sigma_def)

lemma divisor_sigma_1 [simp]: "divisor_sigma x 1 = 1"
  by simp

lemma fds_divisor_sigma: "fds (divisor_sigma x) = fds_zeta * fds_shift x fds_zeta"
  by (rule fds_eqI) (simp add: fds_nth_mult dirichlet_prod_altdef1 divisor_sigma_def)

interpretation divisor_sigma: multiplicative_function "divisor_sigma x"
proof -
  have "multiplicative_function (dirichlet_prod (\<lambda>n. if n = 0 then 0 else 1)
           (\<lambda>n. if n = 0 then 0 else nat_power n x))" (is "multiplicative_function ?f")
    by (rule multiplicative_dirichlet_prod; standard)
       (simp_all add: nat_power_mult_distrib)
  also have "?f n = divisor_sigma x n" for n
    using fds_divisor_sigma[of x]
    by (cases "n = 0") (simp_all add: fds_eq_iff fds_nth_mult )
  hence "?f = divisor_sigma x" ..
  finally show "multiplicative_function (divisor_sigma x)" .
qed

lemma divisor_sigma_naive [code]:
  "divisor_sigma x n = (if n = 0 then 0 else fold_atLeastAtMost_nat
        (\<lambda>d acc. if d dvd n then nat_power d x + acc else acc) 1 n 0)"
proof (cases "n = 0")
  case False
  have "divisor_sigma x n = (\<Sum>d\<in>{1..n}. if d dvd n then nat_power d x else 0)"
    unfolding divisor_sigma_def using False by (intro sum.mono_neutral_cong_left) (auto elim: dvdE)
  also have "\<dots> = fold_atLeastAtMost_nat
        (\<lambda>d acc. (if d dvd n then nat_power d x else 0) + acc) 1 n 0"
    by (rule sum_atLeastAtMost_code)
  also have "(\<lambda>d acc. (if d dvd n then nat_power d x else 0) + acc) =
               (\<lambda>d acc. (if d dvd n then nat_power d x + acc else acc))"
    by (auto simp: fun_eq_iff)
  finally show ?thesis using False by simp
qed auto

lemma divisor_sigma_of_nat: "divisor_sigma (of_nat x) n = of_nat (divisor_sigma x n)"
proof (cases "n = 0")
  case False
  show ?thesis unfolding divisor_sigma_def of_nat_sum
    by (intro sum.cong refl, subst nat_power_of_nat) (insert False, auto elim: dvdE)
qed auto

lemma divisor_sigma_prime_power_field:
  fixes x :: "'a :: {field, nat_power}"
  assumes "prime p"
  shows   "divisor_sigma x (p ^ k) =
             (if nat_power p x = 1 then of_nat (k + 1) else
             (nat_power p x ^ Suc k - 1) / (nat_power p x - 1))"
proof -
  have "divisor_sigma x (p ^ k) = (\<Sum>i\<le>k. nat_power (p^i) x)"
    unfolding divisor_sigma_def
    by (rule sum.reindex_bij_betw [symmetric])
       (insert assms, auto simp: bij_betw_def inj_on_def prime_gt_Suc_0_nat
          divides_primepow_nat intro: le_imp_power_dvd)
  also have "\<dots> = (\<Sum>i\<le>k. nat_power p x ^ i)"
    using assms by (intro sum.cong refl) (simp_all add: prime_gt_0_nat nat_power_power_left)
  also have "\<dots> = (if nat_power p x = 1 then of_nat (k + 1) else
                    (nat_power p x ^ Suc k - 1) / (nat_power p x - 1))"
    using geometric_sum[of "nat_power p x" "Suc k"] unfolding lessThan_Suc_atMost
    by (auto split: if_splits)
  finally show ?thesis .
qed

lemma divisor_sigma_prime_power_nat:
  assumes "prime p"
  shows   "divisor_sigma x (p ^ k) = (if x = 0 then Suc k else
             (p ^ (x * Suc k) - 1) div (p ^ x - 1))"
proof (cases "x = 0")
  case True
  with assms have "nat_power p (real x) = 1" by simp
  hence "divisor_sigma (real x) (p ^ k) = real (Suc k)"
    by (subst divisor_sigma_prime_power_field) (simp_all del: nat_power_real_def add: assms)
  thus ?thesis unfolding divisor_sigma_of_nat by (subst (asm) of_nat_eq_iff) (insert True, simp)
next
  case False
  with assms have gt_1: "p ^ x > 1"
    using power_gt1[of p "x - 1"] by (simp add: prime_gt_Suc_0_nat)
  hence not_one: "real p ^ x \<noteq> 1"
    unfolding of_nat_power [symmetric] of_nat_eq_1_iff by (intro notI) simp
  from gt_1 have dvd: "p ^ x - 1 dvd p ^ (x * Suc k) - 1"
    using geometric_sum_nat_dvd[of "p ^ x" "Suc k"] assms
    by (simp add: power_mult prime_gt_Suc_0_nat power_add)
  have "divisor_sigma (real x) (p ^ k) =
          real (if x = 0 then Suc k else (p ^ (x * Suc k) - 1) div (p ^ x - 1))"
    by (subst divisor_sigma_prime_power_field [OF assms, where 'a = real])
       (insert assms False dvd not_one, auto simp del: power_Suc nat_power_real_def
        simp: prime_gt_0_nat real_of_nat_div of_nat_diff prime_ge_Suc_0_nat power_mult [symmetric])
  thus ?thesis unfolding divisor_sigma_of_nat by (subst (asm) of_nat_eq_iff)
qed

interpretation divisor_sigma_field:
  multiplicative_function' "divisor_sigma (x :: 'a :: {field, nat_power})"
    "\<lambda>p k. if nat_power p x = 1 then of_nat (Suc k) else
        (nat_power p x ^ Suc k - 1) / (nat_power p x - 1)"
    "\<lambda>p. nat_power p x + 1"
  by standard (auto simp: divisor_sigma_prime_power_field prime_gt_0_nat field_simps)

interpretation divisor_sigma_real:
  multiplicative_function' "divisor_sigma (x :: real)"
    "\<lambda>p k. if x = 0 then of_nat (Suc k) else ((real p powr x) ^ Suc k - 1) / (real p powr x - 1)"
    "\<lambda>p. real p powr x + 1"
proof (standard, goal_cases)
  case (1 p k)
  thus ?case
    by (auto simp: divisor_sigma_prime_power_field prime_gt_0_nat powr_def of_nat_eq_1_iff
                   exp_of_nat_mult [symmetric] mult_ac simp del: of_nat_Suc power_Suc)
next
  case (2 p)
  hence "real p powr x \<noteq> 1" if "x \<noteq> 0" by (auto simp: powr_def that prime_gt_0_nat of_nat_eq_1_iff)
  with 2 show ?case by (auto simp: field_simps)
qed

interpretation divisor_sigma_nat:
  multiplicative_function' "divisor_sigma (x :: nat)"
    "\<lambda>p k. if x = 0 then Suc k else (p ^ (Suc k * x) - 1) div (p ^ x - 1)"
    "\<lambda>p. p ^ x + 1"
proof (standard, goal_cases)
  case (2 p)
  have "(p ^ (x + x) - 1) = (p ^ x + 1) * (p ^ x - 1)"
    by (simp add: algebra_simps power_add)
  moreover have "p ^ x > 1" if "x > 0" using that 2 one_less_power prime_gt_1_nat by blast
  ultimately show ?case using prime_ge_Suc_0_nat[of p] by auto
qed (auto simp: divisor_sigma_prime_power_nat mult_ac)

lemma divisor_sigma_prime:
  assumes "prime p"
  shows   "divisor_sigma x p = nat_power p x + 1"
proof -
  have "divisor_sigma x p = (\<Sum>d | d dvd p. nat_power d x)"
    by (simp add: divisor_sigma_def)
  also from assms have "{d. d dvd p} = {1, p}" by (auto simp: prime_nat_iff)
  also have "(\<Sum>d\<in>\<dots>. nat_power d x) = nat_power p x + 1"
    using assms by (subst sum.insert) (auto simp: add_ac)
  finally show ?thesis .
qed

subsection \<open>The divisor-counting function\<close>

definition divisor_count :: "nat \<Rightarrow> nat" where
  "divisor_count n = card {d. d dvd n}"

lemma divisor_count_0 [simp]: "divisor_count 0 = 0"
  by (simp add: divisor_count_def)

lemma divisor_count_Suc_0 [simp]: "divisor_count (Suc 0) = 1"
  by (simp add: divisor_count_def)

lemma divisor_sigma_0_left_nat: "divisor_sigma 0 n = divisor_count n"
  by (simp add: divisor_sigma_def divisor_count_def)

lemma divisor_sigma_0_left: "divisor_sigma 0 n = of_nat (divisor_count n)"
  unfolding divisor_sigma_0_left_nat [symmetric] divisor_sigma_of_nat [symmetric] by simp

lemma divisor_count_altdef: "divisor_count n = divisor_sigma 0 n"
  by (simp add: divisor_sigma_0_left)

lemma divisor_count_naive [code]:
  "divisor_count n = (if n = 0 then 0 else
     fold_atLeastAtMost_nat (\<lambda>d acc. if d dvd n then Suc acc else acc) 1 n 0)"
  using divisor_sigma_naive[of "0 :: nat" n]
  by (simp split: if_splits add: divisor_count_altdef cong: if_cong)

interpretation divisor_count: multiplicative_function' divisor_count "\<lambda>p k. Suc k" "\<lambda>_. 2"
  by standard (simp_all add: divisor_count_altdef divisor_sigma.mult_coprime
                             divisor_sigma_nat.prime_power)

lemma divisor_count_dvd_mono:
  assumes "a dvd b" "b \<noteq> 0"
  shows   "divisor_count a \<le> divisor_count b"
  using assms by (auto simp: divisor_count_def intro!: card_mono intro: dvd_trans)

subsection \<open>The divisor sum function\<close>

definition divisor_sum :: "nat \<Rightarrow> nat" where
  "divisor_sum n = \<Sum>{d. d dvd n}"

lemma divisor_sum_0 [simp]: "divisor_sum 0 = 0"
  by (simp add: divisor_sum_def)

lemma divisor_sum_Suc_0 [simp]: "divisor_sum (Suc 0) = Suc 0"
  by (simp add: divisor_sum_def)

lemma divisor_sigma_1_left_nat: "divisor_sigma (Suc 0) n = divisor_sum n"
  by (simp add: divisor_sum_def divisor_sigma_def)

lemma divisor_sigma_1_left: "divisor_sigma 1 n = of_nat (divisor_sum n)"
  by (simp add: divisor_sum_def divisor_sigma_def)

lemma divisor_sum_altdef: "divisor_sum n = divisor_sigma 1 n"
  by (simp add: divisor_sigma_1_left_nat)

interpretation divisor_sum:
  multiplicative_function' divisor_sum "\<lambda>p k. (p ^ Suc k - 1) div (p - 1)" "\<lambda>p. Suc p"
proof (standard, goal_cases)
  case (5 p)
  thus ?case using divisor_sigma_nat.prime_aux[of p 1]
    by (simp_all add: divisor_sum_altdef)
qed (simp_all add: divisor_sum_altdef divisor_sigma_nat.prime_power divisor_sigma.mult_coprime)

lemma divisor_sum_dvd_mono:
  assumes "a dvd b" "b \<noteq> 0"
  shows   "divisor_sum a \<le> divisor_sum b"
  using assms
  by (cases "a = 0") (auto simp: divisor_sum_def intro!: sum_le_included intro: dvd_trans)

lemma divisor_sum_naive [code]:
  "divisor_sum n = (if n = 0 then 0 else
     fold_atLeastAtMost_nat (\<lambda>d acc. if d dvd n then d + acc else acc) 1 n 0)"
  using divisor_sigma_naive[of "Suc 0" n]
  by (simp split: if_splits add: divisor_sum_altdef cong: if_cong)

lemma fds_divisor_count: "fds divisor_count = fds_zeta ^ 2"
  by (rule fds_eqI)
     (simp add: fds_nth_mult dirichlet_prod_altdef1 divisor_count_def power2_eq_square)

lemma fds_shift_zeta_1: "fds_shift 1 fds_zeta = fds of_nat"
  by (rule fds_eqI) (simp add: fds_nth_mult)

lemma fds_shift_zeta_Suc_0: "fds_shift (Suc 0) fds_zeta = fds id"
  by (rule fds_eqI) (simp add: fds_nth_mult)

lemma fds_divisor_sum: "fds divisor_sum = fds_zeta * fds id"
  by (rule fds_eqI) (simp add: fds_nth_mult dirichlet_prod_altdef1 divisor_sum_def)

lemma fds_divisor_sum_eq_totient_times_d: "fds divisor_sum = fds totient * fds divisor_count"
proof -
  have "fds divisor_sum = fds_zeta * fds id" by (fact fds_divisor_sum)
  also have "fds id = fds totient * fds_zeta" by (rule fds_totient_times_zeta' [symmetric])
  also have "fds_zeta * \<dots> = fds totient * fds divisor_count"
    using fds_divisor_count by (simp add: power2_eq_square mult_ac)
  finally show ?thesis .
qed

lemma fds_divisor_sum_times_moebius_mu:
  "fds (divisor_sigma (1 :: 'a :: {nat_power,comm_ring_1})) * fds moebius_mu = fds of_nat"
proof -
  have "fds (divisor_sigma 1) * fds moebius_mu =
          fds of_nat * (fds_zeta * fds moebius_mu :: 'a fds)"
    by (subst mult.assoc [symmetric], subst fds_zeta_commutes [symmetric])
       (simp add: fds_divisor_sigma fds_shift_zeta_1)
  also have "fds_zeta * fds moebius_mu = (1 :: 'a fds)" by (fact fds_zeta_times_moebius_mu)
  finally show ?thesis by simp
qed

(* Theorem 2.20 *)
lemma inverse_divisor_sigma:
  fixes a :: "'a :: {field, nat_power}"
  shows "inverse (fds (divisor_sigma a)) = fds_shift a (fds moebius_mu) * fds moebius_mu"
proof -
  have "fds (divisor_sigma a) = fds_zeta * fds_shift a fds_zeta"
    by (simp add: fds_divisor_sigma)
  also have "inverse \<dots> = fds moebius_mu * inverse (fds_shift a fds_zeta)"
    by (simp add: fds_moebius_inverse_zeta inverse_mult_fds)
  also have "inverse (fds_shift a fds_zeta) =
               fds (\<lambda>n. moebius_mu n * fds_nth (fds_shift a fds_zeta) n)"
    by (intro completely_multiplicative_fds_inverse', unfold_locales)
       (auto simp: nat_power_mult_distrib)
  also have "\<dots> = fds_shift a (fds moebius_mu)"
    by (auto simp: fds_eq_iff)
  finally show ?thesis by (simp add: mult.commute)
qed

end


chapter {* R6: Recorridos de árboles *}

theory R6_Recorridos_de_arboles
imports Main
begin

text {*
  ---------------------------------------------------------------------
  Ejercicio 1. Definir el tipo de datos arbol para representar los
  árboles binarios que tiene información en los nodos y en las hojas.
  Por ejemplo, el árbol
          e
         / \
        /   \
       c     g
      / \   / \
     a   d f   h
  se representa por "N e (N c (H a) (H d)) (N g (H f) (H h))".
  ---------------------------------------------------------------------
*}

datatype 'a arbol = H "'a" | N "'a" "'a arbol" "'a arbol"

value "N e (N c (H a) (H d)) (N g (H f) (H h))"

text {*
  ---------------------------------------------------------------------
  Ejercicio 2. Definir la función
     preOrden :: "'a arbol \<Rightarrow> 'a list"
  tal que (preOrden a) es el recorrido pre orden del árbol a. Por
  ejemplo,
     preOrden (N e (N c (H a) (H d)) (N g (H f) (H h)))
     = [e,c,a,d,g,f,h]
  ---------------------------------------------------------------------
*}

fun preOrden :: "'a arbol \<Rightarrow> 'a list" where
  "preOrden (H t) = [t]"
| "preOrden (N t i d) = [t] @ (preOrden i) @ (preOrden d)"

value "preOrden (N e (N c (H a) (H d)) (N g (H f) (H h)))
      = [e,c,a,d,g,f,h]"

text {*
  ---------------------------------------------------------------------
  Ejercicio 3. Definir la función
     postOrden :: "'a arbol \<Rightarrow> 'a list"
  tal que (postOrden a) es el recorrido post orden del árbol a. Por
  ejemplo,
     postOrden (N e (N c (H a) (H d)) (N g (H f) (H h)))
     = [e,c,a,d,g,f,h]
  ---------------------------------------------------------------------
*}

fun postOrden :: "'a arbol \<Rightarrow> 'a list" where
  "postOrden (H t) = [t]"
| "postOrden (N t i d) = (postOrden i) @ (postOrden d) @ [t]"

value "postOrden (N e (N c (H a) (H d)) (N g (H f) (H h)))
       = [a,d,c,f,h,g,e]"

text {*
  ---------------------------------------------------------------------
  Ejercicio 4. Definir la función
     inOrden :: "'a arbol \<Rightarrow> 'a list"
  tal que (inOrden a) es el recorrido in orden del árbol a. Por
  ejemplo,
     inOrden (N e (N c (H a) (H d)) (N g (H f) (H h)))
     = [a,c,d,e,f,g,h]
  ---------------------------------------------------------------------
*}

fun inOrden :: "'a arbol \<Rightarrow> 'a list" where
  "inOrden (H t) = [t]"
| "inOrden (N t i d) = (inOrden i) @ [t] @ (inOrden d)"

value "inOrden (N e (N c (H a) (H d)) (N g (H f) (H h)))
       = [a,c,d,e,f,g,h]"

text {*
  ---------------------------------------------------------------------
  Ejercicio 5. Definir la función
     espejo :: "'a arbol \<Rightarrow> 'a arbol"
  tal que (espejo a) es la imagen especular del árbol a. Por ejemplo,
     espejo (N e (N c (H a) (H d)) (N g (H f) (H h)))
     = N e (N g (H h) (H f)) (N c (H d) (H a))
  ---------------------------------------------------------------------
*}

fun espejo :: "'a arbol \<Rightarrow> 'a arbol" where
  "espejo (H t) = H t"
| "espejo (N t i d) = N t (espejo d) (espejo i)"

value "espejo (N e (N c (H a) (H d)) (N g (H f) (H h)))
       = N e (N g (H h) (H f)) (N c (H d) (H a))"

text {*
  ---------------------------------------------------------------------
  Ejercicio 6. Demostrar que
     preOrden (espejo a) = rev (postOrden a)
  ---------------------------------------------------------------------
*}

lemma  "preOrden (espejo a) = rev (postOrden a)" (is "?P a")
proof (induct a)
  fix x
  show "?P (H x)" by simp
next
  fix x
  fix i assume h1: "?P i"
  fix d assume h2: "?P d"
  have "preOrden (espejo (N x i d)) = preOrden (N x (espejo d) (espejo i))" by simp
  also have "... = [x] @ (preOrden (espejo d)) @ (preOrden (espejo i))" by simp
  also have "... = [x] @ rev (postOrden d) @ rev (postOrden i)" using h1 h2 by simp
  finally show "preOrden (espejo (N x i d)) = rev (postOrden (N x i d))" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 7. Demostrar que
     postOrden (espejo a) = rev (preOrden a)
  ---------------------------------------------------------------------
*}

lemma "postOrden (espejo a) = rev (preOrden a)" (is "?P a")
proof (induct a)
  fix x
  show "?P (H x)" by simp
next
  fix x
  fix i assume h1: "?P i"
  fix d assume h2: "?P d"
  have "postOrden (espejo (N x i d)) = postOrden (N x (espejo d) (espejo i))" by simp
  also have "... = (postOrden (espejo d)) @ (postOrden (espejo i)) @ [x]" by simp
  also have "... = rev (preOrden d) @ rev (preOrden i) @ [x]" using h1 h2 by simp
  finally show "?P (N x i d)" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 8. Demostrar que
     inOrden (espejo a) = rev (inOrden a)
  ---------------------------------------------------------------------
*}

theorem "inOrden (espejo a) = rev (inOrden a)" (is "?P a")
proof (induct a)
  fix x
  show "?P (H x)" by simp
next
  fix x
  fix i assume h1: "?P i"
  fix d assume h2: "?P d"
  have "inOrden (espejo (N x i d)) = inOrden (N x (espejo d) (espejo i))" by simp
  also have "... = (inOrden (espejo d)) @ [x] @ (inOrden (espejo i))" by simp
  also have "... = rev (inOrden d) @ [x] @ rev (inOrden i)" using h1 h2 by simp
  finally show "?P (N x i d)" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 9. Definir la función
     raiz :: "'a arbol \<Rightarrow> 'a"
  tal que (raiz a) es la raiz del árbol a. Por ejemplo,
     raiz (N e (N c (H a) (H d)) (N g (H f) (H h))) = e
  ---------------------------------------------------------------------
*}

fun raiz :: "'a arbol \<Rightarrow> 'a" where
  "raiz (H x) = x"
| "raiz (N x i d) = x"

value "raiz (N e (N c (H a) (H d)) (N g (H f) (H h))) = e"

text {*
  ---------------------------------------------------------------------
  Ejercicio 10. Definir la función
     extremo_izquierda :: "'a arbol \<Rightarrow> 'a"
  tal que (extremo_izquierda a) es el nodo más a la izquierda del árbol
  a. Por ejemplo,
     extremo_izquierda (N e (N c (H a) (H d)) (N g (H f) (H h))) = a
  ---------------------------------------------------------------------
*}

fun extremo_izquierda :: "'a arbol \<Rightarrow> 'a" where
  "extremo_izquierda (H t) = t"
| "extremo_izquierda (N t i d) = extremo_izquierda i"

value "extremo_izquierda (N e (N c (H a) (H d)) (N g (H f) (H h))) = a"

text {*
  ---------------------------------------------------------------------
  Ejercicio 11. Definir la función
     extremo_derecha :: "'a arbol \<Rightarrow> 'a"
  tal que (extremo_derecha a) es el nodo más a la derecha del árbol
  a. Por ejemplo,
     extremo_derecha (N e (N c (H a) (H d)) (N g (H f) (H h))) = h
  ---------------------------------------------------------------------
*}

fun extremo_derecha :: "'a arbol \<Rightarrow> 'a" where
  "extremo_derecha (H t) = t"
| "extremo_derecha (N t i d) = extremo_derecha d"

value "extremo_derecha (N e (N c (H a) (H d)) (N g (H f) (H h))) = h"

text {*
  ---------------------------------------------------------------------
  Ejercicio 12. Demostrar o refutar
     last (inOrden a) = extremo_derecha a
  ---------------------------------------------------------------------
*}

lemma aux_ej12: "inOrden a \<noteq> []"
apply (induct a)
apply simp
apply simp
done

theorem "last (inOrden a) = extremo_derecha a" (is "?P a")
proof (induct a)
  fix t
  show "?P (H t)" by simp
next
  fix t i d
  assume H1: "?P i"
  assume H2: "?P d"
  have "last (inOrden (N t i d)) = last (inOrden i @ [t] @ inOrden d)"
    by (simp only: inOrden.simps(2))
  also have "\<dots> = last (inOrden d)" by (simp add: aux_ej12)
  also have "\<dots> = extremo_derecha d" using H2 by simp
  also have "\<dots> = extremo_derecha (N t i d)" by simp
  finally show "?P (N t i d)" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 13. Demostrar o refutar
     hd (inOrden a) = extremo_izquierda a
  ---------------------------------------------------------------------
*}

theorem "hd (inOrden a) = extremo_izquierda a" (is "?P a")
proof (induct a)
  fix t
  show "?P (H t)" by simp
next
  fix t i d
  assume H1: "?P i"
  assume H2: "?P d"
  have "hd (inOrden (N t i d)) = hd (inOrden i @ [t] @ inOrden d)"
    by (simp only: inOrden.simps(2))
  also have "\<dots> = hd (inOrden i)" by (simp add: aux_ej12)
  also have "\<dots> = extremo_izquierda i" using H1 by simp
  also have "\<dots> = extremo_izquierda (N t i d)" by simp
  finally show "?P (N t i d)" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 14. Demostrar o refutar
     hd (preOrden a) = last (postOrden a)
  ---------------------------------------------------------------------
*}

theorem "hd (preOrden a) = last (postOrden a)" (is "?P a")
proof (induct a)
  fix t
  show "?P (H t)" by simp
next
  fix t
  fix i assume H1: "?P i"
  fix d assume H2: "?P d"
  have "hd (preOrden (N t i d)) = hd ([t] @ (preOrden i) @ (preOrden d))" by simp
  also have "... = hd ([t])" by simp
  finally show "hd (preOrden (N t i d)) = last (postOrden (N t i d))" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 15. Demostrar o refutar
     hd (preOrden a) = raiz a
  ---------------------------------------------------------------------
*}

theorem "hd (preOrden a) = raiz a" (is "?P a")
proof (induct a)
  fix t
  show "?P (H t)" by simp
next
  fix t i d
  assume H1: " ?P i"
  assume H2: " ?P d"
  have " hd (preOrden (N t i d)) = hd ([t] @ preOrden i @ preOrden d) " by simp
  also have "... = t" by simp
  also have "... = raiz (N t i d)" by simp
  finally show " ?P (N t i d)" by simp
qed

text {*
  ---------------------------------------------------------------------
  Ejercicio 16. Demostrar o refutar
     hd (inOrden a) = raiz a
  ---------------------------------------------------------------------
*}

theorem "hd (inOrden a) = raiz a"
quickcheck
oops

text {*
  ---------------------------------------------------------------------
  Ejercicio 17. Demostrar o refutar
     last (postOrden a) = raiz a
  ---------------------------------------------------------------------
*}

theorem "last (postOrden a) = raiz a" (is "?P a")
proof (induct a )
  fix t
  show "?P (H t)" by simp
next
  fix t i d
  assume H1: "?P i"
  assume H2: "?P d"
  have "last (postOrden (N t i d)) = last ( postOrden i @ postOrden d @ [t])" by simp
  also have "... = t" by simp
  also have "... = raiz (N t i d) " by simp
  finally show " ?P (N t i d)" by simp
qed

end


(*  Title:      HOL/Analysis/Continuum_Not_Denumerable.thy
    Author:     Benjamin Porter, Monash University, NICTA, 2005
    Author:     Johannes Hölzl, TU München
*)

section \<open>Non-denumerability of the Continuum.\<close>

theory Continuum_Not_Denumerable
imports
  Complex_Main
  "~~/src/HOL/Library/Countable_Set"
begin

subsection \<open>Abstract\<close>

text \<open>
  The following document presents a proof that the Continuum is uncountable.
  It is formalised in the Isabelle/Isar theorem proving system.

  \<^bold>\<open>Theorem:\<close> The Continuum \<open>\<real>\<close> is not denumerable. In other words, there does
  not exist a function \<open>f: \<nat> \<Rightarrow> \<real>\<close> such that \<open>f\<close> is surjective.

  \<^bold>\<open>Outline:\<close> An elegant informal proof of this result uses Cantor's
  Diagonalisation argument. The proof presented here is not this one.

  First we formalise some properties of closed intervals, then we prove the
  Nested Interval Property. This property relies on the completeness of the
  Real numbers and is the foundation for our argument. Informally it states
  that an intersection of countable closed intervals (where each successive
  interval is a subset of the last) is non-empty. We then assume a surjective
  function \<open>f: \<nat> \<Rightarrow> \<real>\<close> exists and find a real \<open>x\<close> such that \<open>x\<close> is not in the
  range of \<open>f\<close> by generating a sequence of closed intervals then using the
  Nested Interval Property.
\<close>

theorem real_non_denum: "\<nexists>f :: nat \<Rightarrow> real. surj f"
proof
  assume "\<exists>f::nat \<Rightarrow> real. surj f"
  then obtain f :: "nat \<Rightarrow> real" where "surj f" ..

  txt \<open>First we construct a sequence of nested intervals, ignoring @{term "range f"}.\<close>

  have "a < b \<Longrightarrow> \<exists>ka kb. ka < kb \<and> {ka..kb} \<subseteq> {a..b} \<and> c \<notin> {ka..kb}" for a b c :: real
    by (auto simp add: not_le cong: conj_cong)
      (metis dense le_less_linear less_linear less_trans order_refl)
  then obtain i j where ij:
    "a < b \<Longrightarrow> i a b c < j a b c"
      "a < b \<Longrightarrow> {i a b c .. j a b c} \<subseteq> {a .. b}"
      "a < b \<Longrightarrow> c \<notin> {i a b c .. j a b c}"
    for a b c :: real
    by metis

  define ivl where "ivl =
    rec_nat (f 0 + 1, f 0 + 2) (\<lambda>n x. (i (fst x) (snd x) (f n), j (fst x) (snd x) (f n)))"
  define I where "I n = {fst (ivl n) .. snd (ivl n)}" for n

  have ivl [simp]:
    "ivl 0 = (f 0 + 1, f 0 + 2)"
    "\<And>n. ivl (Suc n) = (i (fst (ivl n)) (snd (ivl n)) (f n), j (fst (ivl n)) (snd (ivl n)) (f n))"
    unfolding ivl_def by simp_all

  txt \<open>This is a decreasing sequence of non-empty intervals.\<close>

  have less: "fst (ivl n) < snd (ivl n)" for n
    by (induct n) (auto intro!: ij)

  have "decseq I"
    unfolding I_def decseq_Suc_iff ivl fst_conv snd_conv
    by (intro ij allI less)

  txt \<open>Now we apply the finite intersection property of compact sets.\<close>

  have "I 0 \<inter> (\<Inter>i. I i) \<noteq> {}"
  proof (rule compact_imp_fip_image)
    fix S :: "nat set"
    assume fin: "finite S"
    have "{} \<subset> I (Max (insert 0 S))"
      unfolding I_def using less[of "Max (insert 0 S)"] by auto
    also have "I (Max (insert 0 S)) \<subseteq> (\<Inter>i\<in>insert 0 S. I i)"
      using fin decseqD[OF \<open>decseq I\<close>, of _ "Max (insert 0 S)"]
      by (auto simp: Max_ge_iff)
    also have "(\<Inter>i\<in>insert 0 S. I i) = I 0 \<inter> (\<Inter>i\<in>S. I i)"
      by auto
    finally show "I 0 \<inter> (\<Inter>i\<in>S. I i) \<noteq> {}"
      by auto
  qed (auto simp: I_def)
  then obtain x where "x \<in> I n" for n
    by blast
  moreover from \<open>surj f\<close> obtain j where "x = f j"
    by blast
  ultimately have "f j \<in> I (Suc j)"
    by blast
  with ij(3)[OF less] show False
    unfolding I_def ivl fst_conv snd_conv by auto
qed

lemma uncountable_UNIV_real: "uncountable (UNIV :: real set)"
  using real_non_denum unfolding uncountable_def by auto

lemma bij_betw_open_intervals:
  fixes a b c d :: real
  assumes "a < b" "c < d"
  shows "\<exists>f. bij_betw f {a<..<b} {c<..<d}"
proof -
  define f where "f a b c d x = (d - c)/(b - a) * (x - a) + c" for a b c d x :: real
  {
    fix a b c d x :: real
    assume *: "a < b" "c < d" "a < x" "x < b"
    moreover from * have "(d - c) * (x - a) < (d - c) * (b - a)"
      by (intro mult_strict_left_mono) simp_all
    moreover from * have "0 < (d - c) * (x - a) / (b - a)"
      by simp
    ultimately have "f a b c d x < d" "c < f a b c d x"
      by (simp_all add: f_def field_simps)
  }
  with assms have "bij_betw (f a b c d) {a<..<b} {c<..<d}"
    by (intro bij_betw_byWitness[where f'="f c d a b"]) (auto simp: f_def)
  then show ?thesis by auto
qed

lemma bij_betw_tan: "bij_betw tan {-pi/2<..<pi/2} UNIV"
  using arctan_ubound by (intro bij_betw_byWitness[where f'=arctan]) (auto simp: arctan arctan_tan)

lemma uncountable_open_interval: "uncountable {a<..<b} \<longleftrightarrow> a < b" for a b :: real
proof
  show "a < b" if "uncountable {a<..<b}"
    using uncountable_def that by force
  show "uncountable {a<..<b}" if "a < b"
  proof -
    obtain f where "bij_betw f {a <..< b} {-pi/2<..<pi/2}"
      using bij_betw_open_intervals[OF \<open>a < b\<close>, of "-pi/2" "pi/2"] by auto
    then show ?thesis
      by (metis bij_betw_tan uncountable_bij_betw uncountable_UNIV_real)
  qed
qed

lemma uncountable_half_open_interval_1: "uncountable {a..<b} \<longleftrightarrow> a < b" for a b :: real
  apply auto
  using atLeastLessThan_empty_iff
  apply fastforce
  using uncountable_open_interval [of a b]
  apply (metis countable_Un_iff ivl_disj_un_singleton(3))
  done

lemma uncountable_half_open_interval_2: "uncountable {a<..b} \<longleftrightarrow> a < b" for a b :: real
  apply auto
  using atLeastLessThan_empty_iff
  apply fastforce
  using uncountable_open_interval [of a b]
  apply (metis countable_Un_iff ivl_disj_un_singleton(4))
  done

lemma real_interval_avoid_countable_set:
  fixes a b :: real and A :: "real set"
  assumes "a < b" and "countable A"
  shows "\<exists>x\<in>{a<..<b}. x \<notin> A"
proof -
  from \<open>countable A\<close> have *: "countable (A \<inter> {a<..<b})"
    by auto
  with \<open>a < b\<close> have "\<not> countable {a<..<b}"
    by (simp add: uncountable_open_interval)
  with * have "A \<inter> {a<..<b} \<noteq> {a<..<b}"
    by auto
  then have "A \<inter> {a<..<b} \<subset> {a<..<b}"
    by (intro psubsetI) auto
  then have "\<exists>x. x \<in> {a<..<b} - A \<inter> {a<..<b}"
    by (rule psubset_imp_ex_mem)
  then show ?thesis
    by auto
qed

lemma uncountable_closed_interval: "uncountable {a..b} \<longleftrightarrow> a < b" for a b :: real
  apply (rule iffI)
   apply (metis atLeastAtMost_singleton atLeastatMost_empty countable_finite finite.emptyI finite_insert linorder_neqE_linordered_idom)
  using real_interval_avoid_countable_set by fastforce

lemma open_minus_countable:
  fixes S A :: "real set"
  assumes "countable A" "S \<noteq> {}" "open S"
  shows "\<exists>x\<in>S. x \<notin> A"
proof -
  obtain x where "x \<in> S"
    using \<open>S \<noteq> {}\<close> by auto
  then obtain e where "0 < e" "{y. dist y x < e} \<subseteq> S"
    using \<open>open S\<close> by (auto simp: open_dist subset_eq)
  moreover have "{y. dist y x < e} = {x - e <..< x + e}"
    by (auto simp: dist_real_def)
  ultimately have "uncountable (S - A)"
    using uncountable_open_interval[of "x - e" "x + e"] \<open>countable A\<close>
    by (intro uncountable_minus_countable) (auto dest: countable_subset)
  then show ?thesis
    unfolding uncountable_def by auto
qed

end


(*  Title:      HOL/Isar_Examples/Summation.thy
    Author:     Markus Wenzel
*)

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

theory Summation
imports Main
begin

text \<open>Subsequently, we prove some summation laws of natural numbers
  (including odds, squares, and cubes).  These examples demonstrate
  how plain natural deduction (including induction) may be combined
  with calculational proof.\<close>

subsection \<open>Summation laws\<close>

text \<open>The sum of natural numbers $0 + \cdots + n$ equals $n \times
  (n + 1)/2$.  Avoiding formal reasoning about division we prove this
  equation multiplied by $2$.\<close>

theorem sum_of_naturals:
  "2 * (\<Sum>i::nat=0..n. i) = n * (n + 1)"
  (is "?P n" is "?S n = _")
proof (induct n)
  show "?P 0" by simp
next
  fix n have "?S (n + 1) = ?S n + 2 * (n + 1)"
    by simp
  also assume "?S n = n * (n + 1)"
  also have "\<dots> + 2 * (n + 1) = (n + 1) * (n + 2)"
    by simp
  finally show "?P (Suc n)"
    by simp
qed

text \<open>The above proof is a typical instance of mathematical
  induction.  The main statement is viewed as some $\var{P} \ap n$
  that is split by the induction method into base case $\var{P} \ap
  0$, and step case $\var{P} \ap n \Impl \var{P} \ap (\idt{Suc} \ap
  n)$ for arbitrary $n$.

  The step case is established by a short calculation in forward
  manner.  Starting from the left-hand side $\var{S} \ap (n + 1)$ of
  the thesis, the final result is achieved by transformations
  involving basic arithmetic reasoning (using the Simplifier).  The
  main point is where the induction hypothesis $\var{S} \ap n = n
  \times (n + 1)$ is introduced in order to replace a certain subterm.
  So the ``transitivity'' rule involved here is actual
  \emph{substitution}.  Also note how the occurrence of ``\dots'' in
  the subsequent step documents the position where the right-hand side
  of the hypothesis got filled in.

  \medskip A further notable point here is integration of calculations
  with plain natural deduction.  This works so well in Isar for two
  reasons.
  \begin{enumerate}

  \item Facts involved in \isakeyword{also}~/ \isakeyword{finally}
  calculational chains may be just anything.  There is nothing special
  about \isakeyword{have}, so the natural deduction element
  \isakeyword{assume} works just as well.

  \item There are two \emph{separate} primitives for building natural
  deduction contexts: \isakeyword{fix}~$x$ and
  \isakeyword{assume}~$A$.  Thus it is possible to start reasoning
  with some new ``arbitrary, but fixed'' elements before bringing in
  the actual assumption.  In contrast, natural deduction is
  occasionally formalized with basic context elements of the form
  $x:A$ instead.

  \end{enumerate}
\<close>

text \<open>\medskip We derive further summation laws for odds, squares,
  and cubes as follows.  The basic technique of induction plus
  calculation is the same as before.\<close>

theorem sum_of_odds:
  "(\<Sum>i::nat=0..<n. 2 * i + 1) = n^Suc (Suc 0)"
  (is "?P n" is "?S n = _")
proof (induct n)
  show "?P 0" by simp
next
  fix n
  have "?S (n + 1) = ?S n + 2 * n + 1"
    by simp
  also assume "?S n = n^Suc (Suc 0)"
  also have "\<dots> + 2 * n + 1 = (n + 1)^Suc (Suc 0)"
    by simp
  finally show "?P (Suc n)"
    by simp
qed

text \<open>Subsequently we require some additional tweaking of Isabelle
  built-in arithmetic simplifications, such as bringing in
  distributivity by hand.\<close>

lemmas distrib = add_mult_distrib add_mult_distrib2

theorem sum_of_squares:
  "6 * (\<Sum>i::nat=0..n. i^Suc (Suc 0)) = n * (n + 1) * (2 * n + 1)"
  (is "?P n" is "?S n = _")
proof (induct n)
  show "?P 0" by simp
next
  fix n
  have "?S (n + 1) = ?S n + 6 * (n + 1)^Suc (Suc 0)"
    by (simp add: distrib)
  also assume "?S n = n * (n + 1) * (2 * n + 1)"
  also have "\<dots> + 6 * (n + 1)^Suc (Suc 0) =
      (n + 1) * (n + 2) * (2 * (n + 1) + 1)"
    by (simp add: distrib)
  finally show "?P (Suc n)"
    by simp
qed

theorem sum_of_cubes:
  "4 * (\<Sum>i::nat=0..n. i^3) = (n * (n + 1))^Suc (Suc 0)"
  (is "?P n" is "?S n = _")
proof (induct n)
  show "?P 0" by (simp add: power_eq_if)
next
  fix n
  have "?S (n + 1) = ?S n + 4 * (n + 1)^3"
    by (simp add: power_eq_if distrib)
  also assume "?S n = (n * (n + 1))^Suc (Suc 0)"
  also have "\<dots> + 4 * (n + 1)^3 = ((n + 1) * ((n + 1) + 1))^Suc (Suc 0)"
    by (simp add: power_eq_if distrib)
  finally show "?P (Suc n)"
    by simp
qed

text \<open>Note that in contrast to older traditions of tactical proof
  scripts, the structured proof applies induction on the original,
  unsimplified statement.  This allows to state the induction cases
  robustly and conveniently.  Simplification (or other automated)
  methods are then applied in terminal position to solve certain
  sub-problems completely.

  As a general rule of good proof style, automatic methods such as
  $\idt{simp}$ or $\idt{auto}$ should normally be never used as
  initial proof methods with a nested sub-proof to address the
  automatically produced situation, but only as terminal ones to solve
  sub-problems.\<close>

end


(*  Title:      HOL/Library/Countable_Set.thy
    Author:     Johannes Hölzl
    Author:     Andrei Popescu
*)

section {* Countable sets *}

theory Countable_Set
imports Countable Infinite_Set
begin

subsection {* Predicate for countable sets *}

definition countable :: "'a set \<Rightarrow> bool" where
  "countable S \<longleftrightarrow> (\<exists>f::'a \<Rightarrow> nat. inj_on f S)"

lemma countableE:
  assumes S: "countable S" obtains f :: "'a \<Rightarrow> nat" where "inj_on f S"
  using S by (auto simp: countable_def)

lemma countableI: "inj_on (f::'a \<Rightarrow> nat) S \<Longrightarrow> countable S"
  by (auto simp: countable_def)

lemma countableI': "inj_on (f::'a \<Rightarrow> 'b::countable) S \<Longrightarrow> countable S"
  using comp_inj_on[of f S to_nat] by (auto intro: countableI)

lemma countableE_bij:
  assumes S: "countable S" obtains f :: "nat \<Rightarrow> 'a" and C :: "nat set" where "bij_betw f C S"
  using S by (blast elim: countableE dest: inj_on_imp_bij_betw bij_betw_inv)

lemma countableI_bij: "bij_betw f (C::nat set) S \<Longrightarrow> countable S"
  by (blast intro: countableI bij_betw_inv_into bij_betw_imp_inj_on)

lemma countable_finite: "finite S \<Longrightarrow> countable S"
  by (blast dest: finite_imp_inj_to_nat_seg countableI)

lemma countableI_bij1: "bij_betw f A B \<Longrightarrow> countable A \<Longrightarrow> countable B"
  by (blast elim: countableE_bij intro: bij_betw_trans countableI_bij)

lemma countableI_bij2: "bij_betw f B A \<Longrightarrow> countable A \<Longrightarrow> countable B"
  by (blast elim: countableE_bij intro: bij_betw_trans bij_betw_inv_into countableI_bij)

lemma countable_iff_bij[simp]: "bij_betw f A B \<Longrightarrow> countable A \<longleftrightarrow> countable B"
  by (blast intro: countableI_bij1 countableI_bij2)

lemma countable_subset: "A \<subseteq> B \<Longrightarrow> countable B \<Longrightarrow> countable A"
  by (auto simp: countable_def intro: subset_inj_on)

lemma countableI_type[intro, simp]: "countable (A:: 'a :: countable set)"
  using countableI[of to_nat A] by auto

subsection {* Enumerate a countable set *}

lemma countableE_infinite:
  assumes "countable S" "infinite S"
  obtains e :: "'a \<Rightarrow> nat" where "bij_betw e S UNIV"
proof -
  obtain f :: "'a \<Rightarrow> nat" where "inj_on f S"
    using `countable S` by (rule countableE)
  then have "bij_betw f S (f`S)"
    unfolding bij_betw_def by simp
  moreover
  from `inj_on f S` `infinite S` have inf_fS: "infinite (f`S)"
    by (auto dest: finite_imageD)
  then have "bij_betw (the_inv_into UNIV (enumerate (f`S))) (f`S) UNIV"
    by (intro bij_betw_the_inv_into bij_enumerate)
  ultimately have "bij_betw (the_inv_into UNIV (enumerate (f`S)) \<circ> f) S UNIV"
    by (rule bij_betw_trans)
  then show thesis ..
qed

lemma countable_enum_cases:
  assumes "countable S"
  obtains (finite) f :: "'a \<Rightarrow> nat" where "finite S" "bij_betw f S {..<card S}"
        | (infinite) f :: "'a \<Rightarrow> nat" where "infinite S" "bij_betw f S UNIV"
  using ex_bij_betw_finite_nat[of S] countableE_infinite `countable S`
  by (cases "finite S") (auto simp add: atLeast0LessThan)

definition to_nat_on :: "'a set \<Rightarrow> 'a \<Rightarrow> nat" where
  "to_nat_on S = (SOME f. if finite S then bij_betw f S {..< card S} else bij_betw f S UNIV)"

definition from_nat_into :: "'a set \<Rightarrow> nat \<Rightarrow> 'a" where
  "from_nat_into S n = (if n \<in> to_nat_on S ` S then inv_into S (to_nat_on S) n else SOME s. s\<in>S)"

lemma to_nat_on_finite: "finite S \<Longrightarrow> bij_betw (to_nat_on S) S {..< card S}"
  using ex_bij_betw_finite_nat unfolding to_nat_on_def
  by (intro someI2_ex[where Q="\<lambda>f. bij_betw f S {..<card S}"]) (auto simp add: atLeast0LessThan)

lemma to_nat_on_infinite: "countable S \<Longrightarrow> infinite S \<Longrightarrow> bij_betw (to_nat_on S) S UNIV"
  using countableE_infinite unfolding to_nat_on_def
  by (intro someI2_ex[where Q="\<lambda>f. bij_betw f S UNIV"]) auto

lemma bij_betw_from_nat_into_finite: "finite S \<Longrightarrow> bij_betw (from_nat_into S) {..< card S} S"
  unfolding from_nat_into_def[abs_def]
  using to_nat_on_finite[of S]
  apply (subst bij_betw_cong)
  apply (split split_if)
  apply (simp add: bij_betw_def)
  apply (auto cong: bij_betw_cong
              intro: bij_betw_inv_into to_nat_on_finite)
  done

lemma bij_betw_from_nat_into: "countable S \<Longrightarrow> infinite S \<Longrightarrow> bij_betw (from_nat_into S) UNIV S"
  unfolding from_nat_into_def[abs_def]
  using to_nat_on_infinite[of S, unfolded bij_betw_def]
  by (auto cong: bij_betw_cong intro: bij_betw_inv_into to_nat_on_infinite)

lemma inj_on_to_nat_on[intro]: "countable A \<Longrightarrow> inj_on (to_nat_on A) A"
  using to_nat_on_infinite[of A] to_nat_on_finite[of A]
  by (cases "finite A") (auto simp: bij_betw_def)

lemma to_nat_on_inj[simp]:
  "countable A \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> to_nat_on A a = to_nat_on A b \<longleftrightarrow> a = b"
  using inj_on_to_nat_on[of A] by (auto dest: inj_onD)

lemma from_nat_into_to_nat_on[simp]: "countable A \<Longrightarrow> a \<in> A \<Longrightarrow> from_nat_into A (to_nat_on A a) = a"
  by (auto simp: from_nat_into_def intro!: inv_into_f_f)

lemma subset_range_from_nat_into: "countable A \<Longrightarrow> A \<subseteq> range (from_nat_into A)"
  by (auto intro: from_nat_into_to_nat_on[symmetric])

lemma from_nat_into: "A \<noteq> {} \<Longrightarrow> from_nat_into A n \<in> A"
  unfolding from_nat_into_def by (metis equals0I inv_into_into someI_ex)

lemma range_from_nat_into_subset: "A \<noteq> {} \<Longrightarrow> range (from_nat_into A) \<subseteq> A"
  using from_nat_into[of A] by auto

lemma range_from_nat_into[simp]: "A \<noteq> {} \<Longrightarrow> countable A \<Longrightarrow> range (from_nat_into A) = A"
  by (metis equalityI range_from_nat_into_subset subset_range_from_nat_into)

lemma image_to_nat_on: "countable A \<Longrightarrow> infinite A \<Longrightarrow> to_nat_on A ` A = UNIV"
  using to_nat_on_infinite[of A] by (simp add: bij_betw_def)

lemma to_nat_on_surj: "countable A \<Longrightarrow> infinite A \<Longrightarrow> \<exists>a\<in>A. to_nat_on A a = n"
  by (metis (no_types) image_iff iso_tuple_UNIV_I image_to_nat_on)

lemma to_nat_on_from_nat_into[simp]: "n \<in> to_nat_on A ` A \<Longrightarrow> to_nat_on A (from_nat_into A n) = n"
  by (simp add: f_inv_into_f from_nat_into_def)

lemma to_nat_on_from_nat_into_infinite[simp]:
  "countable A \<Longrightarrow> infinite A \<Longrightarrow> to_nat_on A (from_nat_into A n) = n"
  by (metis image_iff to_nat_on_surj to_nat_on_from_nat_into)

lemma from_nat_into_inj:
  "countable A \<Longrightarrow> m \<in> to_nat_on A ` A \<Longrightarrow> n \<in> to_nat_on A ` A \<Longrightarrow>
    from_nat_into A m = from_nat_into A n \<longleftrightarrow> m = n"
  by (subst to_nat_on_inj[symmetric, of A]) auto

lemma from_nat_into_inj_infinite[simp]:
  "countable A \<Longrightarrow> infinite A \<Longrightarrow> from_nat_into A m = from_nat_into A n \<longleftrightarrow> m = n"
  using image_to_nat_on[of A] from_nat_into_inj[of A m n] by simp

lemma eq_from_nat_into_iff:
  "countable A \<Longrightarrow> x \<in> A \<Longrightarrow> i \<in> to_nat_on A ` A \<Longrightarrow> x = from_nat_into A i \<longleftrightarrow> i = to_nat_on A x"
  by auto

lemma from_nat_into_surj: "countable A \<Longrightarrow> a \<in> A \<Longrightarrow> \<exists>n. from_nat_into A n = a"
  by (rule exI[of _ "to_nat_on A a"]) simp

lemma from_nat_into_inject[simp]:
  "A \<noteq> {} \<Longrightarrow> countable A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> countable B \<Longrightarrow> from_nat_into A = from_nat_into B \<longleftrightarrow> A = B"
  by (metis range_from_nat_into)

lemma inj_on_from_nat_into: "inj_on from_nat_into ({A. A \<noteq> {} \<and> countable A})"
  unfolding inj_on_def by auto

subsection {* Closure properties of countability *}

lemma countable_SIGMA[intro, simp]:
  "countable I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> countable (A i)) \<Longrightarrow> countable (SIGMA i : I. A i)"
  by (intro countableI'[of "\<lambda>(i, a). (to_nat_on I i, to_nat_on (A i) a)"]) (auto simp: inj_on_def)

lemma countable_image[intro, simp]:
  assumes "countable A"
  shows "countable (f`A)"
proof -
  obtain g :: "'a \<Rightarrow> nat" where "inj_on g A"
    using assms by (rule countableE)
  moreover have "inj_on (inv_into A f) (f`A)" "inv_into A f ` f ` A \<subseteq> A"
    by (auto intro: inj_on_inv_into inv_into_into)
  ultimately show ?thesis
    by (blast dest: comp_inj_on subset_inj_on intro: countableI)
qed

lemma countable_UN[intro, simp]:
  fixes I :: "'i set" and A :: "'i => 'a set"
  assumes I: "countable I"
  assumes A: "\<And>i. i \<in> I \<Longrightarrow> countable (A i)"
  shows "countable (\<Union>i\<in>I. A i)"
proof -
  have "(\<Union>i\<in>I. A i) = snd ` (SIGMA i : I. A i)" by (auto simp: image_iff)
  then show ?thesis by (simp add: assms)
qed

lemma countable_Un[intro]: "countable A \<Longrightarrow> countable B \<Longrightarrow> countable (A \<union> B)"
  by (rule countable_UN[of "{True, False}" "\<lambda>True \<Rightarrow> A | False \<Rightarrow> B", simplified])
     (simp split: bool.split)

lemma countable_Un_iff[simp]: "countable (A \<union> B) \<longleftrightarrow> countable A \<and> countable B"
  by (metis countable_Un countable_subset inf_sup_ord(3,4))

lemma countable_Plus[intro, simp]:
  "countable A \<Longrightarrow> countable B \<Longrightarrow> countable (A <+> B)"
  by (simp add: Plus_def)

lemma countable_empty[intro, simp]: "countable {}"
  by (blast intro: countable_finite)

lemma countable_insert[intro, simp]: "countable A \<Longrightarrow> countable (insert a A)"
  using countable_Un[of "{a}" A] by (auto simp: countable_finite)

lemma countable_Int1[intro, simp]: "countable A \<Longrightarrow> countable (A \<inter> B)"
  by (force intro: countable_subset)

lemma countable_Int2[intro, simp]: "countable B \<Longrightarrow> countable (A \<inter> B)"
  by (blast intro: countable_subset)

lemma countable_INT[intro, simp]: "i \<in> I \<Longrightarrow> countable (A i) \<Longrightarrow> countable (\<Inter>i\<in>I. A i)"
  by (blast intro: countable_subset)

lemma countable_Diff[intro, simp]: "countable A \<Longrightarrow> countable (A - B)"
  by (blast intro: countable_subset)

lemma countable_vimage: "B \<subseteq> range f \<Longrightarrow> countable (f -` B) \<Longrightarrow> countable B"
  by (metis Int_absorb2 assms countable_image image_vimage_eq)

lemma surj_countable_vimage: "surj f \<Longrightarrow> countable (f -` B) \<Longrightarrow> countable B"
  by (metis countable_vimage top_greatest)

lemma countable_Collect[simp]: "countable A \<Longrightarrow> countable {a \<in> A. \<phi> a}"
  by (metis Collect_conj_eq Int_absorb Int_commute Int_def countable_Int1)

lemma countable_Image:
  assumes "\<And>y. y \<in> Y \<Longrightarrow> countable (X `` {y})"
  assumes "countable Y"
  shows "countable (X `` Y)"
proof -
  have "countable (X `` (\<Union>y\<in>Y. {y}))"
    unfolding Image_UN by (intro countable_UN assms)
  then show ?thesis by simp
qed

lemma countable_relpow:
  fixes X :: "'a rel"
  assumes Image_X: "\<And>Y. countable Y \<Longrightarrow> countable (X `` Y)"
  assumes Y: "countable Y"
  shows "countable ((X ^^ i) `` Y)"
  using Y by (induct i arbitrary: Y) (auto simp: relcomp_Image Image_X)

lemma countable_rtrancl:
  "(\<And>Y. countable Y \<Longrightarrow> countable (X `` Y)) \<Longrightarrow> countable Y \<Longrightarrow> countable (X^* `` Y)"
  unfolding rtrancl_is_UN_relpow UN_Image by (intro countable_UN countableI_type countable_relpow)

lemma countable_lists[intro, simp]:
  assumes A: "countable A" shows "countable (lists A)"
proof -
  have "countable (lists (range (from_nat_into A)))"
    by (auto simp: lists_image)
  with A show ?thesis
    by (auto dest: subset_range_from_nat_into countable_subset lists_mono)
qed

lemma Collect_finite_eq_lists: "Collect finite = set ` lists UNIV"
  using finite_list by auto

lemma countable_Collect_finite: "countable (Collect (finite::'a::countable set\<Rightarrow>bool))"
  by (simp add: Collect_finite_eq_lists)

lemma countable_rat: "countable \<rat>"
  unfolding Rats_def by auto

lemma Collect_finite_subset_eq_lists: "{A. finite A \<and> A \<subseteq> T} = set ` lists T"
  using finite_list by (auto simp: lists_eq_set)

lemma countable_Collect_finite_subset:
  "countable T \<Longrightarrow> countable {A. finite A \<and> A \<subseteq> T}"
  unfolding Collect_finite_subset_eq_lists by auto

subsection {* Misc lemmas *}

lemma countable_all:
  assumes S: "countable S"
  shows "(\<forall>s\<in>S. P s) \<longleftrightarrow> (\<forall>n::nat. from_nat_into S n \<in> S \<longrightarrow> P (from_nat_into S n))"
  using S[THEN subset_range_from_nat_into] by auto

lemma finite_sequence_to_countable_set:
   assumes "countable X" obtains F where "\<And>i. F i \<subseteq> X" "\<And>i. F i \<subseteq> F (Suc i)" "\<And>i. finite (F i)" "(\<Union>i. F i) = X"
proof -  show thesis
    apply (rule that[of "\<lambda>i. if X = {} then {} else from_nat_into X ` {..i}"])
    apply (auto simp: image_iff Ball_def intro: from_nat_into split: split_if_asm)
  proof -
    fix x n assume "x \<in> X" "\<forall>i m. m \<le> i \<longrightarrow> x \<noteq> from_nat_into X m"
    with from_nat_into_surj[OF `countable X` `x \<in> X`]
    show False
      by auto
  qed
qed

subsection {* Uncountable *}

abbreviation uncountable where
  "uncountable A \<equiv> \<not> countable A"

lemma uncountable_def: "uncountable A \<longleftrightarrow> A \<noteq> {} \<and> \<not> (\<exists>f::(nat \<Rightarrow> 'a). range f = A)"
  by (auto intro: inj_on_inv_into simp: countable_def)
     (metis all_not_in_conv inj_on_iff_surj subset_UNIV)

lemma uncountable_bij_betw: "bij_betw f A B \<Longrightarrow> uncountable B \<Longrightarrow> uncountable A"
  unfolding bij_betw_def by (metis countable_image)

lemma uncountable_infinite: "uncountable A \<Longrightarrow> infinite A"
  by (metis countable_finite)

lemma uncountable_minus_countable:
  "uncountable A \<Longrightarrow> countable B \<Longrightarrow> uncountable (A - B)"
  using countable_Un[of B "A - B"] assms by auto

end


theory Ex2_2
imports Main
begin

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

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

lemma add_asso: "add (add x y) z = add x (add y z)"
apply(induction x)
apply(auto)
done

lemma add_comm2[simp]: "Suc (add x y) = add x (Suc y)"
apply(induction x)
apply(auto)
done

lemma add_comm: "(add x y) = (add y x)"
apply(induction x)
apply auto
done

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

lemma double_add : "double x = add x x"
apply(induction x)
apply(auto)
done

end


(*  Title:      HOL/Computational_Algebra/Group_Closure.thy
    Author:     Johannes Hoelzl, TU Muenchen
    Author:     Florian Haftmann, TU Muenchen
*)

theory Group_Closure
imports
  MainRLT
begin

context ab_group_add
begin

inductive_set group_closure :: "'a set \<Rightarrow> 'a set" for S
  where base: "s \<in> insert 0 S \<Longrightarrow> s \<in> group_closure S"
| diff: "s \<in> group_closure S \<Longrightarrow> t \<in> group_closure S \<Longrightarrow> s - t \<in> group_closure S"

lemma zero_in_group_closure [simp]:
  "0 \<in> group_closure S"
  using group_closure.base [of 0 S] by simp

lemma group_closure_minus_iff [simp]:
  "- s \<in> group_closure S \<longleftrightarrow> s \<in> group_closure S"
  using group_closure.diff [of 0 S s] group_closure.diff [of 0 S "- s"] by auto

lemma group_closure_add:
  "s + t \<in> group_closure S" if "s \<in> group_closure S" and "t \<in> group_closure S"
  using that group_closure.diff [of s S "- t"] by auto

lemma group_closure_empty [simp]:
  "group_closure {} = {0}"
  by (rule ccontr) (auto elim: group_closure.induct)

lemma group_closure_insert_zero [simp]:
  "group_closure (insert 0 S) = group_closure S"
  by (auto elim: group_closure.induct intro: group_closure.intros)

end

context comm_ring_1
begin

lemma group_closure_scalar_mult_left:
  "of_nat n * s \<in> group_closure S" if "s \<in> group_closure S"
  using that by (induction n) (auto simp add: algebra_simps intro: group_closure_add)

lemma group_closure_scalar_mult_right:
  "s * of_nat n \<in> group_closure S" if "s \<in> group_closure S"
  using that group_closure_scalar_mult_left [of s S n] by (simp add: ac_simps)

end

lemma group_closure_abs_iff [simp]:
  "\<bar>s\<bar> \<in> group_closure S \<longleftrightarrow> s \<in> group_closure S" for s :: int
  by (simp add: abs_if)

lemma group_closure_mult_left:
  "s * t \<in> group_closure S" if "s \<in> group_closure S" for s t :: int
proof -
  from that group_closure_scalar_mult_right [of s S "nat \<bar>t\<bar>"]
    have "s * int (nat \<bar>t\<bar>) \<in> group_closure S"
    by (simp only:)
  then show ?thesis
    by (cases "t \<ge> 0") simp_all
qed

lemma group_closure_mult_right:
  "s * t \<in> group_closure S" if "t \<in> group_closure S" for s t :: int
  using that group_closure_mult_left [of t S s] by (simp add: ac_simps)

context idom
begin

lemma group_closure_mult_all_eq:
  "group_closure (times k ` S) = times k ` group_closure S"
proof (rule; rule)
  fix s
  have *: "k * a + k * b = k * (a + b)"
    "k * a - k * b = k * (a - b)" for a b
    by (simp_all add: algebra_simps)
  assume "s \<in> group_closure (times k ` S)"
  then show "s \<in> times k ` group_closure S"
    by induction (auto simp add: * image_iff intro: group_closure.base group_closure.diff bexI [of _ 0])
next
  fix s
  assume "s \<in> times k ` group_closure S"
  then obtain r where r: "r \<in> group_closure S" and s: "s = k * r"
    by auto
  from r have "k * r \<in> group_closure (times k ` S)"
    by (induction arbitrary: s) (auto simp add: algebra_simps intro: group_closure.intros)
  with s show "s \<in> group_closure (times k ` S)"
    by simp
qed

end

lemma Gcd_group_closure_eq_Gcd:
  "Gcd (group_closure S) = Gcd S" for S :: "int set"
proof (rule associated_eqI)
  have "Gcd S dvd s" if "s \<in> group_closure S" for s
    using that by induction auto
  then show "Gcd S dvd Gcd (group_closure S)"
    by auto
  have "Gcd (group_closure S) dvd s" if "s \<in> S" for s
  proof -
    from that have "s \<in> group_closure S"
      by (simp add: group_closure.base)
    then show ?thesis
      by (rule Gcd_dvd)
  qed
  then show "Gcd (group_closure S) dvd Gcd S"
    by auto
qed simp_all

lemma group_closure_sum:
  fixes S :: "int set"
  assumes X: "finite X" "X \<noteq> {}" "X \<subseteq> S"
  shows "(\<Sum>x\<in>X. a x * x) \<in> group_closure S"
  using X by (induction X rule: finite_ne_induct)
    (auto intro: group_closure_mult_right group_closure.base group_closure_add)

lemma Gcd_group_closure_in_group_closure:
  "Gcd (group_closure S) \<in> group_closure S" for S :: "int set"
proof (cases "S \<subseteq> {0}")
  case True
  then have "S = {} \<or> S = {0}"
    by auto
  then show ?thesis
    by auto
next
  case False
  then obtain s where s: "s \<noteq> 0" "s \<in> S"
    by auto
  then have s': "\<bar>s\<bar> \<noteq> 0" "\<bar>s\<bar> \<in> group_closure S"
    by (auto intro: group_closure.base)
  define m where "m = (LEAST n. n > 0 \<and> int n \<in> group_closure S)"
  have "m > 0 \<and> int m \<in> group_closure S"
    unfolding m_def
    apply (rule LeastI [of _ "nat \<bar>s\<bar>"])
    using s'
    by simp
  then have m: "int m \<in> group_closure S" and "0 < m"
    by auto

  have "Gcd (group_closure S) = int m"
  proof (rule associated_eqI)
    from m show "Gcd (group_closure S) dvd int m"
      by (rule Gcd_dvd)
    show "int m dvd Gcd (group_closure S)"
    proof (rule Gcd_greatest)
      fix s
      assume s: "s \<in> group_closure S"
      show "int m dvd s"
      proof (rule ccontr)
        assume "\<not> int m dvd s"
        then have *: "0 < s mod int m"
          using \<open>0 < m\<close> le_less by fastforce
        have "m \<le> nat (s mod int m)"
        proof (subst m_def, rule Least_le, rule)
          from * show "0 < nat (s mod int m)"
            by simp
          from minus_div_mult_eq_mod [symmetric, of s "int m"]
          have "s mod int m = s - s div int m * int m"
            by auto
          also have "s - s div int m * int m \<in> group_closure S"
            by (auto intro: group_closure.diff s group_closure_mult_right m)
          finally  show "int (nat (s mod int m)) \<in> group_closure S"
            by simp
        qed
        with * have "int m \<le> s mod int m"
          by simp
        moreover have "s mod int m < int m"
          using \<open>0 < m\<close> by simp
        ultimately show False
          by auto
      qed
    qed
  qed simp_all
  with m show ?thesis
    by simp
qed

lemma Gcd_in_group_closure:
  "Gcd S \<in> group_closure S" for S :: "int set"
  using Gcd_group_closure_in_group_closure [of S]
  by (simp add: Gcd_group_closure_eq_Gcd)

lemma group_closure_eq:
  "group_closure S = range (times (Gcd S))" for S :: "int set"
proof (auto intro: Gcd_in_group_closure group_closure_mult_left)
  fix s
  assume "s \<in> group_closure S"
  then show "s \<in> range (times (Gcd S))"
  proof induction
    case (base s)
    then have "Gcd S dvd s"
      by (auto intro: Gcd_dvd)
    then obtain t where "s = Gcd S * t" ..
    then show ?case
      by auto
  next
    case (diff s t)
    moreover have "Gcd S * a - Gcd S * b = Gcd S * (a - b)" for a b
      by (simp add: algebra_simps)
    ultimately show ?case
      by auto
  qed
qed

end


theory Highorder_Func
  imports Main HOL.Real
begin

subsection \<open>first and high order functions\<close>

definition fof1 :: "nat \<Rightarrow> nat"
  where "fof1 x \<equiv> x ^ 2"

value "fof1 2"

fun fof2 :: "(nat \<times> nat) \<Rightarrow> nat"
  where "fof2 (x,y) = x + y"

value "fof2 (2,3)"

fun fof3 :: "(nat \<times> nat \<times> nat) \<Rightarrow> nat"
  where "fof3 (x,y,z) = x + y * z"

value "fof3 (2,3,4)"

definition arith :: "(int \<Rightarrow> int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int"
  where "arith ops x y \<equiv> ops x y"

value "arith plus 10 20"
value "arith minus 10 20"

definition hof1 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c"
  where "hof1 f x y \<equiv> f x y"

value "hof1 plus (1::int) 2"
value "hof1 times (3::int) 4"
value "hof1 plus (1.5::real) 2"
value "hof1 append ''hello'' ''world''"
value "hof1 append [a,b,c] [e,f,g]"

subsection \<open>types of high-order functions\<close>

type_synonym ('a,'b,'c,'d) hoftype0 = "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd"
type_synonym ('a,'b,'c,'d) hoftype1 = "'a \<Rightarrow> ('b \<Rightarrow> ('c \<Rightarrow> 'd))"
type_synonym ('a,'b,'c,'d) hoftype2 = "(('a \<Rightarrow> 'b) \<Rightarrow> 'c) \<Rightarrow> 'd"
type_synonym ('a,'b,'c,'d) hoftype3 = "('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd)"
type_synonym ('a,'b,'c,'d) hoftype4 = "('a \<Rightarrow> 'b) \<Rightarrow> 'c \<Rightarrow> 'd"

definition hoft0 :: "(int, int, int, int) hoftype0"
  where "hoft0 \<equiv> (\<lambda>a. \<lambda>b. \<lambda>c. a + b + c)"

definition hoft1 :: "(int, int, int, int) hoftype1"
  where "hoft1 \<equiv> (\<lambda>a. \<lambda>b. \<lambda>c. a + b + c)"

definition hoft2 :: "(int, int, int, int) hoftype2"
  where "hoft2 \<equiv> \<lambda>f. 1"

definition hoft3 :: "(int, int, int, int) hoftype3"
  where "hoft3 \<equiv> (\<lambda>f. (\<lambda>x. f x + 1))"

definition hoft4 :: "(int, int, int, int) hoftype4"
  where "hoft4 \<equiv> (\<lambda>f. \<lambda>x. f x + 1)"

subsection \<open>definition and usage of high-order functions\<close>
definition hof2 :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'c)"
  where "hof2 x f \<equiv> f x"

term "hof2 (1::int) plus"
term "hof2 (2::int) plus"

lemma "hof2 (1::int) plus = (\<lambda>x. x + 1)"
  unfolding hof2_def by auto

lemma "hof2 (2::int) plus = (\<lambda>x. x + 2)"
  unfolding hof2_def by auto

lemma "hof2 (m::nat) plus = (\<lambda>x. x + m)"
  unfolding hof2_def by auto

lemma "hof2 (n::nat) times = (\<lambda>x. x * n)"
  unfolding hof2_def by auto

type_synonym hoftype = "real \<Rightarrow> real"
definition limit :: "(real \<Rightarrow> real) \<Rightarrow> real \<Rightarrow> real \<Rightarrow> bool"
  where "limit f x\<^sub>0 A \<equiv>
    \<forall>(\<epsilon>::real)>0. (\<exists>\<delta>>0. (\<forall>x. 0 < \<bar>x - x\<^sub>0\<bar> \<and> \<bar>x - x\<^sub>0\<bar> < \<delta>
                                \<longrightarrow> \<bar>f(x) - A\<bar> < \<epsilon>))"

primrec map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list"
  where "map f [] = []" |
        "map f (x # xs) = f x # map f xs"

definition "f1 x \<equiv> x^2"
definition "l1 \<equiv> [1::int, 2, 3, 4, 5, 6]"
value "map f1 l1"

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

definition "f2 x \<equiv> (2 dvd x)"
definition "l2 \<equiv> [(1::int)..20]"
value "filter f2 l2"

primrec fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b"
  where "fold f [] = id" |
        "fold f (x # xs) = fold f xs \<circ> f x"

primrec foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b"
  where "foldr f [] = id" |
        "foldr f (x # xs) = f x \<circ> foldr f xs"

definition ff :: "int \<Rightarrow> nat \<Rightarrow> nat"
  where "ff i \<equiv> (\<lambda>x. x + nat i)"

definition "f4 \<equiv> fold ff [1..3]"
definition "f5 \<equiv> foldr ff [1..3]"

lemma "f4 = (ff 3) \<circ> (ff 2) \<circ> (ff 1)"
  unfolding f4_def using upto.simps fold.simps(1) fold.simps(2) by force

lemma "f5 = (ff 1) \<circ> (ff 2) \<circ> (ff 3)"
  unfolding f5_def using upto.simps foldr.simps(1) foldr.simps(2) by force

lemma "f4 = (\<lambda>x. x + 6)"
  unfolding f4_def ff_def using upto.simps fold.simps(1) fold.simps(2) by force

lemma "f5 = (\<lambda>x. x + 6)"
  unfolding f5_def ff_def using upto.simps fold.simps(1) fold.simps(2) by force

value "f4 1"
value "f5 1"

primrec foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b"
  where "foldl f a [] = a" |
        "foldl f a (x # xs) = foldl f (f a x) xs"

value "foldl plus 123 [1..10]"

subsection \<open>Map Reduce implementation\<close>

definition MapReduce ::
  "'a list \<Rightarrow> \<comment> \<open> input \<close>
    ('a \<Rightarrow> ('k1 \<times>'v1) list) \<Rightarrow>  \<comment> \<open> mapping \<close>
    (('k1 \<times>'v1) list list \<Rightarrow> ('k2 \<times> ('v2 list)) list) \<Rightarrow>  \<comment> \<open> shuffling \<close>
    (('k2 \<times> ('v2 list)) \<Rightarrow> ('k2 \<times> 'v2)) \<Rightarrow>  \<comment> \<open> reducing \<close>
    ('k2 \<times> 'v2) list"
  where "MapReduce input m spl r \<equiv> map r (spl (map m input))"

type_synonym webpage = "string list"

fun split0 :: "string \<Rightarrow> webpage \<Rightarrow> webpage"
  where "split0 (x#y#xs) l =
          (if l = [] then
             if x \<noteq> CHR '' '' then split0 (y#xs) [[x]]
             else split0 (y#xs) l
           else
             if x = CHR '' '' then
                if y = CHR '' '' then split0 xs l
                else split0 xs (l@[[y]])
             else
                if y = CHR '' '' then
                  split0 (y#xs) (butlast l@[last l @[x]])
                else
                  split0 xs (butlast l@[last l @[x,y]]))" |
        "split0 [x] l = (if l = [] then [[x]]
                        else butlast l@[last l @[x]])" |
        "split0 [] l = l"

definition "split s \<equiv> split0 s []"

value "split ''This is the first article, it has 100 words, these are bus and car ...''"

primrec countword ::
  "string \<Rightarrow> (string \<times> nat) list
          \<Rightarrow> (string \<times> nat) list"
  where "countword s [] = [(s,1)]" |
        "countword s (x # xs) =
            (if fst x = s then
              (fst x, snd x + 1) # xs
            else x # (countword s xs))"

primrec countwebpage ::
  "webpage \<Rightarrow> (string \<times> nat) list
           \<Rightarrow> (string \<times> nat) list"
  where "countwebpage [] kvs = kvs" |
        "countwebpage (x # xs) kvs =
            (let kvs1 = countword x kvs in countwebpage xs kvs1)"

definition mapper :: "webpage \<Rightarrow> (string \<times> nat) list"
  where "mapper a \<equiv> countwebpage a []"

primrec shuffword ::
  "(string \<times> nat) \<Rightarrow> (string \<times> (nat list)) list
                  \<Rightarrow> (string \<times> (nat list)) list"
  where "shuffword kv [] = [(fst kv, [snd kv])]" |
        "shuffword kv (x # xs) =
            (if fst kv = fst x then
              (fst x, (snd kv) # (snd x))#xs
             else x # (shuffword kv xs))"

primrec shuffwords ::
  "(string \<times> nat) list \<Rightarrow> (string \<times> (nat list)) list
                        \<Rightarrow> (string \<times> (nat list)) list"
  where "shuffwords [] kvs = kvs" |
        "shuffwords (x # xs) kvs = shuffwords xs (shuffword x kvs)"

primrec shuffall ::
  "(string \<times> nat) list list \<Rightarrow> (string \<times> (nat list)) list
                            \<Rightarrow> (string \<times> (nat list)) list"
  where "shuffall [] kvs = kvs" |
        "shuffall (x # xs) kvs = shuffall xs (shuffwords x kvs)"

definition "shuff l \<equiv> shuffall l []"
(*
definition reducer :: "string \<times> (nat list) \<Rightarrow> (string \<times> nat)"
  where "reducer kvs \<equiv> (fst kvs, sum_list (snd kvs))"*)
fun reducer :: "string \<times> (nat list) \<Rightarrow> (string \<times> nat)"
  where "reducer (k,vlist) = (k, foldl plus 0 vlist)"

definition news :: "webpage list"
  where "news \<equiv> [split ''This is the first article, it has 100 words, these are bus and car ...'',
                 split ''This is the second article, it has 1000 words, The These are train and plane and car'',
                 split ''Those are plane and bus'']"

value "split ''Those are plane and bus''"
value "MapReduce news mapper shuff reducer"

definition webpages0 :: "webpage list"
  where "webpages0 \<equiv> [split ''Bus Car Train'',
                     split ''Train Plane Car'',
                     split ''Bus Bus Plane'']"

definition webpages :: "webpage list"
  where "webpages \<equiv> [split ''Dear Bear River'',
                     split ''Car Car River'',
                     split ''Dear Car Bear'']"

value "webpages"
value "map mapper webpages"
value "shuff (map mapper webpages)"
value "MapReduce webpages mapper shuff reducer"

subsection \<open>curring\<close>

fun concat2 :: "(string \<times> string) \<Rightarrow> string"
  where "concat2 (x,y) = x@y"

fun concat3 :: "(string \<times> string \<times> string) \<Rightarrow> string"
  where "concat3 (x,y,z) = x@y@z"

value "concat2 (''aaa'',''bbb'')"
value "concat3 (''aaa'',''bbb'',''ccc'')"

definition "concat2c \<equiv> curry concat2"
definition "concat3c \<equiv> curry concat3"

term "concat2c"
term "concat3c"

definition "concathello \<equiv> concat2c ''hello''"

value "concathello ''world''"

value "curry concat2 ''hello'' ''world''"

term "curry (concat3c ''hello'')"

fun concat2c' :: "string \<Rightarrow> string \<Rightarrow> string"
  where "concat2c' x y = x@y"

fun concat3c' :: "string \<Rightarrow> string \<Rightarrow> string \<Rightarrow> string"
  where "concat3c' x y z = x@y@z"

definition "concat2' \<equiv> case_prod concat2c'"
definition "concat3' \<equiv> case_prod concat3c'"
definition "concat3'' \<equiv> case_prod concat3'"

term "concat2'"
term "concat3'"
term "concat3''"

lemma "concat2' (x,y) = concat2 (x,y)"
  using concat2c'.simps concat2.simps
    by (simp add: concat2'_def)

lemma "concat3'' ((x,y),z) = concat3 (x,y,z)"
  using concat3c'.simps concat3.simps
    by (simp add:concat3''_def concat3'_def)

fun add0 :: "(int \<times> int) \<Rightarrow> int"
  where "add0 (x,y) = x + y"

value "add0 (10,23)"

fun add1 :: "int \<Rightarrow> int \<Rightarrow> int"
  where "add1 x y = x + y"

(*definition curry :: "('a \<times> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c"
  where "curry g x y = g (x, y)"
*)

term "curry add0"
term "case_prod add1"

lemma "add1 = curry add0"
  using add0.simps add1.simps curry_def by force

lemma "add0 = case_prod add1"
  using add0.simps add1.simps by force

lemma "case_prod (curry f) = f"
  by auto

lemma "curry (case_prod f) = f"
  by auto

fun addxyz :: "(int \<times> int \<times> int) \<Rightarrow> int"
  where "addxyz (x,y,z) = x + y + z"

term "curry addxyz"
term "curry addxyz 1"

lemma "curry addxyz 1 = (\<lambda> (x,y). x + y +1)"
  using addxyz.simps curry_def by force

fun addxyz2 :: "((int \<times> int) \<times> int) \<Rightarrow> int"
  where "addxyz2 ((x,y),z) = x + y + z"

term "curry addxyz2"
term "curry (curry addxyz2)"

term "curry (curry addxyz2) 1"

fun addxyz3 :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int"
  where "addxyz3 x y z = x + y + z"
term "case_prod addxyz3"
term "case_prod (case_prod addxyz3)"

end