(*  Title:      ZF/Arith.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

(*"Difference" is subtraction of natural numbers.
  There are no negative numbers; we have
     m #- n = 0  iff  m<=n   and     m #- n = succ(k) iff m>n.
  Also, rec(m, 0, %z w.z) is pred(m).
*)

section\<open>Arithmetic Operators and Their Definitions\<close>

theory Arith imports Univ begin

text\<open>Proofs about elementary arithmetic: addition, multiplication, etc.\<close>

definition
  pred   :: "i=>i"    (*inverse of succ*)  where
    "pred(y) == nat_case(0, %x. x, y)"

definition
  natify :: "i=>i"    (*coerces non-nats to nats*)  where
    "natify == Vrecursor(%f a. if a = succ(pred(a)) then succ(f`pred(a))
                                                    else 0)"

consts
  raw_add  :: "[i,i]=>i"
  raw_diff  :: "[i,i]=>i"
  raw_mult  :: "[i,i]=>i"

primrec
  "raw_add (0, n) = n"
  "raw_add (succ(m), n) = succ(raw_add(m, n))"

primrec
  raw_diff_0:     "raw_diff(m, 0) = m"
  raw_diff_succ:  "raw_diff(m, succ(n)) =
                     nat_case(0, %x. x, raw_diff(m, n))"

primrec
  "raw_mult(0, n) = 0"
  "raw_mult(succ(m), n) = raw_add (n, raw_mult(m, n))"

definition
  add :: "[i,i]=>i"                    (infixl \<open>#+\<close> 65)  where
    "m #+ n == raw_add (natify(m), natify(n))"

definition
  diff :: "[i,i]=>i"                    (infixl \<open>#-\<close> 65)  where
    "m #- n == raw_diff (natify(m), natify(n))"

definition
  mult :: "[i,i]=>i"                    (infixl \<open>#*\<close> 70)  where
    "m #* n == raw_mult (natify(m), natify(n))"

definition
  raw_div  :: "[i,i]=>i"  where
    "raw_div (m, n) ==
       transrec(m, %j f. if j<n | n=0 then 0 else succ(f`(j#-n)))"

definition
  raw_mod  :: "[i,i]=>i"  where
    "raw_mod (m, n) ==
       transrec(m, %j f. if j<n | n=0 then j else f`(j#-n))"

definition
  div  :: "[i,i]=>i"                    (infixl \<open>div\<close> 70)  where
    "m div n == raw_div (natify(m), natify(n))"

definition
  mod  :: "[i,i]=>i"                    (infixl \<open>mod\<close> 70)  where
    "m mod n == raw_mod (natify(m), natify(n))"

declare rec_type [simp]
        nat_0_le [simp]

lemma zero_lt_lemma: "[| 0<k; k \<in> nat |] ==> \<exists>j\<in>nat. k = succ(j)"
apply (erule rev_mp)
apply (induct_tac "k", auto)
done

(* @{term"[| 0 < k; k \<in> nat; !!j. [| j \<in> nat; k = succ(j) |] ==> Q |] ==> Q"} *)
lemmas zero_lt_natE = zero_lt_lemma [THEN bexE]

subsection\<open>\<open>natify\<close>, the Coercion to \<^term>\<open>nat\<close>\<close>

lemma pred_succ_eq [simp]: "pred(succ(y)) = y"
by (unfold pred_def, auto)

lemma natify_succ: "natify(succ(x)) = succ(natify(x))"
by (rule natify_def [THEN def_Vrecursor, THEN trans], auto)

lemma natify_0 [simp]: "natify(0) = 0"
by (rule natify_def [THEN def_Vrecursor, THEN trans], auto)

lemma natify_non_succ: "\<forall>z. x \<noteq> succ(z) ==> natify(x) = 0"
by (rule natify_def [THEN def_Vrecursor, THEN trans], auto)

lemma natify_in_nat [iff,TC]: "natify(x) \<in> nat"
apply (rule_tac a=x in eps_induct)
apply (case_tac "\<exists>z. x = succ(z)")
apply (auto simp add: natify_succ natify_non_succ)
done

lemma natify_ident [simp]: "n \<in> nat ==> natify(n) = n"
apply (induct_tac "n")
apply (auto simp add: natify_succ)
done

lemma natify_eqE: "[|natify(x) = y;  x \<in> nat|] ==> x=y"
by auto

(*** Collapsing rules: to remove natify from arithmetic expressions ***)

lemma natify_idem [simp]: "natify(natify(x)) = natify(x)"
by simp

(** Addition **)

lemma add_natify1 [simp]: "natify(m) #+ n = m #+ n"
by (simp add: add_def)

lemma add_natify2 [simp]: "m #+ natify(n) = m #+ n"
by (simp add: add_def)

(** Multiplication **)

lemma mult_natify1 [simp]: "natify(m) #* n = m #* n"
by (simp add: mult_def)

lemma mult_natify2 [simp]: "m #* natify(n) = m #* n"
by (simp add: mult_def)

(** Difference **)

lemma diff_natify1 [simp]: "natify(m) #- n = m #- n"
by (simp add: diff_def)

lemma diff_natify2 [simp]: "m #- natify(n) = m #- n"
by (simp add: diff_def)

(** Remainder **)

lemma mod_natify1 [simp]: "natify(m) mod n = m mod n"
by (simp add: mod_def)

lemma mod_natify2 [simp]: "m mod natify(n) = m mod n"
by (simp add: mod_def)

(** Quotient **)

lemma div_natify1 [simp]: "natify(m) div n = m div n"
by (simp add: div_def)

lemma div_natify2 [simp]: "m div natify(n) = m div n"
by (simp add: div_def)

subsection\<open>Typing rules\<close>

(** Addition **)

lemma raw_add_type: "[| m\<in>nat;  n\<in>nat |] ==> raw_add (m, n) \<in> nat"
by (induct_tac "m", auto)

lemma add_type [iff,TC]: "m #+ n \<in> nat"
by (simp add: add_def raw_add_type)

(** Multiplication **)

lemma raw_mult_type: "[| m\<in>nat;  n\<in>nat |] ==> raw_mult (m, n) \<in> nat"
apply (induct_tac "m")
apply (simp_all add: raw_add_type)
done

lemma mult_type [iff,TC]: "m #* n \<in> nat"
by (simp add: mult_def raw_mult_type)

(** Difference **)

lemma raw_diff_type: "[| m\<in>nat;  n\<in>nat |] ==> raw_diff (m, n) \<in> nat"
by (induct_tac "n", auto)

lemma diff_type [iff,TC]: "m #- n \<in> nat"
by (simp add: diff_def raw_diff_type)

lemma diff_0_eq_0 [simp]: "0 #- n = 0"
apply (unfold diff_def)
apply (rule natify_in_nat [THEN nat_induct], auto)
done

(*Must simplify BEFORE the induction: else we get a critical pair*)
lemma diff_succ_succ [simp]: "succ(m) #- succ(n) = m #- n"
apply (simp add: natify_succ diff_def)
apply (rule_tac x1 = n in natify_in_nat [THEN nat_induct], auto)
done

(*This defining property is no longer wanted*)
declare raw_diff_succ [simp del]

(*Natify has weakened this law, compared with the older approach*)
lemma diff_0 [simp]: "m #- 0 = natify(m)"
by (simp add: diff_def)

lemma diff_le_self: "m\<in>nat ==> (m #- n) \<le> m"
apply (subgoal_tac " (m #- natify (n)) \<le> m")
apply (rule_tac [2] m = m and n = "natify (n) " in diff_induct)
apply (erule_tac [6] leE)
apply (simp_all add: le_iff)
done

subsection\<open>Addition\<close>

(*Natify has weakened this law, compared with the older approach*)
lemma add_0_natify [simp]: "0 #+ m = natify(m)"
by (simp add: add_def)

lemma add_succ [simp]: "succ(m) #+ n = succ(m #+ n)"
by (simp add: natify_succ add_def)

lemma add_0: "m \<in> nat ==> 0 #+ m = m"
by simp

(*Associative law for addition*)

(*The following two lemmas are used for add_commute and sometimes
  elsewhere, since they are safe for rewriting.*)
lemma add_0_right_natify [simp]: "m #+ 0 = natify(m)"
apply (subgoal_tac "natify(m) #+ 0 = natify(m)")
apply (rule_tac [2] n = "natify(m)" in nat_induct)
apply auto
done

lemma add_succ_right [simp]: "m #+ succ(n) = succ(m #+ n)"
apply (unfold add_def)
apply (rule_tac n = "natify(m) " in nat_induct)
apply (auto simp add: natify_succ)
done

lemma add_0_right: "m \<in> nat ==> m #+ 0 = m"
by auto

(*Commutative law for addition*)
lemma add_commute: "m #+ n = n #+ m"
apply (subgoal_tac "natify(m) #+ natify(n) = natify(n) #+ natify(m) ")
apply (rule_tac [2] n = "natify(m) " in nat_induct)
apply auto
done

(*for a/c rewriting*)
lemma add_left_commute: "m#+(n#+k)=n#+(m#+k)"
apply (rule add_commute [THEN trans])
apply (rule add_assoc [THEN trans])
apply (rule add_commute [THEN subst_context])
done

(*Addition is an AC-operator*)
lemmas add_ac = add_assoc add_commute add_left_commute

(*Cancellation law on the left*)
lemma raw_add_left_cancel:
     "[| raw_add(k, m) = raw_add(k, n);  k\<in>nat |] ==> m=n"
apply (erule rev_mp)
apply (induct_tac "k", auto)
done

lemma add_left_cancel_natify: "k #+ m = k #+ n ==> natify(m) = natify(n)"
apply (unfold add_def)
apply (drule raw_add_left_cancel, auto)
done

lemma add_left_cancel:
     "[| i = j;  i #+ m = j #+ n;  m\<in>nat;  n\<in>nat |] ==> m = n"
by (force dest!: add_left_cancel_natify)

(*Thanks to Sten Agerholm*)
lemma add_le_elim1_natify: "k#+m \<le> k#+n ==> natify(m) \<le> natify(n)"
apply (rule_tac P = "natify(k) #+m \<le> natify(k) #+n" in rev_mp)
apply (rule_tac [2] n = "natify(k) " in nat_induct)
apply auto
done

lemma add_le_elim1: "[| k#+m \<le> k#+n; m \<in> nat; n \<in> nat |] ==> m \<le> n"
by (drule add_le_elim1_natify, auto)

lemma add_lt_elim1_natify: "k#+m < k#+n ==> natify(m) < natify(n)"
apply (rule_tac P = "natify(k) #+m < natify(k) #+n" in rev_mp)
apply (rule_tac [2] n = "natify(k) " in nat_induct)
apply auto
done

lemma add_lt_elim1: "[| k#+m < k#+n; m \<in> nat; n \<in> nat |] ==> m < n"
by (drule add_lt_elim1_natify, auto)

lemma zero_less_add: "[| n \<in> nat; m \<in> nat |] ==> 0 < m #+ n \<longleftrightarrow> (0<m | 0<n)"
by (induct_tac "n", auto)

subsection\<open>Monotonicity of Addition\<close>

(*strict, in 1st argument; proof is by rule induction on 'less than'.
  Still need j\<in>nat, for consider j = omega.  Then we can have i<omega,
  which is the same as i\<in>nat, but natify(j)=0, so the conclusion fails.*)
lemma add_lt_mono1: "[| i<j; j\<in>nat |] ==> i#+k < j#+k"
apply (frule lt_nat_in_nat, assumption)
apply (erule succ_lt_induct)
apply (simp_all add: leI)
done

text\<open>strict, in second argument\<close>
lemma add_lt_mono2: "[| i<j; j\<in>nat |] ==> k#+i < k#+j"
by (simp add: add_commute [of k] add_lt_mono1)

text\<open>A [clumsy] way of lifting < monotonicity to \<open>\<le>\<close> monotonicity\<close>
lemma Ord_lt_mono_imp_le_mono:
  assumes lt_mono: "!!i j. [| i<j; j:k |] ==> f(i) < f(j)"
      and ford:    "!!i. i:k ==> Ord(f(i))"
      and leij:    "i \<le> j"
      and jink:    "j:k"
  shows "f(i) \<le> f(j)"
apply (insert leij jink)
apply (blast intro!: leCI lt_mono ford elim!: leE)
done

text\<open>\<open>\<le>\<close> monotonicity, 1st argument\<close>
lemma add_le_mono1: "[| i \<le> j; j\<in>nat |] ==> i#+k \<le> j#+k"
apply (rule_tac f = "%j. j#+k" in Ord_lt_mono_imp_le_mono, typecheck)
apply (blast intro: add_lt_mono1 add_type [THEN nat_into_Ord])+
done

text\<open>\<open>\<le>\<close> monotonicity, both arguments\<close>
lemma add_le_mono: "[| i \<le> j; k \<le> l; j\<in>nat; l\<in>nat |] ==> i#+k \<le> j#+l"
apply (rule add_le_mono1 [THEN le_trans], assumption+)
apply (subst add_commute, subst add_commute, rule add_le_mono1, assumption+)
done

text\<open>Combinations of less-than and less-than-or-equals\<close>

lemma add_lt_le_mono: "[| i<j; k\<le>l; j\<in>nat; l\<in>nat |] ==> i#+k < j#+l"
apply (rule add_lt_mono1 [THEN lt_trans2], assumption+)
apply (subst add_commute, subst add_commute, rule add_le_mono1, assumption+)
done

lemma add_le_lt_mono: "[| i\<le>j; k<l; j\<in>nat; l\<in>nat |] ==> i#+k < j#+l"
by (subst add_commute, subst add_commute, erule add_lt_le_mono, assumption+)

text\<open>Less-than: in other words, strict in both arguments\<close>
lemma add_lt_mono: "[| i<j; k<l; j\<in>nat; l\<in>nat |] ==> i#+k < j#+l"
apply (rule add_lt_le_mono)
apply (auto intro: leI)
done

(** Subtraction is the inverse of addition. **)

lemma diff_add_inverse: "(n#+m) #- n = natify(m)"
apply (subgoal_tac " (natify(n) #+ m) #- natify(n) = natify(m) ")
apply (rule_tac [2] n = "natify(n) " in nat_induct)
apply auto
done

lemma diff_add_inverse2: "(m#+n) #- n = natify(m)"
by (simp add: add_commute [of m] diff_add_inverse)

lemma diff_cancel: "(k#+m) #- (k#+n) = m #- n"
apply (subgoal_tac "(natify(k) #+ natify(m)) #- (natify(k) #+ natify(n)) =
                    natify(m) #- natify(n) ")
apply (rule_tac [2] n = "natify(k) " in nat_induct)
apply auto
done

lemma diff_cancel2: "(m#+k) #- (n#+k) = m #- n"
by (simp add: add_commute [of _ k] diff_cancel)

lemma diff_add_0: "n #- (n#+m) = 0"
apply (subgoal_tac "natify(n) #- (natify(n) #+ natify(m)) = 0")
apply (rule_tac [2] n = "natify(n) " in nat_induct)
apply auto
done

lemma pred_0 [simp]: "pred(0) = 0"
by (simp add: pred_def)

lemma eq_succ_imp_eq_m1: "[|i = succ(j); i\<in>nat|] ==> j = i #- 1 & j \<in>nat"
by simp

lemma pred_Un_distrib:
    "[|i\<in>nat; j\<in>nat|] ==> pred(i \<union> j) = pred(i) \<union> pred(j)"
apply (erule_tac n=i in natE, simp)
apply (erule_tac n=j in natE, simp)
apply (simp add:  succ_Un_distrib [symmetric])
done

lemma pred_type [TC,simp]:
    "i \<in> nat ==> pred(i) \<in> nat"
by (simp add: pred_def split: split_nat_case)

lemma nat_diff_pred: "[|i\<in>nat; j\<in>nat|] ==> i #- succ(j) = pred(i #- j)"
apply (rule_tac m=i and n=j in diff_induct)
apply (auto simp add: pred_def nat_imp_quasinat split: split_nat_case)
done

lemma diff_succ_eq_pred: "i #- succ(j) = pred(i #- j)"
apply (insert nat_diff_pred [of "natify(i)" "natify(j)"])
apply (simp add: natify_succ [symmetric])
done

lemma nat_diff_Un_distrib:
    "[|i\<in>nat; j\<in>nat; k\<in>nat|] ==> (i \<union> j) #- k = (i#-k) \<union> (j#-k)"
apply (rule_tac n=k in nat_induct)
apply (simp_all add: diff_succ_eq_pred pred_Un_distrib)
done

lemma diff_Un_distrib:
    "[|i\<in>nat; j\<in>nat|] ==> (i \<union> j) #- k = (i#-k) \<union> (j#-k)"
by (insert nat_diff_Un_distrib [of i j "natify(k)"], simp)

text\<open>We actually prove \<^term>\<open>i #- j #- k = i #- (j #+ k)\<close>\<close>
lemma diff_diff_left [simplified]:
     "natify(i)#-natify(j)#-k = natify(i) #- (natify(j)#+k)"
by (rule_tac m="natify(i)" and n="natify(j)" in diff_induct, auto)

(** Lemmas for the CancelNumerals simproc **)

lemma eq_add_iff: "(u #+ m = u #+ n) \<longleftrightarrow> (0 #+ m = natify(n))"
apply auto
apply (blast dest: add_left_cancel_natify)
apply (simp add: add_def)
done

lemma less_add_iff: "(u #+ m < u #+ n) \<longleftrightarrow> (0 #+ m < natify(n))"
apply (auto simp add: add_lt_elim1_natify)
apply (drule add_lt_mono1)
apply (auto simp add: add_commute [of u])
done

lemma diff_add_eq: "((u #+ m) #- (u #+ n)) = ((0 #+ m) #- n)"
by (simp add: diff_cancel)

(*To tidy up the result of a simproc.  Only the RHS will be simplified.*)
lemma eq_cong2: "u = u' ==> (t==u) == (t==u')"
by auto

lemma iff_cong2: "u \<longleftrightarrow> u' ==> (t==u) == (t==u')"
by auto

subsection\<open>Multiplication\<close>

lemma mult_0 [simp]: "0 #* m = 0"
by (simp add: mult_def)

lemma mult_succ [simp]: "succ(m) #* n = n #+ (m #* n)"
by (simp add: add_def mult_def natify_succ raw_mult_type)

(*right annihilation in product*)
lemma mult_0_right [simp]: "m #* 0 = 0"
apply (unfold mult_def)
apply (rule_tac n = "natify(m) " in nat_induct)
apply auto
done

(*right successor law for multiplication*)
lemma mult_succ_right [simp]: "m #* succ(n) = m #+ (m #* n)"
apply (subgoal_tac "natify(m) #* succ (natify(n)) =
                    natify(m) #+ (natify(m) #* natify(n))")
apply (simp (no_asm_use) add: natify_succ add_def mult_def)
apply (rule_tac n = "natify(m) " in nat_induct)
apply (simp_all add: add_ac)
done

lemma mult_1_natify [simp]: "1 #* n = natify(n)"
by auto

lemma mult_1_right_natify [simp]: "n #* 1 = natify(n)"
by auto

lemma mult_1: "n \<in> nat ==> 1 #* n = n"
by simp

lemma mult_1_right: "n \<in> nat ==> n #* 1 = n"
by simp

(*Commutative law for multiplication*)
lemma mult_commute: "m #* n = n #* m"
apply (subgoal_tac "natify(m) #* natify(n) = natify(n) #* natify(m) ")
apply (rule_tac [2] n = "natify(m) " in nat_induct)
apply auto
done

(*addition distributes over multiplication*)
lemma add_mult_distrib: "(m #+ n) #* k = (m #* k) #+ (n #* k)"
apply (subgoal_tac "(natify(m) #+ natify(n)) #* natify(k) =
                    (natify(m) #* natify(k)) #+ (natify(n) #* natify(k))")
apply (rule_tac [2] n = "natify(m) " in nat_induct)
apply (simp_all add: add_assoc [symmetric])
done

(*Distributive law on the left*)
lemma add_mult_distrib_left: "k #* (m #+ n) = (k #* m) #+ (k #* n)"
apply (subgoal_tac "natify(k) #* (natify(m) #+ natify(n)) =
                    (natify(k) #* natify(m)) #+ (natify(k) #* natify(n))")
apply (rule_tac [2] n = "natify(m) " in nat_induct)
apply (simp_all add: add_ac)
done

(*Associative law for multiplication*)
lemma mult_assoc: "(m #* n) #* k = m #* (n #* k)"
apply (subgoal_tac "(natify(m) #* natify(n)) #* natify(k) =
                    natify(m) #* (natify(n) #* natify(k))")
apply (rule_tac [2] n = "natify(m) " in nat_induct)
apply (simp_all add: add_mult_distrib)
done

(*for a/c rewriting*)
lemma mult_left_commute: "m #* (n #* k) = n #* (m #* k)"
apply (rule mult_commute [THEN trans])
apply (rule mult_assoc [THEN trans])
apply (rule mult_commute [THEN subst_context])
done

lemmas mult_ac = mult_assoc mult_commute mult_left_commute

lemma lt_succ_eq_0_disj:
     "[| m\<in>nat; n\<in>nat |]
      ==> (m < succ(n)) \<longleftrightarrow> (m = 0 | (\<exists>j\<in>nat. m = succ(j) & j < n))"
by (induct_tac "m", auto)

lemma less_diff_conv [rule_format]:
     "[| j\<in>nat; k\<in>nat |] ==> \<forall>i\<in>nat. (i < j #- k) \<longleftrightarrow> (i #+ k < j)"
by (erule_tac m = k in diff_induct, auto)

lemmas nat_typechecks = rec_type nat_0I nat_1I nat_succI Ord_nat

end


(*<*)
(*
   Title:  Theory JoinSplitTime.thy
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2013
*)
(*>*)
 section \<open>Changing time granularity of the streams\<close>

theory JoinSplitTime
imports stream arith_hints
begin

subsection  \<open>Join time units\<close>

primrec
  join_ti ::"'a istream \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
where
join_ti_0:
 "join_ti s x 0 = s x" |
join_ti_Suc:
 "join_ti s x (Suc i) = (join_ti s x i) @ (s (x + (Suc i)))"

primrec
  fin_join_ti ::"'a fstream \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
where
fin_join_ti_0:
 "fin_join_ti s x 0 = nth s x" |
fin_join_ti_Suc:
 "fin_join_ti s x (Suc i) = (fin_join_ti s x i) @ (nth s (x + (Suc i)))"

definition
  join_time ::"'a istream \<Rightarrow> nat \<Rightarrow> 'a istream"
where
 "join_time s n t \<equiv>
  (case n of
        0  \<Rightarrow> []
  |(Suc i) \<Rightarrow>  join_ti s (n*t) i)"

lemma join_ti_hint1:
  assumes "join_ti s x (Suc i) = []"
  shows   "join_ti s x i = []"
using assms by auto

lemma join_ti_hint2:
  assumes "join_ti s x (Suc i) = []"
  shows   "s (x + (Suc i)) = []"
using assms by auto

lemma join_ti_hint3:
  assumes "join_ti s x (Suc i) = []"
  shows   "s (x + i) = []"
using assms by (induct i, auto)

lemma join_ti_empty_join:
  assumes "i \<le> n"
         and "join_ti s x n = []"
  shows      "s (x+i) = []"
using assms
proof (induct n)
  case 0 then show ?case by auto
next
  case (Suc n) then show ?case
  by (metis join_ti_hint1 join_ti_hint2 le_SucE)
qed

lemma join_ti_empty_ti:
  assumes "\<forall> i \<le> n. s (x+i) = []"
  shows    "join_ti s x n = []"
using assms by (induct n, auto)

lemma join_ti_1nempty:
  assumes "\<forall> i. 0 < i \<and> i < Suc n \<longrightarrow> s (x+i) = []"
  shows    "join_ti s x n = s x"
using assms by (induct n, auto)

lemma join_time1t: "\<forall> t. join_time s (1::nat) t = s t"
by (simp add: join_time_def)

lemma join_time1: "join_time s 1 = s"
by (simp add: fun_eq_iff join_time_def)

lemma join_time_empty1:
  assumes h1:"i < n"
         and h2:"join_time s n t = []"
  shows      "s (n*t + i) = []"
proof (cases n)
  assume "n = 0"
  from assms and this show ?thesis by (simp add: join_time_def)
next
  fix x
  assume a2:"n = Suc x"
  from assms and a2 have sg1:"join_ti s (t + x * t) x = []"
    by (simp add: join_time_def)
  from a2 and h1 have "i \<le> x" by simp
  from this and sg1 and a2 show ?thesis by (simp add: join_ti_empty_join)
qed

lemma fin_join_ti_hint1:
  assumes "fin_join_ti s x (Suc i) = []"
  shows   "fin_join_ti s x i = []"
using assms by auto

lemma fin_join_ti_hint2:
  assumes "fin_join_ti s x (Suc i) = []"
  shows    "nth s (x + (Suc i)) = []"
using assms by auto

lemma fin_join_ti_hint3:
  assumes "fin_join_ti s x (Suc i) = []"
  shows    "nth s (x + i) = []"
using assms by (induct i, auto)

lemma fin_join_ti_empty_join:
  assumes "i \<le> n"
         and "fin_join_ti s x n = []"
  shows      "nth s (x+i) = []"
using assms
proof (induct n)
  case 0 then show ?case by auto
next
  case (Suc n) then show ?case
  proof (cases "i = Suc n")
    assume "i = Suc n"
    from Suc and this show ?thesis by simp
  next
    assume "i \<noteq> Suc n"
    from Suc and this show ?thesis by simp
  qed
qed

lemma fin_join_ti_empty_ti:
  assumes "\<forall> i \<le> n. nth s (x+i) = []"
  shows    "fin_join_ti s x n = []"
using assms by (induct n, auto)

lemma fin_join_ti_1nempty:
  assumes "\<forall> i. 0 < i \<and> i < Suc n \<longrightarrow> nth s (x+i) = []"
  shows    "fin_join_ti s x n = nth s x"
using assms  by (induct n, auto)

subsection \<open>Split time units\<close>

definition
  split_time ::"'a istream \<Rightarrow> nat \<Rightarrow> 'a istream"
where
 "split_time s n t \<equiv>
  ( if (t mod n = 0)
    then s (t div n)
    else [])"

lemma split_time1t: "\<forall> t. split_time s 1 t = s t"
by (simp add: split_time_def)

lemma split_time1: "split_time s 1 = s"
by (simp add: fun_eq_iff split_time_def)

lemma split_time_mod:
  assumes "t mod n \<noteq> 0"
  shows    "split_time s n t = []"
using assms by (simp add: split_time_def)

lemma split_time_nempty:
  assumes "0 < n"
  shows    "split_time s n (n * t) = s t"
using assms by (simp add: split_time_def)

lemma split_time_nempty_Suc:
  assumes "0 < n"
  shows   "split_time s (Suc n) ((Suc n) * t) = split_time s n (n * t)"
proof -
  have "0 < Suc n" by simp
  then have sg1:"split_time s (Suc n) ((Suc n) * t) =  s t"
    by (rule split_time_nempty)
  from assms have sg2:"split_time s n (n * t) = s t"
    by (rule split_time_nempty)
  from sg1 and sg2 show ?thesis by simp
qed

lemma split_time_empty:
  assumes "i < n" and h2:"0 < i"
  shows    "split_time s n (n * t + i) = []"
proof -
  from assms have "0 < (n * t + i) mod n" by (simp add: arith_mod_nzero)
  from assms and this show ?thesis by (simp add: split_time_def)
qed

lemma split_time_empty_Suc:
  assumes h1:"i < n"
         and h2:"0 < i"
  shows "split_time s (Suc n) ((Suc n)* t + i)  = split_time s n (n * t + i)"
proof -
  from h1 have "i < Suc n" by simp
  from this and h2 have sg2:"split_time s (Suc n) (Suc n * t + i) = []"
    by (rule split_time_empty)
  from assms have sg3:"split_time s n (n * t + i) = []"
    by (rule split_time_empty)
  from sg3 and sg2 show ?thesis by simp
qed

lemma split_time_hint1:
  assumes "n = Suc m"
  shows   "split_time s (Suc n) (i + n * i + n) = []"
proof -
  have sg1:"i + n * i + n = (Suc n) * i + n" by simp
  have sg2:"n < Suc n" by simp
  from assms have sg3:"0 < n" by simp
  from sg2 and sg3 have sg4:"split_time s (Suc n) (Suc n * i + n) = []"
     by (rule split_time_empty)
  from sg1 and sg4  show ?thesis by auto
qed

subsection \<open>Duality of the split and the join operators\<close>

lemma join_split_i:
  assumes "0 < n"
  shows   "join_time (split_time s n) n i = s i"
proof (cases n)
  assume "n = 0"
  from this and assms show ?thesis by simp
next
  fix k
  assume a2:"n = Suc k"
  have sg0:"0 < Suc k" by simp
  then have sg1:"(split_time s (Suc k)) (Suc k * i) = s i"
    by (rule split_time_nempty)
  have sg2:"i + k * i = (Suc k) * i" by simp
  have sg3:"\<forall> j. 0 < j \<and> j < Suc k \<longrightarrow> split_time s (Suc k) (Suc k * i + j) = []"
    by (clarify, rule split_time_empty, auto)
  from sg3 have sg4:"join_ti (split_time s (Suc k)) ((Suc k) * i) k =
                     (split_time s (Suc k)) (Suc k * i)"
    by (rule join_ti_1nempty)
  from a2 and sg4 and sg1 show ?thesis by (simp add: join_time_def)
qed

lemma join_split:
  assumes "0 < n"
  shows "join_time (split_time s n) n = s"
using assms  by (simp add: fun_eq_iff join_split_i)

end


theory sort_BSortSorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (Nil2) = Nil2"
| "evens (Cons2 y xs) = Cons2 y (odds xs)"
| "odds (Nil2) = Nil2"
| "odds (Cons2 y xs) = evens xs"
by pat_completeness auto

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun pairs :: "int list => int list => int list" where
"pairs (Nil2) y = y"
| "pairs (Cons2 z x2) (Nil2) = Cons2 z x2"
| "pairs (Cons2 z x2) (Cons2 x3 x4) =
     append (sort2 z x3) (pairs x2 x4)"

fun stitch :: "int list => int list => int list" where
"stitch (Nil2) y = y"
| "stitch (Cons2 z xs) y = Cons2 z (pairs xs y)"

fun bmerge :: "int list => int list => int list" where
"bmerge (Nil2) y = Nil2"
| "bmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "bmerge (Cons2 z (Nil2)) (Cons2 x3 (Nil2)) = sort2 z x3"
| "bmerge (Cons2 z (Nil2)) (Cons2 x3 (Cons2 x5 x6)) =
     stitch
       (bmerge (evens (Cons2 z (Nil2))) (evens (Cons2 x3 (Cons2 x5 x6))))
       (bmerge (odds (Cons2 z (Nil2))) (odds (Cons2 x3 (Cons2 x5 x6))))"
| "bmerge (Cons2 z (Cons2 x7 x8)) (Cons2 x3 x4) =
     stitch
       (bmerge (evens (Cons2 z (Cons2 x7 x8))) (evens (Cons2 x3 x4)))
       (bmerge (odds (Cons2 z (Cons2 x7 x8))) (odds (Cons2 x3 x4)))"

fun bsort :: "int list => int list" where
"bsort (Nil2) = Nil2"
| "bsort (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "bsort (Cons2 y (Cons2 x2 x3)) =
     bmerge
       (bsort (evens (Cons2 y (Cons2 x2 x3))))
       (bsort (odds (Cons2 y (Cons2 x2 x3))))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "int list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (y <= y2) (ordered (Cons2 y2 xs))"

(*hipster sort2
          evens
          odds
          append
          pairs
          stitch
          bmerge
          bsort
          and2
          ordered *)

theorem x0 :
  "!! (x :: int list) . ordered (bsort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Mod_Plus_Minus

imports Kyber_spec

begin
section \<open>Re-centered Modulo Operation\<close>
text \<open>To define the compress and decompress functions,
  we need some special form of modulo. It returns the
  representation of the equivalence class in \<open>(-q div 2, q div 2]\<close>.
  Using these representatives, we ensure that the norm of the
  representative is as small as possible.\<close>

definition mod_plus_minus :: "int \<Rightarrow> int \<Rightarrow> int"
  (infixl "mod+-" 70) where
"m mod+- b =
  (if m mod b > \<lfloor>b/2\<rfloor> then m mod b - b else m mod b)"

text \<open>Range of the (re-centered) modulo operation\<close>

lemma mod_range: "b>0 \<Longrightarrow> (a::int) mod (b::int) \<in> {0..b-1}"
using range_mod by auto

lemma mod_rangeE:
  assumes "(a::int)\<in>{0..<b}"
  shows "a = a mod b"
using assms by auto

lemma half_mod_odd:
assumes "b>0" "odd b" "\<lfloor>real_of_int b / 2\<rfloor> < y mod b"
shows "- \<lfloor>real_of_int b / 2\<rfloor> \<le> y mod b - b" "y mod b - b \<le> \<lfloor>real_of_int b / 2\<rfloor>"
proof -
  have "\<lfloor>real_of_int b / 2\<rfloor> = (b-1) div 2" using \<open>odd b\<close>
    by (metis add.commute diff_add_cancel even_add even_succ_div_2 floor_divide_of_int_eq
    odd_one of_int_numeral)
  then show "- \<lfloor>real_of_int b / 2\<rfloor> \<le> y mod b - b" using assms by linarith
  have "y mod b \<le> b + \<lfloor>real_of_int b / 2\<rfloor>" using mod_range[OF assms(1)]
  by (smt (verit, ccfv_SIG) \<open>\<lfloor>real_of_int b / 2\<rfloor> = (b - 1) div 2\<close> atLeastAtMost_iff
    pos_imp_zdiv_neg_iff)
  then show "y mod b - b \<le> \<lfloor>real_of_int b / 2\<rfloor>" by auto
qed

lemma half_mod:
assumes "b>0"
shows "- \<lfloor>real_of_int b / 2\<rfloor> \<le> y mod b"
using assms
by (smt (verit, best) floor_less_zero half_gt_zero mod_int_pos_iff of_int_pos)

lemma mod_plus_minus_range_odd:
  assumes "b>0" "odd b"
  shows "y mod+- b \<in> {-\<lfloor>b/2\<rfloor>..\<lfloor>b/2\<rfloor>}"
unfolding mod_plus_minus_def by (auto simp add: half_mod_odd[OF assms] half_mod[OF assms(1)])

lemma odd_smaller_b:
  assumes "odd b"
  shows "\<lfloor> real_of_int b / 2 \<rfloor> + \<lfloor> real_of_int b / 2 \<rfloor> < b"
using assms
by (smt (z3) floor_divide_of_int_eq odd_two_times_div_two_succ
  of_int_hom.hom_add of_int_hom.hom_one)

lemma mod_plus_minus_rangeE_neg:
  assumes "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..\<lfloor>real_of_int b/2\<rfloor>}"
          "odd b" "b > 0"
           "\<lfloor>real_of_int b / 2\<rfloor> < y mod b"
  shows "y = y mod b - b"
proof -
  have "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..<0}" using assms
  by (meson atLeastAtMost_iff atLeastLessThan_iff linorder_not_le order_trans zmod_le_nonneg_dividend)
  then have "y \<in> {-b..<0}" using assms(2-3)
  by (metis atLeastLessThan_iff floor_divide_of_int_eq int_div_less_self linorder_linear
    linorder_not_le neg_le_iff_le numeral_code(1) numeral_le_iff of_int_numeral order_trans
    semiring_norm(69))
  then have "y mod b = y + b"
  by (smt (verit) atLeastLessThan_iff mod_add_self2 mod_pos_pos_trivial)
  then show ?thesis by auto
qed

lemma mod_plus_minus_rangeE_pos:
  assumes "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..\<lfloor>real_of_int b/2\<rfloor>}"
          "odd b" "b > 0"
          "\<lfloor>real_of_int b / 2\<rfloor> \<ge> y mod b"
  shows "y = y mod b"
proof -
  have "y \<in> {0..\<lfloor>real_of_int b/2\<rfloor>}"
  proof (rule ccontr)
    assume "y \<notin> {0..\<lfloor>real_of_int b / 2\<rfloor>} "
    then have "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..<0}" using assms(1) by auto
    then have "y \<in> {-b..<0}" using assms(2-3)
    by (metis atLeastLessThan_iff floor_divide_of_int_eq int_div_less_self linorder_linear
      linorder_not_le neg_le_iff_le numeral_code(1) numeral_le_iff of_int_numeral order_trans
      semiring_norm(69))
    then have "y mod b = y + b"
      by (smt (verit) atLeastLessThan_iff mod_add_self2 mod_pos_pos_trivial)
    then have "y mod b \<ge> b - \<lfloor>real_of_int b/2\<rfloor>" using assms(1) by auto
    then have "y mod b > \<lfloor>real_of_int b/2\<rfloor>"
      using assms(2) odd_smaller_b by fastforce
    then show False using assms(4) by auto
  qed
  then have "y \<in> {0..<b}" using assms(2-3)
  by (metis atLeastAtMost_iff atLeastLessThan_empty atLeastLessThan_iff floor_divide_of_int_eq
    int_div_less_self linorder_not_le numeral_One numeral_less_iff of_int_numeral semiring_norm(76))
  then show ?thesis by auto
qed

lemma mod_plus_minus_rangeE:
  assumes "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..\<lfloor>real_of_int b/2\<rfloor>}"
          "odd b" "b > 0"
  shows "y = y mod+- b"
unfolding mod_plus_minus_def
using mod_plus_minus_rangeE_pos[OF assms] mod_plus_minus_rangeE_neg[OF assms]
by auto

text \<open>Image of $0$.\<close>

lemma mod_plus_minus_zero:
  assumes "x mod+- b = 0"
  shows "x mod b = 0"
using assms unfolding mod_plus_minus_def
by (metis eq_iff_diff_eq_0 mod_mod_trivial mod_self)

lemma mod_plus_minus_zero':
  assumes "b>0" "odd b"
  shows "0 mod+- b = (0::int)"
using assms(1) mod_plus_minus_def by force

text \<open>\<open>mod+-\<close> with negative values.\<close>

lemma neg_mod_plus_minus:
  assumes "odd b"
          "b>0"
  shows "(- x) mod+- b = - (x mod+- b)"
proof -
  obtain k :: int where k_def: "(-x) mod+- b = (-x)+ k* b"
  using mod_plus_minus_def
  proof -
    assume a1: "\<And>k. - x mod+- b = - x + k * b \<Longrightarrow> thesis"
    have "\<exists>i. i mod b + - (x + i) = - x mod+- b"
    by (smt (verit, del_insts) mod_add_self1 mod_plus_minus_def)
    then show ?thesis
      using a1 by (metis (no_types) diff_add_cancel diff_diff_add
      diff_minus_eq_add minus_diff_eq minus_mult_div_eq_mod
      mult.commute mult_minus_left)
  qed
  then have "(-x) mod+- b = -(x - k*b)" using k_def by auto
  also have "\<dots> = - ((x-k*b) mod+- b)"
  proof -
    have range_xkb:"x - k * b \<in>
      {- \<lfloor>real_of_int b / 2\<rfloor>..\<lfloor>real_of_int b / 2\<rfloor>}"
      using k_def mod_plus_minus_range_odd[OF assms(2) assms(1)]
      by (smt (verit, ccfv_SIG) atLeastAtMost_iff)
    have "x - k*b = (x - k*b) mod+- b"
      using mod_plus_minus_rangeE[OF range_xkb assms] by auto
    then show ?thesis by auto
  qed
  also have "-((x - k*b) mod+- b) = -(x mod+- b)"
    unfolding mod_plus_minus_def
    by (smt (verit, best) mod_mult_self1)
  finally show ?thesis by auto
qed

text \<open>Representative with \<open>mod+-\<close>\<close>

lemma mod_plus_minus_rep_ex:
"\<exists>k. x = k*b + x mod+- b"
unfolding mod_plus_minus_def
by (split if_splits)(metis add.right_neutral add_diff_eq div_mod_decomp_int
  eq_iff_diff_eq_0 mod_add_self2)

lemma mod_plus_minus_rep:
  obtains k where "x = k*b + x mod+- b"
using mod_plus_minus_rep_ex by auto

text \<open>Multiplication in \<open>mod+-\<close>\<close>

lemma mod_plus_minus_mult:
  "s*x mod+- q = (s mod+- q) * (x mod+- q) mod+- q"
unfolding mod_plus_minus_def
by (smt (verit, ccfv_threshold) minus_mod_self2 mod_mult_left_eq mod_mult_right_eq)
end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Factoring Rational Polynomials\<close>

text \<open>We combine the factorization algorithm for integer polynomials
  with Gauss Lemma to a factorization algorithm for rational polynomials.\<close>
theory Factorize_Rat_Poly
imports
  Factorize_Int_Poly
begin

(*TODO: Move*)
interpretation content_hom: monoid_mult_hom
  "content::'a::{factorial_semiring, semiring_gcd, normalization_semidom_multiplicative} poly \<Rightarrow> _"
by (unfold_locales, auto simp: content_mult)

lemma prod_dvd_1_imp_all_dvd_1:
  assumes "finite X" and "prod f X dvd 1" and "x \<in> X" shows "f x dvd 1"
proof (insert assms, induct rule:finite_induct)
  case IH: (insert x' X)
  show ?case
  proof (cases "x = x'")
    case True
    with IH show ?thesis using  dvd_trans[of "f x'" "f x' * _" 1]
      by (metis dvd_triv_left prod.insert)
  next
    case False
    then show ?thesis using IH by (auto intro!: IH(3) dvd_trans[of "prod f X" "_ * prod f X" 1])
  qed
qed simp

context
  fixes alg :: int_poly_factorization_algorithm
begin
definition factorize_rat_poly_generic :: "rat poly \<Rightarrow> rat \<times> (rat poly \<times> nat) list" where
  "factorize_rat_poly_generic f = (case rat_to_normalized_int_poly f of
     (c,g) \<Rightarrow> case factorize_int_poly_generic alg g of (d,fs) \<Rightarrow> (c * rat_of_int d,
     map (\<lambda> (fi,i). (map_poly rat_of_int fi, i)) fs))"

lemma factorize_rat_poly_0[simp]: "factorize_rat_poly_generic 0 = (0,[])"
  unfolding factorize_rat_poly_generic_def rat_to_normalized_int_poly_def by simp

lemma factorize_rat_poly:
  assumes res: "factorize_rat_poly_generic f = (c,fs)"
  shows "square_free_factorization f (c,fs)"
    and "(fi,i) \<in> set fs \<Longrightarrow> irreducible fi"
proof(atomize(full), cases "f=0", goal_cases)
  case 1 with res show ?case by (auto simp: square_free_factorization_def)
next
  case 2 show ?case
  proof (unfold square_free_factorization_def split, intro conjI impI allI)
    let ?r = rat_of_int
    let ?rp = "map_poly ?r"
    obtain d g where ri: "rat_to_normalized_int_poly f = (d,g)" by force
    obtain e gs where fi: "factorize_int_poly_generic alg g = (e,gs)" by force
    from res[unfolded factorize_rat_poly_generic_def ri fi split]
    have c: "c = d * ?r e" and fs: "fs = map (\<lambda> (fi,i). (?rp fi, i)) gs" by auto
    from factorize_int_poly[OF fi]
    have irr: "(fi, i) \<in> set gs \<Longrightarrow> irreducible fi \<and> content fi = 1" for fi i
      using irreducible_imp_primitive[of fi] by auto
    note sff = factorize_int_poly(1)[OF fi]
    note sff' = square_free_factorizationD[OF sff]
    {
      fix n f
      have "?rp (f ^ n) = (?rp f) ^ n"
        by (induct n, auto simp: hom_distribs)
    } note exp = this
    show dist: "distinct fs" using sff'(5) unfolding fs distinct_map inj_on_def by auto
    interpret mh: map_poly_inj_idom_hom rat_of_int..
    have "f = smult d (?rp g)" using rat_to_normalized_int_poly[OF ri] by auto
    also have "\<dots> = smult d (?rp (smult e (\<Prod>(a, i)\<in>set gs. a ^ Suc i)))" using sff'(1) by simp
    also have "\<dots> = smult c (?rp (\<Prod>(a, i)\<in>set gs. a ^ Suc i))" unfolding c by (simp add: hom_distribs)
    also have "?rp (\<Prod>(a, i)\<in>set gs. a ^ Suc i) = (\<Prod>(a, i)\<in>set fs. a ^ Suc i)"
      unfolding prod.distinct_set_conv_list[OF sff'(5)] prod.distinct_set_conv_list[OF dist]
      unfolding fs
      by (insert exp, auto intro!: arg_cong[of _ _ "\<lambda>x. prod_list (map x gs)"] simp: hom_distribs of_int_poly_hom.hom_prod_list)
    finally show f: "f = smult c (\<Prod>(a, i)\<in>set fs. a ^ Suc i)" by auto
    {
      fix a i
      assume ai: "(a,i) \<in> set fs"
      from ai obtain A where a: "a = ?rp A" and A: "(A,i) \<in> set gs" unfolding fs by auto
      fix b j
      assume "(b,j) \<in> set fs" and diff: "(a,i) \<noteq> (b,j)"
      from this(1) obtain B where b: "b = ?rp B" and B: "(B,j) \<in> set gs" unfolding fs by auto
      from diff[unfolded a b] have "(A,i) \<noteq> (B,j)" by auto
      from sff'(3)[OF A B this]
      show "Rings.coprime a b"
        by (auto simp add: coprime_iff_gcd_eq_1 gcd_rat_to_gcd_int a b)
    }
    {
      fix fi i
      assume "(fi,i) \<in> set fs"
      then obtain gi where fi: "fi = ?rp gi" and gi: "(gi,i) \<in> set gs" unfolding fs by auto
      from irr[OF gi] have cf_gi: "primitive gi" by auto
      then have "primitive (?rp gi)" by (auto simp: content_field_poly)
      note [simp] = irreducible_primitive_connect[OF cf_gi] irreducible_primitive_connect[OF this]
      show "irreducible fi"
      using irr[OF gi] fi irreducible\<^sub>d_int_rat[of gi,simplified] by auto
      then show "degree fi > 0" "square_free fi" unfolding fi
        by (auto intro: irreducible_imp_square_free)
    }
    {
      assume "f = 0" with ri have *: "d = 1" "g = 0" unfolding rat_to_normalized_int_poly_def by auto
      with sff'(4)[OF *(2)] show "c = 0" "fs = []" unfolding c fs by auto
    }
  qed
qed

end

abbreviation factorize_rat_poly where
  "factorize_rat_poly \<equiv> factorize_rat_poly_generic berlekamp_zassenhaus_factorization_algorithm"

end


(*
  File:     KD_Tree.thy
  Author:   Martin Rau, TU München
*)

section "Definition of the \<open>k\<close>-d Tree"

theory KD_Tree
imports
  Complex_Main
  "HOL-Analysis.Finite_Cartesian_Product"
  "HOL-Analysis.Topology_Euclidean_Space"
  "Eval_Base.Eval_Base"
begin

text \<open>
  A \<open>k\<close>-d tree is a space-partitioning data structure for organizing points in a \<open>k\<close>-dimensional space.
  In principle the \<open>k\<close>-d tree is a binary tree. The leafs hold the \<open>k\<close>-dimensional points and the nodes
  contain left and right subtrees as well as a discriminator \<open>v\<close> at a particular axis \<open>k\<close>.
  Every node divides the space into two parts by splitting along a hyperplane.
  Consider a node \<open>n\<close> with associated discriminator \<open>v\<close> at axis \<open>k\<close>.
  All points in the left subtree must have a value at axis \<open>k\<close> that is less than or
  equal to \<open>v\<close> and all points in the right subtree must have a value at axis \<open>k\<close> that is
  greater than \<open>v\<close>.

  Deviations from the papers:

  The chosen tree representation is taken from @{cite "DBLP:journals/toms/FriedmanBF77"} with one minor
  adjustment. Originally the leafs hold buckets of points of size \<open>b\<close>. This representation fixes the
  bucket size to \<open>b = 1\<close>, a single point per Leaf. This is only a minor adjustment since the paper
  proves that \<open>b = 1\<close> is the optimal bucket size for minimizing the running time of the nearest neighbor
  algorithm @{cite "DBLP:journals/toms/FriedmanBF77"}, only simplifies building the optimized
  \<open>k\<close>-d trees @{cite "DBLP:journals/toms/FriedmanBF77"} and has little influence on the
  search algorithm @{cite "DBLP:journals/cacm/Bentley75"}.
\<close>

type_synonym 'k point = "(real, 'k) vec"

lemma dist_point_def:
  fixes p\<^sub>0 :: "('k::finite) point"
  shows "dist p\<^sub>0 p\<^sub>1 = sqrt (\<Sum>k \<in> UNIV. (p\<^sub>0$k - p\<^sub>1$k)\<^sup>2)"
  unfolding dist_vec_def L2_set_def dist_real_def by simp

datatype 'k kdt =
  Leaf "'k point"
| Node 'k real "'k kdt" "'k kdt"

subsection \<open>Definition of the \<open>k\<close>-d Tree Invariant and Related Functions\<close>

fun set_kdt :: "'k kdt \<Rightarrow> ('k point) set" where
  "set_kdt (Leaf p) = { p }"
| "set_kdt (Node _ _ l r) = set_kdt l \<union> set_kdt r"

definition spread :: "('k::finite) \<Rightarrow> 'k point set \<Rightarrow> real" where
  "spread k P = (if P = {} then 0 else let V = (\<lambda>p. p$k) ` P in Max V - Min V)"

definition widest_spread_axis :: "('k::finite) \<Rightarrow> 'k set \<Rightarrow> 'k point set \<Rightarrow> bool" where
  "widest_spread_axis k K ps \<longleftrightarrow> (\<forall>k' \<in> K. spread k' ps \<le> spread k ps)"

fun invar :: "('k::finite) kdt \<Rightarrow> bool" where
  "invar (Leaf p) \<longleftrightarrow> True"
| "invar (Node k v l r) \<longleftrightarrow> (\<forall>p \<in> set_kdt l. p$k \<le> v) \<and> (\<forall>p \<in> set_kdt r. v < p$k) \<and>
    widest_spread_axis k UNIV (set_kdt l \<union> set_kdt r) \<and> invar l \<and> invar r"

fun size_kdt :: "'k kdt \<Rightarrow> nat" where
  "size_kdt (Leaf _) = 1"
| "size_kdt (Node _ _ l r) = size_kdt l + size_kdt r"

fun height :: "'k kdt \<Rightarrow> nat" where
  "height (Leaf _) = 0"
| "height (Node _ _ l r) = max (height l) (height r) + 1"

fun min_height :: "'k kdt \<Rightarrow> nat" where
  "min_height (Leaf _) = 0"
| "min_height (Node _ _ l r) = min (min_height l) (min_height r) + 1"

definition balanced :: "'k kdt \<Rightarrow> bool" where
  "balanced kdt \<longleftrightarrow> height kdt - min_height kdt \<le> 1"

fun complete :: "'k kdt \<Rightarrow> bool" where
  "complete (Leaf _) = True"
| "complete (Node _ _ l r) \<longleftrightarrow> complete l \<and> complete r \<and> height l = height r"

lemma invar_r:
  "invar (Node k v l r) \<Longrightarrow> invar r"
  by simp

lemma invar_l_le_k:
  "invar (Node k v l r) \<Longrightarrow> \<forall>p \<in> set_kdt l. p$k \<le> v"
  by simp

lemma invar_r_ge_k:
  "invar (Node k v l r) \<Longrightarrow> \<forall>p \<in> set_kdt r. v < p$k"
  by simp

lemma invar_set:
  "set_kdt (Node k v l r) = set_kdt l \<union> set_kdt r"
  by simp

subsection \<open>Lemmas adapted from \<open>HOL-Library.Tree\<close> to \<open>k\<close>-d Tree\<close>

lemma size_ge0[simp]:
  "0 < size_kdt kdt"
  apply2 (induction kdt) by auto

lemma eq_size_1[simp]:
  "size_kdt kdt = 1 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  apply2 (induction kdt)
  apply (auto)
  using size_ge0 nat_less_le apply blast+
  done

lemma eq_1_size[simp]:
  "1 = size_kdt kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  using eq_size_1 by metis

lemma neq_Leaf_iff:
  "(\<nexists>p. kdt = Leaf p) = (\<exists>k v l r. kdt = Node k v l r)"
  by (cases kdt) auto

lemma eq_height_0[simp]:
  "height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_0_height[simp]:
  "0 = height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_min_height_0[simp]:
  "min_height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_0_min_height[simp]:
  "0 = min_height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma size_height:
  "size_kdt kdt \<le> 2 ^ height kdt"
proof2(induction kdt)
  case (Node k v l r)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    have "size_kdt (Node k v l r) = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height r + 2 ^ height r" using True by simp
    also have "\<dots> = 2 ^ height (Node k v l r)"
      using True by (auto simp: max_def mult_2)
    finally show ?thesis .
  next
    case False
    have "size_kdt (Node k v l r) = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height l" using False by simp
    finally show ?thesis using False by (auto simp: max_def mult_2)
  qed
qed simp

lemma min_height_le_height:
  "min_height kdt \<le> height kdt"
  apply2 (induction kdt) by auto

lemma min_height_size:
  "2 ^ min_height kdt \<le> size_kdt kdt"
proof2(induction kdt)
  case (Node k v l r)
  have "(2::nat) ^ min_height (Node k v l r) \<le> 2 ^ min_height l + 2 ^ min_height r"
    by (simp add: min_def)
  also have "\<dots> \<le> size_kdt (Node k v l r)" using Node.IH by simp
  finally show ?case .
qed simp

lemma complete_iff_height:
  "complete kdt \<longleftrightarrow> (min_height kdt = height kdt)"
  apply2 (induction kdt)
  apply simp
  apply (simp add: min_def max_def)
  by (metis le_antisym le_trans min_height_le_height)

lemma size_if_complete:
  "complete kdt \<Longrightarrow> size_kdt kdt = 2 ^ height kdt"
  apply2 (induction kdt) by auto

lemma complete_if_size_height:
  "size_kdt kdt = 2 ^ height kdt \<Longrightarrow> complete kdt"
proof2 (induction "height kdt" arbitrary: kdt)
  case 0 thus ?case by auto
next
  case (Suc h)
  hence "\<nexists>p. kdt = Leaf p"
    by auto
  then obtain k v l r where [simp]: "kdt = Node k v l r"
    using neq_Leaf_iff by metis
  have 1: "height l \<le> h" and 2: "height r \<le> h" using Suc(2) by(auto)
  have 3: "\<not> height l < h"
  proof
    assume 0: "height l < h"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
      using size_height[of l] size_height[of r] by arith
    also have " \<dots> < 2 ^ h + 2 ^ height r" using 0 by (simp)
    also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 2 by (simp)
    also have "\<dots> = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally have "size_kdt kdt < size_kdt kdt" .
    thus False by (simp)
  qed
  have 4: "\<not> height r < h"
  proof
    assume 0: "height r < h"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
      using size_height[of l] size_height[of r] by arith
    also have " \<dots> < 2 ^ height l + 2 ^ h" using 0 by (simp)
    also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 1 by (simp)
    also have "\<dots> = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally have "size_kdt kdt < size_kdt kdt" .
    thus False by (simp)
  qed
  from 1 2 3 4 have *: "height l = h" "height r = h" by linarith+
  hence "size_kdt l = 2 ^ height l" "size_kdt r = 2 ^ height r"
    using Suc(3) size_height[of l] size_height[of r] by (auto)
  with * Suc(1) show ?case by simp
qed

lemma complete_if_size_min_height:
  "size_kdt kdt = 2 ^ min_height kdt \<Longrightarrow> complete kdt"
proof2 (induct "min_height kdt" arbitrary: kdt)
  case 0 thus ?case by auto
next
  case (Suc h)
  hence "\<nexists>p. kdt = Leaf p"
    by auto
  then obtain k v l r where [simp]: "kdt = Node k v l r"
    using neq_Leaf_iff by metis
  have 1: "h \<le> min_height l" and 2: "h \<le> min_height r" using Suc(2) by (auto)
  have 3: "\<not> h < min_height l"
  proof
    assume 0: "h < min_height l"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also note min_height_size[of l]
    also(xtrans) note min_height_size[of r]
    also(xtrans) have "(2::nat) ^ min_height l > 2 ^ h"
        using 0 by (simp add: diff_less_mono)
    also(xtrans) have "(2::nat) ^ min_height r \<ge> 2 ^ h" using 2 by simp
    also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  have 4: "\<not> h < min_height r"
  proof
    assume 0: "h < min_height r"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also note min_height_size[of l]
    also(xtrans) note min_height_size[of r]
    also(xtrans) have "(2::nat) ^ min_height r > 2 ^ h"
        using 0 by (simp add: diff_less_mono)
    also(xtrans) have "(2::nat) ^ min_height l \<ge> 2 ^ h" using 1 by simp
    also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  from 1 2 3 4 have *: "min_height l = h" "min_height r = h" by linarith+
  hence "size_kdt l = 2 ^ min_height l" "size_kdt r = 2 ^ min_height r"
    using Suc(3) min_height_size[of l] min_height_size[of r] by (auto)
  with * Suc(1) show ?case
    by (simp add: complete_iff_height)
qed

lemma complete_iff_size:
  "complete kdt \<longleftrightarrow> size_kdt kdt = 2 ^ height kdt"
  using complete_if_size_height size_if_complete by blast

lemma size_height_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> size_kdt kdt < 2 ^ height kdt"
  by (meson antisym_conv complete_iff_size not_le size_height)

lemma min_height_size_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> 2 ^ min_height kdt < size_kdt kdt"
  by (metis complete_if_size_min_height le_less min_height_size)

lemma balanced_subtreeL:
  "balanced (Node k v l r) \<Longrightarrow> balanced l"
  by (simp add: balanced_def)

lemma balanced_subtreeR:
  "balanced (Node k v l r) \<Longrightarrow> balanced r"
  by (simp add: balanced_def)

lemma balanced_optimal:
  assumes "balanced kdt" "size_kdt kdt \<le> size_kdt kdt'"
  shows "height kdt \<le> height kdt'"
proof (cases "complete kdt")
  case True
  have "(2::nat) ^ height kdt \<le> 2 ^ height kdt'"
  proof -
    have "2 ^ height kdt = size_kdt kdt"
      using True by (simp add: complete_iff_height size_if_complete)
    also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
    also have "\<dots> \<le> 2 ^ height kdt'" by (rule size_height)
    finally show ?thesis .
  qed
  thus ?thesis by (simp)
next
  case False
  have "(2::nat) ^ min_height kdt < 2 ^ height kdt'"
  proof -
    have "(2::nat) ^ min_height kdt < size_kdt kdt"
      by(rule min_height_size_if_incomplete[OF False])
    also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
    also have "\<dots> \<le> 2 ^ height kdt'"  by(rule size_height)
    finally have "(2::nat) ^ min_height kdt < (2::nat) ^ height kdt'" .
    thus ?thesis .
  qed
  hence *: "min_height kdt < height kdt'" by simp
  have "min_height kdt + 1 = height kdt"
    using min_height_le_height[of kdt] assms(1) False
    by (simp add: complete_iff_height balanced_def)
  with * show ?thesis by arith
qed

subsection \<open>Lemmas adapted from \<open>HOL-Library.Tree_Real\<close> to \<open>k\<close>-d Tree\<close>

lemma size_height_log:
  "log 2 (size_kdt kdt) \<le> height kdt"
  by (simp add: log2_of_power_le size_height)

lemma min_height_size_log:
  "min_height kdt \<le> log 2 (size_kdt kdt)"
  by (simp add: le_log2_of_power min_height_size)

lemma size_log_if_complete:
  "complete kdt \<Longrightarrow> height kdt = log 2 (size_kdt kdt)"
  using complete_iff_size log2_of_power_eq by blast

lemma min_height_size_log_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> min_height kdt < log 2 (size_kdt kdt)"
  by (simp add: less_log2_of_power min_height_size_if_incomplete)

lemma min_height_balanced:
  assumes "balanced kdt"
  shows "min_height kdt = nat(floor(log 2 (size_kdt kdt)))"
proof cases
  assume *: "complete kdt"
  hence "size_kdt kdt = 2 ^ min_height kdt"
    by (simp add: complete_iff_height size_if_complete)
  from log2_of_power_eq[OF this] show ?thesis by linarith
next
  assume *: "\<not> complete kdt"
  hence "height kdt = min_height kdt + 1"
    using assms min_height_le_height[of kdt]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size_kdt kdt < 2 ^ (min_height kdt + 1)"
    by (metis * size_height_if_incomplete)
  hence "log 2 (size_kdt kdt) < min_height kdt + 1"
    using log2_of_power_less size_ge0 by blast
  thus ?thesis using min_height_size_log[of kdt] by linarith
qed

lemma height_balanced:
  assumes "balanced kdt"
  shows "height kdt = nat(ceiling(log 2 (size_kdt kdt)))"
proof cases
  assume *: "complete kdt"
  hence "size_kdt kdt = 2 ^ height kdt"
    by (simp add: size_if_complete)
  from log2_of_power_eq[OF this] show ?thesis
    by linarith
next
  assume *: "\<not> complete kdt"
  hence **: "height kdt = min_height kdt + 1"
    using assms min_height_le_height[of kdt]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size_kdt kdt \<le> 2 ^ (min_height kdt + 1)" by (metis size_height)
  from  log2_of_power_le[OF this size_ge0] min_height_size_log_if_incomplete[OF *] **
  show ?thesis by linarith
qed

lemma balanced_Node_if_wbal1:
  assumes "balanced l" "balanced r" "size_kdt l = size_kdt r + 1"
  shows "balanced (Node k v l r)"
proof -
  from assms(3) have [simp]: "size_kdt l = size_kdt r + 1" by simp
  have "nat \<lceil>log 2 (1 + size_kdt r)\<rceil> \<ge> nat \<lceil>log 2 (size_kdt r)\<rceil>"
    by(rule nat_mono[OF ceiling_mono]) simp
  hence 1: "height(Node k v l r) = nat \<lceil>log 2 (1 + size_kdt r)\<rceil> + 1"
    using height_balanced[OF assms(1)] height_balanced[OF assms(2)]
    by (simp del: nat_ceiling_le_eq add: max_def)
  have "nat \<lfloor>log 2 (1 + size_kdt r)\<rfloor> \<ge> nat \<lfloor>log 2 (size_kdt r)\<rfloor>"
    by(rule nat_mono[OF floor_mono]) simp
  hence 2: "min_height(Node k v l r) = nat \<lfloor>log 2 (size_kdt r)\<rfloor> + 1"
    using min_height_balanced[OF assms(1)] min_height_balanced[OF assms(2)]
    by (simp)
  have "size_kdt r \<ge> 1" by (simp add: Suc_leI)
  then obtain i where i: "2 ^ i \<le> size_kdt r" "size_kdt r < 2 ^ (i + 1)"
    using ex_power_ivl1[of 2 "size_kdt r"] by auto
  hence i1: "2 ^ i < size_kdt r + 1" "size_kdt r + 1 \<le> 2 ^ (i + 1)" by auto
  from 1 2 floor_log_nat_eq_if[OF i] ceiling_log_nat_eq_if[OF i1]
  show ?thesis by(simp add:balanced_def)
qed

lemma balanced_sym:
  "balanced (Node k v l r) \<Longrightarrow> balanced (Node k' v' r l)"
  by (auto simp: balanced_def)

lemma balanced_Node_if_wbal2:
  assumes "balanced l" "balanced r" "abs(int(size_kdt l) - int(size_kdt r)) \<le> 1"
  shows "balanced (Node k v l r)"
proof -
  have "size_kdt l = size_kdt r \<or> (size_kdt l = size_kdt r + 1 \<or> size_kdt r = size_kdt l + 1)" (is "?A \<or> ?B")
    using assms(3) by linarith
  thus ?thesis
  proof
    assume "?A"
    thus ?thesis using assms(1,2)
      apply(simp add: balanced_def min_def max_def)
      by (metis assms(1,2) balanced_optimal le_antisym le_less)
  next
    assume "?B"
    thus ?thesis
      by (meson assms(1,2) balanced_sym balanced_Node_if_wbal1)
  qed
qed

end


(* Author: Tobias Nipkow *)

section \<open>Weight-Balanced Trees Have Logarithmic Height, and More\<close>

theory Weight_Balanced_Trees_log
imports
  Complex_Main
  "HOL-Library.Tree"
begin

(* FIXME add these to field_simps *)
lemmas neq0_if = less_imp_neq dual_order.strict_implies_not_eq

subsection \<open>Logarithmic Height\<close>

text \<open>The locale below is parameterized wrt to \<open>\<Delta>\<close>. The original definition of weight-balanced trees
\<^cite>\<open>"NievergeltR72" and "NievergeltR73"\<close> uses \<open>\<alpha>\<close>. The constants \<open>\<alpha>\<close> and \<open>\<Delta>\<close> are interdefinable.
Below we start from \<open>\<Delta>\<close> but derive \<open>\<alpha>\<close>-versions of theorems as well.\<close>

locale WBT0 =
fixes \<Delta> :: real
begin

fun balanced1 :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> bool" where
"balanced1 t1 t2 = (size1 t1 \<le> \<Delta> * size1 t2)"

fun wbt :: "'a tree \<Rightarrow> bool" where
"wbt Leaf = True" |
"wbt (Node l _ r) = (balanced1 l r \<and> balanced1 r l \<and> wbt l \<and> wbt r)"

end

locale WBT1 = WBT0 +
assumes Delta: "\<Delta> \<ge> 1"
begin

definition \<alpha> :: real where
"\<alpha> = 1/(\<Delta>+1)"

lemma Delta_def: "\<Delta> = 1/\<alpha> - 1"
unfolding \<alpha>_def by auto

lemma shows alpha_pos: "0 < \<alpha>" and alpha_ub: "\<alpha> \<le> 1/2"
unfolding \<alpha>_def using Delta by auto

lemma wbt_Node_alpha: "wbt (Node l x r) =
 ((let q = size1 l / (size1 l + size1 r)
   in \<alpha> \<le> q \<and> q \<le> 1 - \<alpha>) \<and>
  wbt l \<and> wbt r)"
proof -
  have "l > 0 \<Longrightarrow> r > 0 \<Longrightarrow>
    (1/(\<Delta>+1) \<le> l/(l+r) \<longleftrightarrow> r/l \<le> \<Delta>) \<and>
    (1/(\<Delta>+1) \<le> r/(l+r) \<longleftrightarrow> l/r \<le> \<Delta>) \<and>
    (l/(l+r) \<le> 1 - 1/(\<Delta>+1) \<longleftrightarrow> l/r \<le> \<Delta>) \<and>
    (r/(l+r) \<le> 1 - 1/(\<Delta>+1) \<longleftrightarrow> r/l \<le> \<Delta>)" for l r
    using Delta by (simp add: field_simps divide_le_eq)
  thus ?thesis using Delta by(auto simp: \<alpha>_def Let_def pos_divide_le_eq add_pos_pos)
qed

lemma height_size1_Delta:
  "wbt t \<Longrightarrow> (1 + 1/\<Delta>) ^ (height t) \<le> size1 t"
proof(induction  t)
  case Leaf thus ?case by simp
next
  case (Node l a r)
  let ?t = "Node l a r" let ?s = "size1 ?t" let ?d = "1 + 1/\<Delta>"
  from Node.prems(1) have 1: "size1 l * ?d \<le> ?s" and 2: "size1 r * ?d  \<le> ?s"
    using Delta by (auto simp: Let_def field_simps add_pos_pos neq0_if)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    hence "?d ^ (height ?t) = ?d ^ (height r) * ?d" by(simp)
    also have "\<dots> \<le> size1 r * ?d"
      using Node.IH(2) Node.prems Delta unfolding wbt.simps
      by (smt (verit) divide_nonneg_nonneg mult_mono of_nat_0_le_iff)
    also have "\<dots> \<le> ?s" using 2 by (simp)
    finally show ?thesis .
  next
    case False
    hence "?d ^ (height ?t) = ?d ^ (height l) * ?d" by(simp)
    also have "\<dots> \<le> size1 l * ?d"
      using Node.IH(1) Node.prems Delta unfolding wbt.simps
      by (smt (verit) divide_nonneg_nonneg mult_mono of_nat_0_le_iff)
    also have "\<dots> \<le> ?s" using 1 by (simp)
    finally show ?thesis .
  qed
qed

lemma height_size1_alpha:
  "wbt t \<Longrightarrow> (1/(1-\<alpha>)) ^ (height t) \<le> size1 t"
proof(induction  t)
  case Leaf thus ?case by simp
next
  note wbt.simps[simp del] wbt_Node_alpha[simp]
  case (Node l a r)
  let ?t = "Node l a r" let ?s = "size1 ?t"
  from Node.prems(1) have 1: "size1 l / (1-\<alpha>) \<le> ?s" and 2: "size1 r / (1-\<alpha>)  \<le> ?s"
    using alpha_ub by (auto simp: Let_def field_simps add_pos_pos neq0_if)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    hence "(1/(1-\<alpha>)) ^ (height ?t) = (1/(1-\<alpha>)) ^ (height r) * (1/(1-\<alpha>))" by(simp)
    also have "\<dots> \<le> size1 r * (1/(1-\<alpha>))"
      using Node.IH(2) Node.prems unfolding wbt_Node_alpha
      by (smt (verit) mult_right_mono zero_le_divide_1_iff)
    also have "\<dots> \<le> ?s" using 2 by (simp)
    finally show ?thesis .
  next
    case False
    hence "(1/(1-\<alpha>)) ^ (height ?t) = (1/(1-\<alpha>)) ^ (height l) * (1/(1-\<alpha>))" by(simp)
    also have "\<dots> \<le> size1 l * (1/(1-\<alpha>))"
      using Node.IH(1) Node.prems unfolding wbt_Node_alpha
      by (smt (verit) mult_right_mono zero_le_divide_1_iff)
    also have "\<dots> \<le> ?s" using 1 by (simp)
    finally show ?thesis .
  qed
qed

lemma height_size1_log_Delta: assumes "wbt t"
shows "height t \<le> log 2 (size1 t) / log 2 (1 + 1/\<Delta>)"
proof -
  from height_size1_Delta[OF assms]
  have "height t \<le> log (1 + 1/\<Delta>) (size1 t)"
    using Delta le_log_of_power by auto
  also have "\<dots> = log 2 (size1 t) / log 2 (1 + 1/\<Delta>)"
    by (simp add: log_base_change)
  finally show ?thesis .
qed

lemma height_size1_log_alpha: assumes "wbt t"
shows "height t \<le> log 2 (size1 t) / log 2 (1/(1-\<alpha>))"
proof -
  from height_size1_alpha[OF assms]
  have "height t \<le> log (1/(1-\<alpha>)) (size1 t)"
    using alpha_pos alpha_ub le_log_of_power by auto
  also have "\<dots> = log 2 (size1 t) / log 2 (1/(1-\<alpha>))"
    by (simp add: log_base_change)
  finally show ?thesis .
qed

end

subsection \<open>Every \<open>1 \<le> \<Delta> < 2\<close> Yields Exactly the Complete Trees\<close>

declare WBT0.wbt.simps [simp] WBT0.balanced1.simps [simp]

lemma wbt1_if_complete: assumes "1 \<le> \<Delta>" shows "complete t \<Longrightarrow> WBT0.wbt \<Delta> t"
apply(induction t)
 apply simp
apply (simp add: assms size1_if_complete)
done

lemma complete_if_wbt2: assumes "\<Delta> < 2" shows "WBT0.wbt \<Delta> t \<Longrightarrow> complete t"
proof(induction t)
  case Leaf
  then show ?case by simp
next
  case (Node t1 x t2)
  let ?h1 = "height t1" let ?h2 = "height t2"
  from Node have *: "complete t1 \<and> complete t2" by auto
  hence sz: "size1 t1 = 2 ^ ?h1 \<and> size1 t2 = 2 ^ ?h2"
    using size1_if_complete by blast
  show ?case
  proof (rule ccontr)
    assume "\<not> complete \<langle>t1, x, t2\<rangle>"
    hence "?h1 \<noteq> ?h2" using * by auto
    thus False
    proof (cases "?h1 < ?h2")
      case True
      hence "2 * (2::real) ^ ?h1 \<le> 2 ^ ?h2"
        by (metis Suc_leI one_le_numeral power_Suc power_increasing)
      also have "\<dots> \<le> \<Delta> * 2 ^ ?h1" using sz Node.prems by (simp)
      finally show False using \<open>\<Delta> < 2\<close> by simp
    next
      case False
      with \<open>?h1 \<noteq> ?h2\<close> have "?h2 < ?h1" by linarith
      hence "2 * (2::real) ^ ?h2 \<le> 2 ^ ?h1"
        by (metis Suc_leI one_le_numeral power_Suc power_increasing)
      also have "\<dots> \<le> \<Delta> * 2 ^ ?h2" using sz Node.prems by (simp)
      finally show False using \<open>\<Delta> < 2\<close> by simp
    qed
  qed
qed

end


theory week01B_demo imports Main begin

text "lambda terms"

term "\<lambda>x. x"

text "alpha"

thm refl

lemma "(\<lambda>x. x) = (\<lambda>y. y)"
  apply (rule refl)
  done

text "eta"

term "\<lambda>x. f x"

text "beta"

term "(\<lambda>x. x y) t"

text {* beta with renaming *}

term "(\<lambda>z. (\<lambda>x. f x z)) x"

text "definitions and unfold"

definition
  c_0 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "c_0 \<equiv> \<lambda>f x. x"

definition
  c_1 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "c_1 \<equiv> \<lambda>f x. f x"

definition
  c_2 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "c_2 \<equiv> \<lambda>f x. f (f x)"

definition
  c_3 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "c_3 \<equiv> \<lambda>f x. f (f (f x))"

definition
  succ :: "(('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "succ \<equiv> \<lambda>n f x. f (n f x)"

definition
  add :: "(('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> (('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow>
          ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "add \<equiv> \<lambda>m n f x. m f (n f x)"

definition
  mult :: "(('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> (('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow>
          ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "mult \<equiv> \<lambda>m n f x. m (n f) x"

text "unfolding a definition"

lemma "c_0 = (\<lambda>f x. x)"
  apply (unfold c_0_def)
  apply (rule refl)
  done

lemma "succ (succ c_0) = c_2"
  apply (unfold succ_def c_0_def c_2_def)
  apply (rule refl)
  done

lemma "add c_2 c_2 = succ c_3"
  apply (unfold add_def succ_def c_3_def c_2_def)
  apply (rule refl)
  done

lemma "add x c_0 = x"
  apply (unfold add_def c_0_def)
  apply (rule refl)
  done

lemma "mult c_1 x = x"
  apply (unfold mult_def c_1_def)
  apply (rule refl)
  done

end


(*  Title:      HOL/Decision_Procs/Rat_Pair.thy
    Author:     Amine Chaieb
*)

section {* Rational numbers as pairs *}

theory Rat_Pair
imports Complex_Main
begin

type_synonym Num = "int \<times> int"

abbreviation Num0_syn :: Num  ("0\<^sub>N")
  where "0\<^sub>N \<equiv> (0, 0)"

abbreviation Numi_syn :: "int \<Rightarrow> Num"  ("'((_)')\<^sub>N")
  where "(i)\<^sub>N \<equiv> (i, 1)"

definition isnormNum :: "Num \<Rightarrow> bool" where
  "isnormNum = (\<lambda>(a,b). (if a = 0 then b = 0 else b > 0 \<and> gcd a b = 1))"

definition normNum :: "Num \<Rightarrow> Num" where
  "normNum = (\<lambda>(a,b).
    (if a=0 \<or> b = 0 then (0,0) else
      (let g = gcd a b
       in if b > 0 then (a div g, b div g) else (- (a div g), - (b div g)))))"

declare gcd_dvd1_int[presburger] gcd_dvd2_int[presburger]

lemma normNum_isnormNum [simp]: "isnormNum (normNum x)"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  { assume "a=0 \<or> b = 0" hence ?thesis by (simp add: x normNum_def isnormNum_def) }
  moreover
  { assume anz: "a \<noteq> 0" and bnz: "b \<noteq> 0"
    let ?g = "gcd a b"
    let ?a' = "a div ?g"
    let ?b' = "b div ?g"
    let ?g' = "gcd ?a' ?b'"
    from anz bnz have "?g \<noteq> 0" by simp  with gcd_ge_0_int[of a b]
    have gpos: "?g > 0" by arith
    have gdvd: "?g dvd a" "?g dvd b" by arith+
    from dvd_mult_div_cancel[OF gdvd(1)] dvd_mult_div_cancel[OF gdvd(2)] anz bnz
    have nz': "?a' \<noteq> 0" "?b' \<noteq> 0" by - (rule notI, simp)+
    from anz bnz have stupid: "a \<noteq> 0 \<or> b \<noteq> 0" by arith
    from div_gcd_coprime_int[OF stupid] have gp1: "?g' = 1" .
    from bnz have "b < 0 \<or> b > 0" by arith
    moreover
    { assume b: "b > 0"
      from b have "?b' \<ge> 0"
        by (presburger add: pos_imp_zdiv_nonneg_iff[OF gpos])
      with nz' have b': "?b' > 0" by arith
      from b b' anz bnz nz' gp1 have ?thesis
        by (simp add: x isnormNum_def normNum_def Let_def split_def) }
    moreover {
      assume b: "b < 0"
      { assume b': "?b' \<ge> 0"
        from gpos have th: "?g \<ge> 0" by arith
        from mult_nonneg_nonneg[OF th b'] dvd_mult_div_cancel[OF gdvd(2)]
        have False using b by arith }
      hence b': "?b' < 0" by (presburger add: linorder_not_le[symmetric])
      from anz bnz nz' b b' gp1 have ?thesis
        by (simp add: x isnormNum_def normNum_def Let_def split_def) }
    ultimately have ?thesis by blast
  }
  ultimately show ?thesis by blast
qed

text {* Arithmetic over Num *}

definition Nadd :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl "+\<^sub>N" 60) where
  "Nadd = (\<lambda>(a,b) (a',b'). if a = 0 \<or> b = 0 then normNum(a',b')
    else if a'=0 \<or> b' = 0 then normNum(a,b)
    else normNum(a*b' + b*a', b*b'))"

definition Nmul :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl "*\<^sub>N" 60) where
  "Nmul = (\<lambda>(a,b) (a',b'). let g = gcd (a*a') (b*b')
    in (a*a' div g, b*b' div g))"

definition Nneg :: "Num \<Rightarrow> Num" ("~\<^sub>N")
  where "Nneg \<equiv> (\<lambda>(a,b). (-a,b))"

definition Nsub :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl "-\<^sub>N" 60)
  where "Nsub = (\<lambda>a b. a +\<^sub>N ~\<^sub>N b)"

definition Ninv :: "Num \<Rightarrow> Num"
  where "Ninv = (\<lambda>(a,b). if a < 0 then (-b, \<bar>a\<bar>) else (b,a))"

definition Ndiv :: "Num \<Rightarrow> Num \<Rightarrow> Num"  (infixl "\<div>\<^sub>N" 60)
  where "Ndiv = (\<lambda>a b. a *\<^sub>N Ninv b)"

lemma Nneg_normN[simp]: "isnormNum x \<Longrightarrow> isnormNum (~\<^sub>N x)"
  by (simp add: isnormNum_def Nneg_def split_def)

lemma Nadd_normN[simp]: "isnormNum (x +\<^sub>N y)"
  by (simp add: Nadd_def split_def)

lemma Nsub_normN[simp]: "\<lbrakk> isnormNum y\<rbrakk> \<Longrightarrow> isnormNum (x -\<^sub>N y)"
  by (simp add: Nsub_def split_def)

lemma Nmul_normN[simp]:
  assumes xn: "isnormNum x" and yn: "isnormNum y"
  shows "isnormNum (x *\<^sub>N y)"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  { assume "a = 0"
    hence ?thesis using xn x y
      by (simp add: isnormNum_def Let_def Nmul_def split_def) }
  moreover
  { assume "a' = 0"
    hence ?thesis using yn x y
      by (simp add: isnormNum_def Let_def Nmul_def split_def) }
  moreover
  { assume a: "a \<noteq>0" and a': "a'\<noteq>0"
    hence bp: "b > 0" "b' > 0" using xn yn x y by (simp_all add: isnormNum_def)
    from bp have "x *\<^sub>N y = normNum (a * a', b * b')"
      using x y a a' bp by (simp add: Nmul_def Let_def split_def normNum_def)
    hence ?thesis by simp }
  ultimately show ?thesis by blast
qed

lemma Ninv_normN[simp]: "isnormNum x \<Longrightarrow> isnormNum (Ninv x)"
  by (simp add: Ninv_def isnormNum_def split_def)
    (cases "fst x = 0", auto simp add: gcd_commute_int)

lemma isnormNum_int[simp]:
  "isnormNum 0\<^sub>N" "isnormNum ((1::int)\<^sub>N)" "i \<noteq> 0 \<Longrightarrow> isnormNum (i)\<^sub>N"
  by (simp_all add: isnormNum_def)

text {* Relations over Num *}

definition Nlt0:: "Num \<Rightarrow> bool"  ("0>\<^sub>N")
  where "Nlt0 = (\<lambda>(a,b). a < 0)"

definition Nle0:: "Num \<Rightarrow> bool"  ("0\<ge>\<^sub>N")
  where "Nle0 = (\<lambda>(a,b). a \<le> 0)"

definition Ngt0:: "Num \<Rightarrow> bool"  ("0<\<^sub>N")
  where "Ngt0 = (\<lambda>(a,b). a > 0)"

definition Nge0:: "Num \<Rightarrow> bool"  ("0\<le>\<^sub>N")
  where "Nge0 = (\<lambda>(a,b). a \<ge> 0)"

definition Nlt :: "Num \<Rightarrow> Num \<Rightarrow> bool"  (infix "<\<^sub>N" 55)
  where "Nlt = (\<lambda>a b. 0>\<^sub>N (a -\<^sub>N b))"

definition Nle :: "Num \<Rightarrow> Num \<Rightarrow> bool"  (infix "\<le>\<^sub>N" 55)
  where "Nle = (\<lambda>a b. 0\<ge>\<^sub>N (a -\<^sub>N b))"

definition "INum = (\<lambda>(a,b). of_int a / of_int b)"

lemma INum_int [simp]: "INum (i)\<^sub>N = ((of_int i) ::'a::field)" "INum 0\<^sub>N = (0::'a::field)"
  by (simp_all add: INum_def)

lemma isnormNum_unique[simp]:
  assumes na: "isnormNum x" and nb: "isnormNum y"
  shows "((INum x ::'a::{field_char_0, field_inverse_zero}) = INum y) = (x = y)" (is "?lhs = ?rhs")
proof
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  assume H: ?lhs
  { assume "a = 0 \<or> b = 0 \<or> a' = 0 \<or> b' = 0"
    hence ?rhs using na nb H
      by (simp add: x y INum_def split_def isnormNum_def split: split_if_asm) }
  moreover
  { assume az: "a \<noteq> 0" and bz: "b \<noteq> 0" and a'z: "a'\<noteq>0" and b'z: "b'\<noteq>0"
    from az bz a'z b'z na nb have pos: "b > 0" "b' > 0" by (simp_all add: x y isnormNum_def)
    from H bz b'z have eq: "a * b' = a'*b"
      by (simp add: x y INum_def eq_divide_eq divide_eq_eq of_int_mult[symmetric] del: of_int_mult)
    from az a'z na nb have gcd1: "gcd a b = 1" "gcd b a = 1" "gcd a' b' = 1" "gcd b' a' = 1"
      by (simp_all add: x y isnormNum_def add: gcd_commute_int)
    from eq have raw_dvd: "a dvd a' * b" "b dvd b' * a" "a' dvd a * b'" "b' dvd b * a'"
      apply -
      apply algebra
      apply algebra
      apply simp
      apply algebra
      done
    from zdvd_antisym_abs[OF coprime_dvd_mult_int[OF gcd1(2) raw_dvd(2)]
        coprime_dvd_mult_int[OF gcd1(4) raw_dvd(4)]]
      have eq1: "b = b'" using pos by arith
      with eq have "a = a'" using pos by simp
      with eq1 have ?rhs by (simp add: x y) }
  ultimately show ?rhs by blast
next
  assume ?rhs thus ?lhs by simp
qed

lemma isnormNum0[simp]:
    "isnormNum x \<Longrightarrow> (INum x = (0::'a::{field_char_0, field_inverse_zero})) = (x = 0\<^sub>N)"
  unfolding INum_int(2)[symmetric]
  by (rule isnormNum_unique) simp_all

lemma of_int_div_aux: "d ~= 0 ==> ((of_int x)::'a::field_char_0) / (of_int d) =
    of_int (x div d) + (of_int (x mod d)) / ((of_int d)::'a)"
proof -
  assume "d ~= 0"
  let ?t = "of_int (x div d) * ((of_int d)::'a) + of_int(x mod d)"
  let ?f = "\<lambda>x. x / of_int d"
  have "x = (x div d) * d + x mod d"
    by auto
  then have eq: "of_int x = ?t"
    by (simp only: of_int_mult[symmetric] of_int_add [symmetric])
  then have "of_int x / of_int d = ?t / of_int d"
    using cong[OF refl[of ?f] eq] by simp
  then show ?thesis by (simp add: add_divide_distrib algebra_simps `d ~= 0`)
qed

lemma of_int_div: "(d::int) ~= 0 ==> d dvd n ==>
    (of_int(n div d)::'a::field_char_0) = of_int n / of_int d"
  using of_int_div_aux [of d n, where ?'a = 'a] by simp

lemma normNum[simp]: "INum (normNum x) = (INum x :: 'a::{field_char_0, field_inverse_zero})"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  { assume "a = 0 \<or> b = 0"
    hence ?thesis by (simp add: x INum_def normNum_def split_def Let_def) }
  moreover
  { assume a: "a \<noteq> 0" and b: "b \<noteq> 0"
    let ?g = "gcd a b"
    from a b have g: "?g \<noteq> 0"by simp
    from of_int_div[OF g, where ?'a = 'a]
    have ?thesis by (auto simp add: x INum_def normNum_def split_def Let_def) }
  ultimately show ?thesis by blast
qed

lemma INum_normNum_iff:
  "(INum x ::'a::{field_char_0, field_inverse_zero}) = INum y \<longleftrightarrow> normNum x = normNum y"
  (is "?lhs = ?rhs")
proof -
  have "normNum x = normNum y \<longleftrightarrow> (INum (normNum x) :: 'a) = INum (normNum y)"
    by (simp del: normNum)
  also have "\<dots> = ?lhs" by simp
  finally show ?thesis by simp
qed

lemma Nadd[simp]: "INum (x +\<^sub>N y) = INum x + (INum y :: 'a :: {field_char_0, field_inverse_zero})"
proof -
  let ?z = "0:: 'a"
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  { assume "a=0 \<or> a'= 0 \<or> b =0 \<or> b' = 0"
    hence ?thesis
      apply (cases "a=0", simp_all add: x y Nadd_def)
      apply (cases "b= 0", simp_all add: INum_def)
       apply (cases "a'= 0", simp_all)
       apply (cases "b'= 0", simp_all)
       done }
  moreover
  { assume aa': "a \<noteq> 0" "a'\<noteq> 0" and bb': "b \<noteq> 0" "b' \<noteq> 0"
    { assume z: "a * b' + b * a' = 0"
      hence "of_int (a*b' + b*a') / (of_int b* of_int b') = ?z" by simp
      hence "of_int b' * of_int a / (of_int b * of_int b') +
          of_int b * of_int a' / (of_int b * of_int b') = ?z"
        by (simp add:add_divide_distrib)
      hence th: "of_int a / of_int b + of_int a' / of_int b' = ?z" using bb' aa'
        by simp
      from z aa' bb' have ?thesis
        by (simp add: x y th Nadd_def normNum_def INum_def split_def) }
    moreover {
      assume z: "a * b' + b * a' \<noteq> 0"
      let ?g = "gcd (a * b' + b * a') (b * b')"
      have gz: "?g \<noteq> 0" using z by simp
      have ?thesis using aa' bb' z gz
        of_int_div [where ?'a = 'a, OF gz gcd_dvd1 [of "a * b' + b * a'" "b * b'"]]
        of_int_div [where ?'a = 'a, OF gz gcd_dvd2 [of "a * b' + b * a'" "b * b'"]]
        by (simp add: x y Nadd_def INum_def normNum_def Let_def) (simp add: field_simps)
    }
    ultimately have ?thesis using aa' bb'
      by (simp add: x y Nadd_def INum_def normNum_def Let_def) }
  ultimately show ?thesis by blast
qed

lemma Nmul[simp]: "INum (x *\<^sub>N y) = INum x * (INum y:: 'a :: {field_char_0, field_inverse_zero})"
proof -
  let ?z = "0::'a"
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  { assume "a=0 \<or> a'= 0 \<or> b = 0 \<or> b' = 0"
    hence ?thesis
      apply (cases "a=0", simp_all add: x y Nmul_def INum_def Let_def)
      apply (cases "b=0", simp_all)
      apply (cases "a'=0", simp_all)
      done }
  moreover
  { assume z: "a \<noteq> 0" "a' \<noteq> 0" "b \<noteq> 0" "b' \<noteq> 0"
    let ?g="gcd (a*a') (b*b')"
    have gz: "?g \<noteq> 0" using z by simp
    from z of_int_div [where ?'a = 'a, OF gz gcd_dvd1 [of "a * a'" "b * b'"]]
      of_int_div [where ?'a = 'a , OF gz gcd_dvd2 [of "a * a'" "b * b'"]]
    have ?thesis by (simp add: Nmul_def x y Let_def INum_def) }
  ultimately show ?thesis by blast
qed

lemma Nneg[simp]: "INum (~\<^sub>N x) = - (INum x ::'a:: field)"
  by (simp add: Nneg_def split_def INum_def)

lemma Nsub[simp]: "INum (x -\<^sub>N y) = INum x - (INum y:: 'a :: {field_char_0, field_inverse_zero})"
  by (simp add: Nsub_def split_def)

lemma Ninv[simp]: "INum (Ninv x) = (1::'a :: field_inverse_zero) / (INum x)"
  by (simp add: Ninv_def INum_def split_def)

lemma Ndiv[simp]: "INum (x \<div>\<^sub>N y) = INum x / (INum y ::'a :: {field_char_0, field_inverse_zero})"
  by (simp add: Ndiv_def)

lemma Nlt0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero})< 0) = 0>\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  { assume "a = 0" hence ?thesis by (simp add: x Nlt0_def INum_def) }
  moreover
  { assume a: "a \<noteq> 0" hence b: "(of_int b::'a) > 0"
      using nx by (simp add: x isnormNum_def)
    from pos_divide_less_eq[OF b, where b="of_int a" and a="0::'a"]
    have ?thesis by (simp add: x Nlt0_def INum_def) }
  ultimately show ?thesis by blast
qed

lemma Nle0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero}) \<le> 0) = 0\<ge>\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  { assume "a = 0" hence ?thesis by (simp add: x Nle0_def INum_def) }
  moreover
  { assume a: "a \<noteq> 0" hence b: "(of_int b :: 'a) > 0"
      using nx by (simp add: x isnormNum_def)
    from pos_divide_le_eq[OF b, where b="of_int a" and a="0::'a"]
    have ?thesis by (simp add: x Nle0_def INum_def) }
  ultimately show ?thesis by blast
qed

lemma Ngt0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero})> 0) = 0<\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  { assume "a = 0" hence ?thesis by (simp add: x Ngt0_def INum_def) }
  moreover
  { assume a: "a \<noteq> 0" hence b: "(of_int b::'a) > 0" using nx
      by (simp add: x isnormNum_def)
    from pos_less_divide_eq[OF b, where b="of_int a" and a="0::'a"]
    have ?thesis by (simp add: x Ngt0_def INum_def) }
  ultimately show ?thesis by blast
qed

lemma Nge0_iff[simp]:
  assumes nx: "isnormNum x"
  shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero}) \<ge> 0) = 0\<le>\<^sub>N x"
proof -
  obtain a b where x: "x = (a, b)" by (cases x)
  { assume "a = 0" hence ?thesis by (simp add: x Nge0_def INum_def) }
  moreover
  { assume "a \<noteq> 0" hence b: "(of_int b::'a) > 0" using nx
      by (simp add: x isnormNum_def)
    from pos_le_divide_eq[OF b, where b="of_int a" and a="0::'a"]
    have ?thesis by (simp add: x Nge0_def INum_def) }
  ultimately show ?thesis by blast
qed

lemma Nlt_iff[simp]:
  assumes nx: "isnormNum x" and ny: "isnormNum y"
  shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero}) < INum y) = (x <\<^sub>N y)"
proof -
  let ?z = "0::'a"
  have "((INum x ::'a) < INum y) = (INum (x -\<^sub>N y) < ?z)"
    using nx ny by simp
  also have "\<dots> = (0>\<^sub>N (x -\<^sub>N y))"
    using Nlt0_iff[OF Nsub_normN[OF ny]] by simp
  finally show ?thesis by (simp add: Nlt_def)
qed

lemma Nle_iff[simp]:
  assumes nx: "isnormNum x" and ny: "isnormNum y"
  shows "((INum x :: 'a :: {field_char_0, linordered_field_inverse_zero})\<le> INum y) = (x \<le>\<^sub>N y)"
proof -
  have "((INum x ::'a) \<le> INum y) = (INum (x -\<^sub>N y) \<le> (0::'a))"
    using nx ny by simp
  also have "\<dots> = (0\<ge>\<^sub>N (x -\<^sub>N y))"
    using Nle0_iff[OF Nsub_normN[OF ny]] by simp
  finally show ?thesis by (simp add: Nle_def)
qed

lemma Nadd_commute:
  assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
  shows "x +\<^sub>N y = y +\<^sub>N x"
proof -
  have n: "isnormNum (x +\<^sub>N y)" "isnormNum (y +\<^sub>N x)" by simp_all
  have "(INum (x +\<^sub>N y)::'a) = INum (y +\<^sub>N x)" by simp
  with isnormNum_unique[OF n] show ?thesis by simp
qed

lemma normNum_nilpotent_aux[simp]:
  assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
  assumes nx: "isnormNum x"
  shows "normNum x = x"
proof -
  let ?a = "normNum x"
  have n: "isnormNum ?a" by simp
  have th: "INum ?a = (INum x ::'a)" by simp
  with isnormNum_unique[OF n nx] show ?thesis by simp
qed

lemma normNum_nilpotent[simp]:
  assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
  shows "normNum (normNum x) = normNum x"
  by simp

lemma normNum0[simp]: "normNum (0,b) = 0\<^sub>N" "normNum (a,0) = 0\<^sub>N"
  by (simp_all add: normNum_def)

lemma normNum_Nadd:
  assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
  shows "normNum (x +\<^sub>N y) = x +\<^sub>N y" by simp

lemma Nadd_normNum1[simp]:
  assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
  shows "normNum x +\<^sub>N y = x +\<^sub>N y"
proof -
  have n: "isnormNum (normNum x +\<^sub>N y)" "isnormNum (x +\<^sub>N y)" by simp_all
  have "INum (normNum x +\<^sub>N y) = INum x + (INum y :: 'a)" by simp
  also have "\<dots> = INum (x +\<^sub>N y)" by simp
  finally show ?thesis using isnormNum_unique[OF n] by simp
qed

lemma Nadd_normNum2[simp]:
  assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
  shows "x +\<^sub>N normNum y = x +\<^sub>N y"
proof -
  have n: "isnormNum (x +\<^sub>N normNum y)" "isnormNum (x +\<^sub>N y)" by simp_all
  have "INum (x +\<^sub>N normNum y) = INum x + (INum y :: 'a)" by simp
  also have "\<dots> = INum (x +\<^sub>N y)" by simp
  finally show ?thesis using isnormNum_unique[OF n] by simp
qed

lemma Nadd_assoc:
  assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
  shows "x +\<^sub>N y +\<^sub>N z = x +\<^sub>N (y +\<^sub>N z)"
proof -
  have n: "isnormNum (x +\<^sub>N y +\<^sub>N z)" "isnormNum (x +\<^sub>N (y +\<^sub>N z))" by simp_all
  have "INum (x +\<^sub>N y +\<^sub>N z) = (INum (x +\<^sub>N (y +\<^sub>N z)) :: 'a)" by simp
  with isnormNum_unique[OF n] show ?thesis by simp
qed

lemma Nmul_commute: "isnormNum x \<Longrightarrow> isnormNum y \<Longrightarrow> x *\<^sub>N y = y *\<^sub>N x"
  by (simp add: Nmul_def split_def Let_def gcd_commute_int mult.commute)

lemma Nmul_assoc:
  assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
  assumes nx: "isnormNum x" and ny: "isnormNum y" and nz: "isnormNum z"
  shows "x *\<^sub>N y *\<^sub>N z = x *\<^sub>N (y *\<^sub>N z)"
proof -
  from nx ny nz have n: "isnormNum (x *\<^sub>N y *\<^sub>N z)" "isnormNum (x *\<^sub>N (y *\<^sub>N z))"
    by simp_all
  have "INum (x +\<^sub>N y +\<^sub>N z) = (INum (x +\<^sub>N (y +\<^sub>N z)) :: 'a)" by simp
  with isnormNum_unique[OF n] show ?thesis by simp
qed

lemma Nsub0:
  assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
  assumes x: "isnormNum x" and y: "isnormNum y"
  shows "x -\<^sub>N y = 0\<^sub>N \<longleftrightarrow> x = y"
proof -
  fix h :: 'a
  from isnormNum_unique[where 'a = 'a, OF Nsub_normN[OF y], where y="0\<^sub>N"]
  have "(x -\<^sub>N y = 0\<^sub>N) = (INum (x -\<^sub>N y) = (INum 0\<^sub>N :: 'a)) " by simp
  also have "\<dots> = (INum x = (INum y :: 'a))" by simp
  also have "\<dots> = (x = y)" using x y by simp
  finally show ?thesis .
qed

lemma Nmul0[simp]: "c *\<^sub>N 0\<^sub>N = 0\<^sub>N" " 0\<^sub>N *\<^sub>N c = 0\<^sub>N"
  by (simp_all add: Nmul_def Let_def split_def)

lemma Nmul_eq0[simp]:
  assumes "SORT_CONSTRAINT('a::{field_char_0, field_inverse_zero})"
  assumes nx: "isnormNum x" and ny: "isnormNum y"
  shows "x*\<^sub>N y = 0\<^sub>N \<longleftrightarrow> x = 0\<^sub>N \<or> y = 0\<^sub>N"
proof -
  fix h :: 'a
  obtain a b where x: "x = (a, b)" by (cases x)
  obtain a' b' where y: "y = (a', b')" by (cases y)
  have n0: "isnormNum 0\<^sub>N" by simp
  show ?thesis using nx ny
    apply (simp only: isnormNum_unique[where ?'a = 'a, OF  Nmul_normN[OF nx ny] n0, symmetric]
      Nmul[where ?'a = 'a])
    apply (simp add: x y INum_def split_def isnormNum_def split: split_if_asm)
    done
qed

lemma Nneg_Nneg[simp]: "~\<^sub>N (~\<^sub>N c) = c"
  by (simp add: Nneg_def split_def)

lemma Nmul1[simp]:
    "isnormNum c \<Longrightarrow> (1)\<^sub>N *\<^sub>N c = c"
    "isnormNum c \<Longrightarrow> c *\<^sub>N (1)\<^sub>N = c"
  apply (simp_all add: Nmul_def Let_def split_def isnormNum_def)
  apply (cases "fst c = 0", simp_all, cases c, simp_all)+
  done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_NStoogeSort2Sorts
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
  "third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function twoThirds :: "Nat => Nat" where
  "twoThirds y =
   (if (y = (S (S Z))) then S Z else
      (if (y = (S Z)) then S Z else
         (case y of
            Z => Z
            | S z => plus (S (S Z)) (twoThirds (minus y (S (S (S Z))))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((le z y2) & (ordered (cons2 y2 xs)))"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "Nat list => Nat list"
  and nstoogesort2 :: "Nat list => Nat list"
  and nstooge2sort1 :: "Nat list => Nat list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "ordered (nstoogesort2 xs)"
  oops

end


theory int_mul_comm
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Sign = Pos | Neg

datatype Nat = Zero | Succ "Nat"

datatype Z = P "Nat" | N "Nat"

fun toInteger :: "Sign => Nat => Z" where
"toInteger (Pos) y = P y"
| "toInteger (Neg) (Zero) = P Zero"
| "toInteger (Neg) (Succ m) = N m"

fun sign2 :: "Z => Sign" where
"sign2 (P y) = Pos"
| "sign2 (N z) = Neg"

fun plus :: "Nat => Nat => Nat" where
"plus (Zero) y = y"
| "plus (Succ n) y = Succ (plus n y)"

fun opposite :: "Sign => Sign" where
"opposite (Pos) = Neg"
| "opposite (Neg) = Pos"

fun timesSign :: "Sign => Sign => Sign" where
"timesSign (Pos) y = y"
| "timesSign (Neg) y = opposite y"

fun mult :: "Nat => Nat => Nat" where
"mult (Zero) y = Zero"
| "mult (Succ n) y = plus y (mult n y)"

fun absVal :: "Z => Nat" where
"absVal (P n) = n"
| "absVal (N m) = Succ m"

fun times :: "Z => Z => Z" where
"times x y =
   toInteger
     (timesSign (sign2 x) (sign2 y)) (mult (absVal x) (absVal y))"

(*hipster toInteger
          sign2
          plus
          opposite
          timesSign
          mult
          absVal
          times *)

theorem x0 :
  "!! (x :: Z) (y :: Z) . (times x y) = (times y x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Periodic_Fun
imports Complex_Main
begin

lemma sin_plus_pi: "sin ((z :: 'a :: {real_normed_field,banach}) + of_real pi) = - sin z"
  by (simp add: sin_add)

lemma cos_plus_pi: "cos ((z :: 'a :: {real_normed_field,banach}) + of_real pi) = - cos z"
  by (simp add: cos_add)

locale periodic_fun =
  fixes f :: "('a :: {ring_1}) \<Rightarrow> 'b" and g gm :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" and g1 gn1 :: "'a \<Rightarrow> 'a"
  assumes plus_1: "f (g1 x) = f x"
  assumes periodic_arg_plus_0: "g x 0 = x"
  assumes periodic_arg_plus_distrib: "g x (of_int (m + n)) = g (g x (of_int n)) (of_int m)"
  assumes plus_1_eq: "g x 1 = g1 x" and minus_1_eq: "g x (-1) = gn1 x"
          and minus_eq: "g x (-y) = gm x y"
begin

lemma plus_of_nat: "f (g x (of_nat n)) = f x"
  by (induction n) (insert periodic_arg_plus_distrib[of _ 1 "int n" for n],
                    simp_all add: plus_1 periodic_arg_plus_0 plus_1_eq)

lemma minus_of_nat: "f (gm x (of_nat n)) = f x"
proof -
  have "f (g x (- of_nat n)) = f (g (g x (- of_nat n)) (of_nat n))"
    by (rule plus_of_nat[symmetric])
  also have "\<dots> = f (g (g x (of_int (- of_nat n))) (of_int (of_nat n)))" by simp
  also have "\<dots> = f x"
    by (subst periodic_arg_plus_distrib [symmetric]) (simp add: periodic_arg_plus_0)
  finally show ?thesis by (simp add: minus_eq)
qed

lemma plus_of_int: "f (g x (of_int n)) = f x"
  by (induction n) (simp_all add: plus_of_nat minus_of_nat minus_eq del: of_nat_Suc)

lemma minus_of_int: "f (gm x (of_int n)) = f x"
  using plus_of_int[of x "of_int (-n)"] by (simp add: minus_eq)

lemma plus_numeral: "f (g x (numeral n)) = f x"
  by (subst of_nat_numeral[symmetric], subst plus_of_nat) (rule refl)

lemma minus_numeral: "f (gm x (numeral n)) = f x"
  by (subst of_nat_numeral[symmetric], subst minus_of_nat) (rule refl)

lemma minus_1: "f (gn1 x) = f x"
  using minus_of_nat[of x 1] by (simp add: minus_1_eq minus_eq[symmetric])

lemmas periodic_simps = plus_of_nat minus_of_nat plus_of_int minus_of_int
                        plus_numeral minus_numeral plus_1 minus_1

end

locale periodic_fun_simple =
  fixes f :: "('a :: {ring_1}) \<Rightarrow> 'b" and period :: 'a
  assumes plus_period: "f (x + period) = f x"
begin
sublocale periodic_fun f "\<lambda>z x. z + x * period" "\<lambda>z x. z - x * period"
  "\<lambda>z. z + period" "\<lambda>z. z - period"
  by standard (simp_all add: ring_distribs plus_period)
end

locale periodic_fun_simple' =
  fixes f :: "('a :: {ring_1}) \<Rightarrow> 'b"
  assumes plus_period: "f (x + 1) = f x"
begin
sublocale periodic_fun f "\<lambda>z x. z + x" "\<lambda>z x. z - x" "\<lambda>z. z + 1" "\<lambda>z. z - 1"
  by standard (simp_all add: ring_distribs plus_period)

lemma of_nat: "f (of_nat n) = f 0" using plus_of_nat[of 0 n] by simp
lemma uminus_of_nat: "f (-of_nat n) = f 0" using minus_of_nat[of 0 n] by simp
lemma of_int: "f (of_int n) = f 0" using plus_of_int[of 0 n] by simp
lemma uminus_of_int: "f (-of_int n) = f 0" using minus_of_int[of 0 n] by simp
lemma of_numeral: "f (numeral n) = f 0" using plus_numeral[of 0 n] by simp
lemma of_neg_numeral: "f (-numeral n) = f 0" using minus_numeral[of 0 n] by simp
lemma of_1: "f 1 = f 0" using plus_of_nat[of 0 1] by simp
lemma of_neg_1: "f (-1) = f 0" using minus_of_nat[of 0 1] by simp

lemmas periodic_simps' =
  of_nat uminus_of_nat of_int uminus_of_int of_numeral of_neg_numeral of_1 of_neg_1

end

interpretation sin: periodic_fun_simple sin "2 * of_real pi :: 'a :: {real_normed_field,banach}"
proof
  fix z :: 'a
  have "sin (z + 2 * of_real pi) = sin (z + of_real pi + of_real pi)" by (simp add: ac_simps)
  also have "\<dots> = sin z" by (simp only: sin_plus_pi) simp
  finally show "sin (z + 2 * of_real pi) = sin z" .
qed

interpretation cos: periodic_fun_simple cos "2 * of_real pi :: 'a :: {real_normed_field,banach}"
proof
  fix z :: 'a
  have "cos (z + 2 * of_real pi) = cos (z + of_real pi + of_real pi)" by (simp add: ac_simps)
  also have "\<dots> = cos z" by (simp only: cos_plus_pi) simp
  finally show "cos (z + 2 * of_real pi) = cos z" .
qed

interpretation tan: periodic_fun_simple tan "2 * of_real pi :: 'a :: {real_normed_field,banach}"
  by standard (simp only: tan_def [abs_def] sin.plus_1 cos.plus_1)

interpretation cot: periodic_fun_simple cot "2 * of_real pi :: 'a :: {real_normed_field,banach}"
  by standard (simp only: cot_def [abs_def] sin.plus_1 cos.plus_1)

end


(*  Title:      HOL/Hoare/SepLogHeap.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM

Heap abstractions (at the moment only Path and List)
for Separation Logic.
*)

theory SepLogHeap
imports Main
begin

type_synonym heap = "(nat \<Rightarrow> nat option)"

text\<open>\<open>Some\<close> means allocated, \<open>None\<close> means
free. Address \<open>0\<close> serves as the null reference.\<close>

subsection "Paths in the heap"

primrec Path :: "heap \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool"
where
  "Path h x [] y = (x = y)"
| "Path h x (a#as) y = (x\<noteq>0 \<and> a=x \<and> (\<exists>b. h x = Some b \<and> Path h b as y))"

lemma [simp]: "\<And>x. Path f x (as@bs) z = (\<exists>y. Path f x as y \<and> Path f y bs z)"
by (induct as) auto

lemma Path_upd[simp]:
 "\<And>x. u \<notin> set as \<Longrightarrow> Path (f(u := v)) x as y = Path f x as y"
by (induct as) simp_all

subsection "Lists on the heap"

definition List :: "heap \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool"
  where "List h x as = Path h x as 0"

lemma [simp]: "List h x [] = (x = 0)"
by (simp add: List_def)

lemma [simp]:
 "List h x (a#as) = (x\<noteq>0 \<and> a=x \<and> (\<exists>y. h x = Some y \<and> List h y as))"
by (simp add: List_def)

lemma [simp]: "List h 0 as = (as = [])"
by (cases as) simp_all

lemma List_non_null: "a\<noteq>0 \<Longrightarrow>
 List h a as = (\<exists>b bs. as = a#bs \<and> h a = Some b \<and> List h b bs)"
by (cases as) simp_all

lemma List_unique: "\<And>x bs. List h x as \<Longrightarrow> List h x bs \<Longrightarrow> as = bs"
by (induct as) (auto simp add:List_non_null)

lemma List_unique1: "List h p as \<Longrightarrow> \<exists>!as. List h p as"
by (blast intro: List_unique)

lemma List_app: "\<And>x. List h x (as@bs) = (\<exists>y. Path h x as y \<and> List h y bs)"
by (induct as) auto

lemma List_hd_not_in_tl[simp]: "List h b as \<Longrightarrow> h a = Some b \<Longrightarrow> a \<notin> set as"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>x. List h x as \<Longrightarrow> distinct as"
by (induct as) (auto dest:List_hd_not_in_tl)

lemma list_in_heap: "\<And>p. List h p ps \<Longrightarrow> set ps \<subseteq> dom h"
by (induct ps) auto

lemma list_ortho_sum1[simp]:
 "\<And>p. \<lbrakk> List h1 p ps; dom h1 \<inter> dom h2 = {}\<rbrakk> \<Longrightarrow> List (h1++h2) p ps"
by (induct ps) (auto simp add:map_add_def split:option.split)

lemma list_ortho_sum2[simp]:
 "\<And>p. \<lbrakk> List h2 p ps; dom h1 \<inter> dom h2 = {}\<rbrakk> \<Longrightarrow> List (h1++h2) p ps"
by (induct ps) (auto simp add:map_add_def split:option.split)

end