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

section\<open>A Small Universe for Lazy Recursive Types\<close>

theory QUniv imports Univ QPair begin

(*Disjoint sums as a datatype*)
rep_datatype
  elimination   sumE
  induction     TrueI
  case_eqns     case_Inl case_Inr

(*Variant disjoint sums as a datatype*)
rep_datatype
  elimination   qsumE
  induction     TrueI
  case_eqns     qcase_QInl qcase_QInr

definition
  quniv :: "i \<Rightarrow> i"  where
   "quniv(A) \<equiv> Pow(univ(eclose(A)))"

subsection\<open>Properties involving Transset and Sum\<close>

lemma Transset_includes_summands:
     "\<lbrakk>Transset(C); A+B \<subseteq> C\<rbrakk> \<Longrightarrow> A \<subseteq> C \<and> B \<subseteq> C"
apply (simp add: sum_def Un_subset_iff)
apply (blast dest: Transset_includes_range)
done

lemma Transset_sum_Int_subset:
     "Transset(C) \<Longrightarrow> (A+B) \<inter> C \<subseteq> (A \<inter> C) + (B \<inter> C)"
apply (simp add: sum_def Int_Un_distrib2)
apply (blast dest: Transset_Pair_D)
done

subsection\<open>Introduction and Elimination Rules\<close>

lemma qunivI: "X \<subseteq> univ(eclose(A)) \<Longrightarrow> X \<in> quniv(A)"
by (simp add: quniv_def)

lemma qunivD: "X \<in> quniv(A) \<Longrightarrow> X \<subseteq> univ(eclose(A))"
by (simp add: quniv_def)

lemma quniv_mono: "A<=B \<Longrightarrow> quniv(A) \<subseteq> quniv(B)"
  unfolding quniv_def
apply (erule eclose_mono [THEN univ_mono, THEN Pow_mono])
done

subsection\<open>Closure Properties\<close>

lemma univ_eclose_subset_quniv: "univ(eclose(A)) \<subseteq> quniv(A)"
apply (simp add: quniv_def Transset_iff_Pow [symmetric])
apply (rule Transset_eclose [THEN Transset_univ])
done

(*Key property for proving A_subset_quniv; requires eclose in definition of quniv*)
lemma univ_subset_quniv: "univ(A) \<subseteq> quniv(A)"
apply (rule arg_subset_eclose [THEN univ_mono, THEN subset_trans])
apply (rule univ_eclose_subset_quniv)
done

lemmas univ_into_quniv = univ_subset_quniv [THEN subsetD]

lemma Pow_univ_subset_quniv: "Pow(univ(A)) \<subseteq> quniv(A)"
  unfolding quniv_def
apply (rule arg_subset_eclose [THEN univ_mono, THEN Pow_mono])
done

lemmas univ_subset_into_quniv =
    PowI [THEN Pow_univ_subset_quniv [THEN subsetD]]

lemmas zero_in_quniv = zero_in_univ [THEN univ_into_quniv]
lemmas one_in_quniv = one_in_univ [THEN univ_into_quniv]
lemmas two_in_quniv = two_in_univ [THEN univ_into_quniv]

lemmas A_subset_quniv =  subset_trans [OF A_subset_univ univ_subset_quniv]

lemmas A_into_quniv = A_subset_quniv [THEN subsetD]

(*** univ(A) closure for Quine-inspired pairs and injections ***)

(*Quine ordered pairs*)
lemma QPair_subset_univ:
    "\<lbrakk>a \<subseteq> univ(A);  b \<subseteq> univ(A)\<rbrakk> \<Longrightarrow> <a;b> \<subseteq> univ(A)"
by (simp add: QPair_def sum_subset_univ)

subsection\<open>Quine Disjoint Sum\<close>

lemma QInl_subset_univ: "a \<subseteq> univ(A) \<Longrightarrow> QInl(a) \<subseteq> univ(A)"
  unfolding QInl_def
apply (erule empty_subsetI [THEN QPair_subset_univ])
done

lemmas naturals_subset_nat =
    Ord_nat [THEN Ord_is_Transset, unfolded Transset_def, THEN bspec]

lemmas naturals_subset_univ =
    subset_trans [OF naturals_subset_nat nat_subset_univ]

lemma QInr_subset_univ: "a \<subseteq> univ(A) \<Longrightarrow> QInr(a) \<subseteq> univ(A)"
  unfolding QInr_def
apply (erule nat_1I [THEN naturals_subset_univ, THEN QPair_subset_univ])
done

subsection\<open>Closure for Quine-Inspired Products and Sums\<close>

(*Quine ordered pairs*)
lemma QPair_in_quniv:
    "\<lbrakk>a: quniv(A);  b: quniv(A)\<rbrakk> \<Longrightarrow> <a;b> \<in> quniv(A)"
by (simp add: quniv_def QPair_def sum_subset_univ)

lemma QSigma_quniv: "quniv(A) <*> quniv(A) \<subseteq> quniv(A)"
by (blast intro: QPair_in_quniv)

lemmas QSigma_subset_quniv =  subset_trans [OF QSigma_mono QSigma_quniv]

(*The opposite inclusion*)
lemma quniv_QPair_D:
    "<a;b> \<in> quniv(A) \<Longrightarrow> a: quniv(A) \<and> b: quniv(A)"
  unfolding quniv_def QPair_def
apply (rule Transset_includes_summands [THEN conjE])
apply (rule Transset_eclose [THEN Transset_univ])
apply (erule PowD, blast)
done

lemmas quniv_QPair_E = quniv_QPair_D [THEN conjE]

lemma quniv_QPair_iff: "<a;b> \<in> quniv(A) \<longleftrightarrow> a: quniv(A) \<and> b: quniv(A)"
by (blast intro: QPair_in_quniv dest: quniv_QPair_D)

subsection\<open>Quine Disjoint Sum\<close>

lemma QInl_in_quniv: "a: quniv(A) \<Longrightarrow> QInl(a) \<in> quniv(A)"
by (simp add: QInl_def zero_in_quniv QPair_in_quniv)

lemma QInr_in_quniv: "b: quniv(A) \<Longrightarrow> QInr(b) \<in> quniv(A)"
by (simp add: QInr_def one_in_quniv QPair_in_quniv)

lemma qsum_quniv: "quniv(C) <+> quniv(C) \<subseteq> quniv(C)"
by (blast intro: QInl_in_quniv QInr_in_quniv)

lemmas qsum_subset_quniv = subset_trans [OF qsum_mono qsum_quniv]

subsection\<open>The Natural Numbers\<close>

lemmas nat_subset_quniv =  subset_trans [OF nat_subset_univ univ_subset_quniv]

(* n:nat \<Longrightarrow> n:quniv(A) *)
lemmas nat_into_quniv = nat_subset_quniv [THEN subsetD]

lemmas bool_subset_quniv = subset_trans [OF bool_subset_univ univ_subset_quniv]

lemmas bool_into_quniv = bool_subset_quniv [THEN subsetD]

(*Intersecting <a;b> with Vfrom...*)

lemma QPair_Int_Vfrom_succ_subset:
 "Transset(X) \<Longrightarrow>
       <a;b> \<inter> Vfrom(X, succ(i))  \<subseteq>  <a \<inter> Vfrom(X,i);  b \<inter> Vfrom(X,i)>"
by (simp add: QPair_def sum_def Int_Un_distrib2 Un_mono
              product_Int_Vfrom_subset [THEN subset_trans]
              Sigma_mono [OF Int_lower1 subset_refl])

subsection\<open>"Take-Lemma" Rules\<close>

(*for proving a=b by coinduction and c: quniv(A)*)

(*Rule for level i -- preserving the level, not decreasing it*)

lemma QPair_Int_Vfrom_subset:
 "Transset(X) \<Longrightarrow>
       <a;b> \<inter> Vfrom(X,i)  \<subseteq>  <a \<inter> Vfrom(X,i);  b \<inter> Vfrom(X,i)>"
  unfolding QPair_def
apply (erule Transset_Vfrom [THEN Transset_sum_Int_subset])
done

(*@{term"\<lbrakk>a \<inter> Vset(i) \<subseteq> c; b \<inter> Vset(i) \<subseteq> d\<rbrakk> \<Longrightarrow> <a;b> \<inter> Vset(i) \<subseteq> <c;d>"}*)
lemmas QPair_Int_Vset_subset_trans =
     subset_trans [OF Transset_0 [THEN QPair_Int_Vfrom_subset] QPair_mono]

lemma QPair_Int_Vset_subset_UN:
     "Ord(i) \<Longrightarrow> <a;b> \<inter> Vset(i) \<subseteq> (\<Union>j\<in>i. <a \<inter> Vset(j); b \<inter> Vset(j)>)"
apply (erule Ord_cases)
(*0 case*)
apply (simp add: Vfrom_0)
(*succ(j) case*)
apply (erule ssubst)
apply (rule Transset_0 [THEN QPair_Int_Vfrom_succ_subset, THEN subset_trans])
apply (rule succI1 [THEN UN_upper])
(*Limit(i) case*)
apply (simp del: UN_simps
        add: Limit_Vfrom_eq Int_UN_distrib UN_mono QPair_Int_Vset_subset_trans)
done

end


theory int_add_comm
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Zero | Succ "Nat"

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

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

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

fun plus :: "Z => Z => Z" where
"plus (P m) (P n) = P (plus2 m n)"
| "plus (P m) (N o) = minus m (Succ o)"
| "plus (N m2) (P n2) = minus n2 (Succ m2)"
| "plus (N m2) (N n3) = N (Succ (plus2 m2 n3))"

(*hipster plus2 minus plus *)

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

end


theory T50
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


subsubsection \<open>Equations for masking relations\<close>

theory Mask_Equations
  imports "../Register_Machine/MachineMasking" Equation_Setup "../Diophantine/Binary_And"

abbrevs mb = "\<preceq>"

begin

context rm_eq_fixes
begin

  text \<open>Equation 4.15\<close>
  definition register_mask :: "bool" where
    "register_mask \<equiv> \<forall>l < n. r l \<preceq> d"

  text \<open>Equation 4.17\<close>
  definition zero_indicator_mask :: "bool" where
    "zero_indicator_mask \<equiv> \<forall>l < n. z l \<preceq> e"

  text \<open>Equation 4.20\<close>
  definition zero_indicator_0_or_1 :: "bool" where
    "zero_indicator_0_or_1 \<equiv> \<forall>l<n. 2^c * z l = (r l + d) && f"

  definition mask_equations :: "bool" where
    "mask_equations \<equiv> register_mask \<and> zero_indicator_mask \<and> zero_indicator_0_or_1"

end

context register_machine
begin

lemma register_mask_dioph:
  fixes d r
  assumes "n = length r"
  defines "DR \<equiv> (NARY (\<lambda>l. rm_eq_fixes.register_mask n (l!0) (shift l 1)) ([d] @ r))"
  shows "is_dioph_rel DR"
proof -
  define DS where "DS \<equiv> [\<forall><n] (\<lambda>i. ((r!i) [\<preceq>] d))"

  have "eval DS a = eval DR a" for a
  proof -
    have "eval DR a = rm_eq_fixes.register_mask n (peval d a) (list_eval r a)"
      unfolding DR_def by (auto simp add: shift_def list_eval_def)
    also have "... = (\<forall>l < n. (peval (r!l) a) \<preceq> peval d a)"
      using rm_eq_fixes.register_mask_def \<open>n = length r\<close> rm_eq_fixes_def
            local.register_machine_axioms by (auto simp: list_eval_def)
    finally show ?thesis
      unfolding DS_def defs by simp
  qed

  moreover have "is_dioph_rel DS"
    unfolding DS_def by (auto simp add: dioph)

  ultimately show ?thesis
    by (simp add: is_dioph_rel_def)
qed

lemma zero_indicator_mask_dioph:
  fixes e z
  assumes "n = length z"
  defines "DR \<equiv> (NARY (\<lambda>l. rm_eq_fixes.zero_indicator_mask n (l!0) (shift l 1)) ([e] @ z))"
  shows "is_dioph_rel DR"
proof -
  define DS where "DS \<equiv> [\<forall><n] (\<lambda>i. ((z!i) [\<preceq>] e))"

  have "eval DS a = eval DR a" for a
  proof -
    have "eval DR a = rm_eq_fixes.zero_indicator_mask n (peval e a) (list_eval z a)"
      unfolding DR_def by (auto simp add: shift_def list_eval_def)
    also have "... = (\<forall>l < n. (peval (z!l) a) \<preceq> peval e a)"
      using rm_eq_fixes.zero_indicator_mask_def \<open>n = length z\<close>
      rm_eq_fixes_def local.register_machine_axioms by (auto simp: list_eval_def)
    finally show ?thesis
      unfolding DS_def defs by simp
  qed

  moreover have "is_dioph_rel DS"
    unfolding DS_def by (auto simp add: dioph)

  ultimately show ?thesis
    by (simp add: is_dioph_rel_def)
qed

lemma zero_indicator_0_or_1_dioph:
  fixes c d f r z
  assumes "n = length r" and "n = length z"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.zero_indicator_0_or_1 n (ll!0!0) (ll!0!1) (ll!0!2)
                             (nth (ll!1)) (nth (ll!2))) [[c, d, f], r, z]"
  shows "is_dioph_rel DR"
proof -
  let ?N = 2
  define c' d' f' r' z' where pushed_def: "c' = push_param c ?N" "d' = push_param d ?N"
                                "f' = push_param f ?N" "r' = map (\<lambda>x. push_param x ?N) r"
                                "z' = map (\<lambda>x. push_param x ?N) z"
  define DS where "DS \<equiv> [\<forall><n] (\<lambda>i. ([\<exists>2] [Param 0 = (Const 2) ^ c']
                                        [\<and>] [Param 1 = (r'!i) [+] d' && f']
                                        [\<and>] Param 0 [*] (z'!i) [=] Param 1))"

  have "eval DS a = eval DR a" for a
  proof -
    have "eval DR a = rm_eq_fixes.zero_indicator_0_or_1 n (peval c a) (peval d a) (peval f a)
                        (list_eval r a) (list_eval z a)"
      unfolding DR_def defs by (auto simp add: assms shift_def list_eval_def)
    also have "... = (\<forall>l < n. 2^(peval c a) * (peval (z!l) a)
                              = (peval (r!l) a + peval d a) && peval f a)"
      using rm_eq_fixes.zero_indicator_0_or_1_def \<open>n = length r\<close> using assms
      rm_eq_fixes_def local.register_machine_axioms by (auto simp: list_eval_def)
    finally show ?thesis
      unfolding DS_def defs pushed_def using push_push apply (auto)
      subgoal for k
        apply (rule exI[of _ "[2^peval c a, peval (r!k) a + peval d a && peval f a]"])
        apply (auto simp: push_list_def assms(1-2))
        by (metis assms(1) assms(2) length_Cons list.size(3) nth_map numeral_2_eq_2)
      subgoal
        using assms by auto
      done
  qed

  moreover have "is_dioph_rel DS"
    unfolding DS_def by (auto simp add: dioph)

  ultimately show ?thesis
    by (simp add: is_dioph_rel_def)
qed

definition mask_equations_relation ("[MASK] _ _ _ _ _ _") where
  "[MASK] c d e f r z \<equiv> LARY (\<lambda>ll. rm_eq_fixes.mask_equations n
                              (ll!0!0) (ll!0!1) (ll!0!2) (ll!0!3) (nth (ll!1)) (nth (ll!2)))
                              [[c, d, e, f], r, z]"

lemma mask_equations_relation_dioph:
  fixes c d e f r z
  assumes "n = length r" and "n = length z"
  defines "DR \<equiv> [MASK] c d e f r z"
  shows "is_dioph_rel DR"
proof -
  define DS where "DS \<equiv> NARY (\<lambda>l. rm_eq_fixes.register_mask n (l!0) (shift l 1)) ([d] @ r)
  [\<and>] NARY (\<lambda>l. rm_eq_fixes.zero_indicator_mask n (l!0) (shift l 1)) ([e] @ z)
  [\<and>] LARY (\<lambda>ll. rm_eq_fixes.zero_indicator_0_or_1 n (ll!0!0) (ll!0!1) (ll!0!2)
                             (nth (ll!1)) (nth (ll!2))) [[c, d, f], r, z]"

  have "eval DS a = eval DR a" for a
    using DS_def DR_def mask_equations_relation_def rm_eq_fixes.mask_equations_def
    rm_eq_fixes_def local.register_machine_axioms by (simp add: defs shift_def)

  moreover have "is_dioph_rel DS"
    unfolding DS_def using assms dioph
    using register_mask_dioph zero_indicator_mask_dioph zero_indicator_0_or_1_dioph
    by (metis (no_types, lifting))

  ultimately show ?thesis
    by (simp add: is_dioph_rel_def)
qed

end

end


text\<open>
Formal Languages and Automata Theory (FLAT)
according to the book with same name (2nd version) by Zongli Jiang
created by Yongwang Zhao (zhaoyw@buaa.edu.cn)
School of Computer Science and Engineering, Beihang University, Beijing, China
\<close>

section\<open>2.Grammar\<close>

theory Grammar
  imports Main
begin

subsection\<open>2.2 formal definition\<close>

subsubsection\<open>definition 2-1: Grammar\<close>

abbreviation "l_prod p \<equiv> fst p"
abbreviation "r_prod p \<equiv> snd p"

type_synonym 'a product = "'a list \<times> 'a list"

(* Grammar = <V,T,P,S> *)
type_synonym 'a Grammar = "'a set \<times> 'a set \<times> 'a product set \<times> 'a"

abbreviation "V g \<equiv> fst g"
abbreviation "T g \<equiv> fst (snd g)"
abbreviation "P g \<equiv> fst (snd (snd g))"
abbreviation "S g \<equiv> snd (snd (snd g))"

lemma getV[simp]: "V (v,t,p,s) = v" by simp
lemma getT[simp]: "T (v,t,p,s) = t" by simp
lemma getP[simp]: "P (v,t,p,s) = p" by simp
lemma getS[simp]: "S (v,t,p,s) = s" by simp

definition grammar :: "'a Grammar \<Rightarrow> bool"
  where "grammar g \<equiv> V g \<noteq> {} \<and> T g \<noteq> {} \<and> V g \<inter> T g = {} \<and> P g \<noteq> {}
            \<and> (\<forall>p\<in>P g. l_prod p \<noteq> [] \<and> (\<exists>i<length (l_prod p). (l_prod p)!i \<in> V g))
            \<and> S g \<in> V g"

subsubsection\<open>example 2-1\<close>

datatype Symbol = A | B | C | D | S0 | a | b | c | zero ("\<zero>") | one ("\<one>") | two ("\<two>") | sharp ("#")

locale example_2_1
begin

definition "g1 \<equiv> ({A,B,C,S0},{a,b,c},{([A,B], [a,a,A])},S0)"

lemma "grammar g1"
  apply(simp add:grammar_def g1_def) by auto

definition "g2 = ({A,B},{\<zero>,\<one>},{([A], [\<zero>]),([A],[\<one>]),([A],[\<zero>,A]),([A],[\<one>,A])},A)"
lemma "grammar g2"
  by(simp add:grammar_def g2_def)

end

thm example_2_1.g2_def

subsubsection \<open>definition 2-2: derivation and reduction\<close>

inductive_set derive_set :: "'a Grammar \<Rightarrow> ('a list \<times> 'a list) set"
  and derive :: "'a Grammar \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<turnstile> _ \<longrightarrow> _" [80,80,80] 81)
  for G :: "'a Grammar"
  where
    "derive G x y \<equiv> (x,y) \<in> derive_set G"
  | r_drvset: "\<exists>p\<in>P G. \<alpha> = l_prod p \<and> \<beta> = r_prod p \<Longrightarrow> (\<gamma>@\<alpha>@\<delta>,\<gamma>@\<beta>@\<delta>)\<in>derive_set G"

inductive nderives :: "'a Grammar \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> bool"
("_ \<turnstile> _ \<midarrow>_\<rightarrow> _" [80,80,80,80] 81)
  where drv0: "g \<turnstile> x \<midarrow>0\<rightarrow> x" |
        drvn: "\<exists>r. g \<turnstile> x \<midarrow>n\<rightarrow> r \<and> g \<turnstile> r \<longrightarrow> y \<Longrightarrow> g \<turnstile> x \<midarrow>(n+1)\<rightarrow> y"

definition derives :: "'a Grammar \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<turnstile> _ \<midarrow>*\<rightarrow> _" [80,80,80] 81)
  where "derives g x y \<equiv> (\<exists>n. g \<turnstile> x \<midarrow>n\<rightarrow> y)"

definition derives1 :: "'a Grammar \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<turnstile> _ \<midarrow>+\<rightarrow> _" [80,80,80] 81)
  where "derives1 g x y \<equiv> (\<exists>n>0. g \<turnstile> x \<midarrow>n\<rightarrow> y)"

inductive_set reduce_set :: "'a Grammar \<Rightarrow> ('a list \<times> 'a list) set"
and reduce :: "'a Grammar \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
and reduces :: "'a Grammar \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
and reduces1 :: "'a Grammar \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
for G :: "'a Grammar"
where
    "reduce G x y \<equiv> (x,y) \<in> reduce_set G"
  | "reduces G x y \<equiv> (x,y) \<in> (reduce_set G)\<^sup>*"
  | "reduces1 G x y \<equiv> (x,y) \<in> (reduce_set G)\<^sup>+"
  | r_redset: "\<exists>p\<in>P G. \<alpha> = l_prod p \<and> \<beta> = r_prod p \<Longrightarrow> (\<gamma>@\<beta>@\<delta>,\<gamma>@\<alpha>@\<delta>)\<in>reduce_set G"

lemma "derive G x y = reduce G y x"
  apply(rule iffI)
    apply(rule derive_set.cases) apply simp
  apply (simp add: reduce_set.r_redset)

  apply(rule reduce_set.cases)
  apply fast
  by (simp add: derive_set.r_drvset)

lemma "derives G x y = reduces G y x"
  apply(simp add:derives_def)
  sorry

subsubsection\<open>example 2-4\<close>

locale example_2_4
begin

definition "g1 \<equiv> ({A},{a},{([A], [a]),([A],[a,A])},A)"

lemma "grammar g1"
  by(simp add:grammar_def g1_def)

lemma "derive g1 [A] [a]"
  using r_drvset[where G = g1 and \<alpha>="[A]" and \<gamma> = "[]" and \<delta>="[]" and \<beta>="[a]"]
  by(simp add: g1_def)

lemma "derive g1 [A,A,a,a,A,A,A] [a,A,a,a,A,A,A]"
  using r_drvset[where \<alpha>="[A]" and \<gamma> = "[]" and \<delta>="[A, a, a, A, A, A]" and \<beta>="[a]"]
  by(simp add: g1_def)

end

subsubsection\<open>definition 2-4: sentantial form\<close>

definition allterminals :: "'a Grammar \<Rightarrow> 'a list \<Rightarrow> bool"
  where "allterminals g w \<equiv> (\<forall>i<length w. (w!i)\<in>T g)"

(* after interpretation, we propage the function ``derives'' to the theory.
here we use local.derives to refer to the definition inner the locale. *)

definition sentence_form :: "'a Grammar \<Rightarrow> 'a list \<Rightarrow> bool"
  where "sentence_form g w \<equiv> (g \<turnstile> [(S g)] \<midarrow>*\<rightarrow> w)"

subsubsection\<open>definition 2-3: Languages\<close>

type_synonym 'a lang = "'a list set"

definition Lang :: "'a Grammar \<Rightarrow> 'a lang"
  where "Lang g \<equiv> {w. sentence_form g w \<and> allterminals g w}"

definition sentence :: "'a Grammar \<Rightarrow> 'a list \<Rightarrow> bool"
  where "sentence g w \<equiv> (w\<in>Lang g)"

subsection\<open>2.3 construct syntax\<close>

subsubsection\<open>definition 2-5: Grammar Equivalence\<close>

definition GrammarEquiv :: "'a Grammar \<Rightarrow> 'a Grammar \<Rightarrow> bool" (infix "\<cong>" 80)
  where "GrammarEquiv g1 g2 \<equiv> Lang g1 = Lang g2"

subsection\<open>2.4 Chomsky Framework for Languages\<close>

subsubsection\<open>definition 2-6: Chomsky Languages\<close>
definition grammar_type0 :: "'a Grammar \<Rightarrow> bool"
  where "grammar_type0 g \<equiv> grammar g"

abbreviation "phrasestruct_grammar \<equiv> grammar_type0"

text\<open>
define all 0 type languages
\<close>
definition "PSL \<equiv> {l. \<exists>g. grammar_type0 g \<and> Lang g = l}"

text\<open>type 1 grammar: \<forall> \<alpha> \<rightarrow> \<beta> \<in> P, |\<alpha>| \<le> |\<beta>|\<close>
definition grammar_type1 :: "'a Grammar \<Rightarrow> bool"
  where "grammar_type1 g \<equiv> grammar_type0 g \<and> (\<forall>p\<in>P g. length (l_prod p) \<le> length (r_prod p))"

abbreviation "contextsensitive_grammar \<equiv> grammar_type1"

text\<open>
define CSL languages
\<close>
definition "CSL \<equiv> {l. \<exists>g. contextsensitive_grammar g \<and> Lang g = l}"

text\<open>type 2 grammar: \<forall> \<alpha> \<rightarrow> \<beta> \<in> P, |\<alpha>| \<le> |\<beta>| and \<alpha> \<in> V\<close>
definition grammar_type2 :: "'a Grammar \<Rightarrow> bool"
  where "grammar_type2 g \<equiv> grammar_type1 g \<and> (\<forall>p\<in>P g. length (l_prod p) = 1 \<and> hd (l_prod p) \<in> V g)"

abbreviation "contextfree_grammar \<equiv> grammar_type2"

text\<open>
define CFL languages
\<close>
definition "CFL \<equiv> {l. \<exists>g. contextfree_grammar g \<and> Lang g = l}"

text\<open>type 3 grammar: \<forall> \<alpha> \<rightarrow> \<beta> \<in> P, having forms of A \<rightarrow> \<omega> or A \<rightarrow> \<omega>B,
where A,B \<in> V and \<omega> \<in> T^+\<close>
definition grammar_type3 :: "'a Grammar \<Rightarrow> bool"
  where "grammar_type3 g \<equiv> grammar_type2 g \<and> (\<forall>p\<in>P g. r_prod p \<noteq> []
                \<and> (allterminals g (r_prod p)
                  \<or> (length (r_prod p) > 1
                      \<and> allterminals g (butlast (r_prod p))
                      \<and> last (r_prod p) \<in> V g)))"

abbreviation "regular_grammar \<equiv> grammar_type3"

text\<open>
define RL languages
\<close>
definition "RL \<equiv> {l. \<exists>g. regular_grammar g \<and> Lang g = l}"

text\<open>
regular grammars are context free grammars.
\<close>
lemma RG_CFG: "regular_grammar g \<Longrightarrow> contextfree_grammar g"
  by(simp add:grammar_type3_def grammar_type2_def)

text\<open>
context free grammars are context sensitive grammars.
\<close>
lemma CFG_CSG: "contextfree_grammar g \<Longrightarrow> contextsensitive_grammar g"
  by(simp add:grammar_type2_def)

text\<open>
context sensitive grammars are phrase structure grammars.
\<close>
lemma CSG_PSG: "contextsensitive_grammar g \<Longrightarrow> phrasestruct_grammar g"
  by(simp add:grammar_type1_def)

text\<open>
regular languages are context free languages.
\<close>
lemma RL_CFL: "RL \<subseteq> CFL"
  apply(simp add: RL_def CFL_def) using RG_CFG by blast

text\<open>
context free languages are context sensitive languages.
\<close>
lemma CFL_CSL: "CFL \<subseteq> CSL"
  apply(simp add: CSL_def CFL_def) using CFG_CSG by blast

text\<open>
context sensitive languages are phrase structure languages.
\<close>
lemma CSL_PSL: "CSL \<subseteq> PSL"
  apply(simp add: CSL_def PSL_def) using CSG_PSG by blast

subsubsection\<open>theorem 2-1\<close>
text\<open>
\<forall> \<alpha> \<rightarrow> \<beta> \<in> P, having forms of A \<rightarrow> a or A \<rightarrow> aB,
\<close>
definition singleprods_r :: "'a Grammar \<Rightarrow> bool"
  where "singleprods_r g \<equiv> \<forall>p\<in>P g. length (l_prod p) = 1 \<and> hd (l_prod p) \<in> V g
                \<and> (length (r_prod p) = 1 \<and> hd (r_prod p) \<in> T g
                  \<or> length (r_prod p) = 2 \<and> hd (r_prod p) \<in> T g \<and> last (r_prod p) \<in> V g)"

text\<open>
exercise for students
\<close>
theorem "L \<in> RL \<longleftrightarrow> (\<exists>G. grammar G \<and> singleprods_r G \<and> L = Lang G)"
  sorry

subsubsection\<open>definition 2-7: linear grammar\<close>

text\<open>
\<forall> \<alpha> \<rightarrow> \<beta> \<in> P, having forms of A \<rightarrow> \<omega> or A \<rightarrow> \<omega>Bx,
where A,B \<in> V and \<omega>,x \<in> T^*
\<close>
definition linear_grammar :: "'a Grammar \<Rightarrow> bool"
  where "linear_grammar g \<equiv> grammar g \<and> (\<forall>p\<in>P g. length (l_prod p) = 1 \<and> hd (l_prod p) \<in> V g
                              \<and> (allterminals g (r_prod p)
                                 \<or> (\<exists>!i. i<length (r_prod p) \<and> (r_prod p)!i \<in> V g) ))"

lemma "\<exists>!i. i<length l \<Longrightarrow> l \<noteq> []" by fastforce

subsubsection\<open>definition 2-8: right linear grammar
A \<rightarrow> \<omega> or A \<rightarrow> \<omega>B, where \<omega> \<in> T^+
\<close>

definition r_linear_grammar :: "'a Grammar \<Rightarrow> bool"
  where "r_linear_grammar g \<equiv> grammar_type2 g \<and> (\<forall>p\<in>P g. r_prod p \<noteq> []
                \<and> (allterminals g (r_prod p)
                  \<or> (length (r_prod p) > 1
                      \<and> allterminals g (butlast (r_prod p))
                      \<and> last (r_prod p) \<in> V g)))"

lemma "r_linear_grammar = grammar_type3"
  using r_linear_grammar_def grammar_type3_def by fast

definition r_linear_lang :: "'a lang \<Rightarrow> bool"
  where "r_linear_lang l \<equiv> (\<exists>g. r_linear_grammar g \<and> Lang g = l)"

subsubsection\<open>definition 2-8: left linear grammar
A \<rightarrow> \<omega> or A \<rightarrow> B\<omega>, where \<omega> \<in> T^+
\<close>

definition l_linear_grammar :: "'a Grammar \<Rightarrow> bool"
  where "l_linear_grammar g \<equiv> grammar_type2 g \<and> (\<forall>p\<in>P g. r_prod p \<noteq> []
                \<and> (allterminals g (r_prod p)
                  \<or> (length (r_prod p) > 1
                      \<and> allterminals g (tl (r_prod p))
                      \<and> hd (r_prod p) \<in> V g)))"

definition l_linear_lang :: "'a lang \<Rightarrow> bool"
  where "l_linear_lang l \<equiv> (\<exists>g. l_linear_grammar g \<and> Lang g = l)"

subsubsection\<open>theorem 2-2\<close>
text\<open>
\<forall> \<alpha> \<rightarrow> \<beta> \<in> P, having forms of A \<rightarrow> a or A \<rightarrow> Ba,
\<close>
definition singleprods_l :: "'a Grammar \<Rightarrow> bool"
  where "singleprods_l g \<equiv> \<forall>p\<in>P g. length (l_prod p) = 1 \<and> hd (l_prod p) \<in> V g
                \<and> (length (r_prod p) = 1 \<and> hd (r_prod p) \<in> T g
                  \<or> length (r_prod p) = 2 \<and> hd (r_prod p) \<in> V g \<and> last (r_prod p) \<in> T g)"

text\<open>
exercise for students
\<close>
theorem "l_linear_lang L \<longleftrightarrow> (\<exists>G. grammar G \<and> singleprods_l G \<and> L = Lang G)"
  sorry

subsubsection \<open>relations among right/left linear grammar\<close>

lemma "r_linear_grammar g \<Longrightarrow> linear_grammar g"
  apply(simp add: r_linear_grammar_def linear_grammar_def)
  apply(rule conjI)
  using grammar_type0_def grammar_type1_def grammar_type2_def apply blast
  apply(simp add:grammar_type2_def Ball_def) apply(rule allI)+ apply(rule impI)
  apply(rule conjI) apply auto[1]
  apply(rule conjI) apply auto[1]
  subgoal for a b
    apply(cases "allterminals g b") apply fast
    apply auto
    apply (metis One_nat_def Suc_pred last_conv_nth length_greater_0_conv less_Suc_eq)
    apply(subgoal_tac "allterminals g (butlast b) \<and> last b \<in> V g") prefer 2
     apply blast apply(subgoal_tac "i = length b - 1") apply(subgoal_tac "y = length b - 1")
    apply blast sorry
  done

lemma "l_linear_grammar g \<Longrightarrow> linear_grammar g"
  apply(simp add: l_linear_grammar_def linear_grammar_def)
  apply(rule conjI)
   apply (simp add: grammar_type0_def grammar_type1_def grammar_type2_def)
  apply(simp add:grammar_type2_def Ball_def)
  sorry

subsection\<open>2.5 empty sentence\<close>

subsubsection\<open>definition 2-9: empty-production\<close>

notation Nil ("\<epsilon>")

text\<open>check if a production rule is an empty rule\<close>
definition emptyproduct :: "'a product \<Rightarrow> bool"
  where "emptyproduct p \<equiv> r_prod p = \<epsilon>"

lemma csg_not_derive2emp:
"contextsensitive_grammar g \<Longrightarrow> g \<turnstile> \<alpha> \<longrightarrow> \<beta> \<Longrightarrow> \<beta> \<noteq> \<epsilon>"
  apply(simp add: grammar_type1_def grammar_type0_def grammar_def)
  apply(rule derive_set.cases) apply fast
  subgoal for \<alpha>' \<beta>' \<gamma> \<delta>
    apply(subgoal_tac "\<beta>' \<noteq> \<epsilon>") apply blast
    by fastforce
  done

lemma csg_not_nderives2emp:
assumes p0: "contextsensitive_grammar g"
and p1: "\<alpha> \<noteq> \<epsilon>"
and drvs: "g \<turnstile> \<alpha> \<midarrow>+\<rightarrow> \<beta>"
shows "\<beta> \<noteq> \<epsilon>"
proof -
  from drvs obtain n where drv_n: "g \<turnstile> \<alpha> \<midarrow>n\<rightarrow> \<beta>" using derives1_def by blast
  then show ?thesis
  proof(induct n arbitrary: \<beta>)
    case 0
    then show ?case using drv_n p1
      by (metis csg_not_derive2emp nderives.cases p0)
  next
    case (Suc n)
    assume a0:"\<And>\<beta>. g \<turnstile> \<alpha> \<midarrow>n\<rightarrow> \<beta> \<Longrightarrow> \<beta> \<noteq> \<epsilon>"
    assume a1:"g \<turnstile> \<alpha> \<midarrow>Suc n\<rightarrow> \<beta>"
    from a1 obtain r where r: "g \<turnstile> \<alpha> \<midarrow>n\<rightarrow> r \<and> g \<turnstile> r \<longrightarrow> \<beta>"
      apply(rule nderives.cases) apply fast by fastforce
    hence "r \<noteq> \<epsilon>" using a0 by simp
    then show ?case using r csg_not_derive2emp p0 by blast
  qed
qed

lemma csg_not_derives2emp:
assumes p0: "contextsensitive_grammar g"
and p1: "\<alpha> \<noteq> \<epsilon>"
and drvs: "g \<turnstile> \<alpha> \<midarrow>*\<rightarrow> \<beta>"
shows "\<beta> \<noteq> \<epsilon>"
proof -
  from drvs obtain n where drv_n: "g \<turnstile> \<alpha> \<midarrow>n\<rightarrow> \<beta>" using derives_def by blast

  then show ?thesis
  proof(cases n)
    case 0
    then show ?thesis using drv_n p1
      by (metis csg_not_derive2emp nderives.cases p0)
  next
    case (Suc m)
    then show ?thesis using csg_not_nderives2emp[OF p0 p1] drv_n derives1_def by blast
    qed
qed

text\<open>
context sensitive languages dont not contain the empty sentence
\<close>
lemma csg_notempty: "contextsensitive_grammar g \<Longrightarrow> \<epsilon> \<notin> Lang g"
  apply(simp add: grammar_type1_def grammar_type0_def grammar_def
              Lang_def sentence_form_def allterminals_def)
  by (metis csg_not_derives2emp grammar_def grammar_type0_def grammar_type1_def not_Cons_self2)

lemma csl_notempty: "\<forall>l\<in>CSL. \<epsilon> \<notin> l"
  apply(simp add:CSL_def)  using csg_notempty by blast

text\<open>
context free languages dont not contain the empty sentence
\<close>
lemma "\<forall>l\<in>CFL. \<epsilon> \<notin> l"
  using csl_notempty CFL_CSL by blast

text\<open>
regular languages dont not contain the empty sentence
\<close>
lemma "\<forall>l\<in>RL. \<epsilon> \<notin> l"
  using csl_notempty CFL_CSL RL_CFL by blast

end


(*
Title: The perimeters of Pythagorean triangles
Author: José Manuel Rodriguez Caballero

We present two theorems belonging to the mathematical folklore. Both theorems can be
putted together into the following statement: For any nonzero natural number n, we have
that 2*n is the perimeter of a Pythagorean triangle if and only if n has a pair of
divisors d and e satisfying d < e < 2*d. Notice that the perimeter of a Pythagorean triangle is
always even.

The systematic research about the numbers n having a pair of divisors d and e satisfying
satisfying d < e < 2*d began with Erdos' conjecture [erdos1948density] that the asymptotic
density of this set is exactly 1. The proof of this conjecture, due to
Maier and Tenenbaum [maier1984set], was a major achievement of Probabilistic Number Theory.

References.

@article{erdos1948density,
  title={On the density of some sequences of integers},
  author={Erd{\"o}s, Paul},
  journal={Bulletin of the American Mathematical Society},
  volume={54},
  number={8},
  pages={685--692},
  year={1948}
}

@article{maier1984set,
  title={On the set of divisors of an integer},
  author={Maier, Helmut and Tenenbaum, G{\'e}rald},
  journal={Inventiones mathematicae},
  volume={76},
  number={1},
  pages={121--128},
  year={1984},
  publisher={Springer}
}

(This code was verified in Isabelle2018)

*)

theory PeriPythTriang

imports Complex_Main "HOL-Number_Theory.Number_Theory"

begin

text {*
the perimeter of a Pythagorean triangle is always even.
*}

proposition PerPythEven: "a^2 + b^2 = (c::nat)^2 \<Longrightarrow> 2 dvd (a+b+c)"
  by (metis even_power odd_add)

text {*
Given a nonzero natural number n, if n has a pair of divisors d and e
 satisfying d < e < 2*d, then 2*n is the perimeter of a Pythagorean triangle.
*}

theorem ShortDivToPeriPyth:
  fixes n :: nat
  assumes n0: "n \<noteq> 0"
    and Edivshotint: "\<exists> d e. d dvd n \<and> e dvd n \<and> d < e \<and> e < 2*d"
  shows "\<exists> a b c::nat. a \<noteq> 0 \<and> b \<noteq> 0 \<and> a^2 + b^2 = c^2 \<and> a + b + c = 2*n"
proof -
  from Edivshotint obtain d e where ddvdn: "d dvd n" and edvdn: "e dvd n" and dle: "d < e" and eltwod: "e < 2*d" by auto
  obtain dd::nat where dddef: "d = (gcd d e)*dd" using dvdE by blast
  obtain ee::nat where eedef: "e = (gcd d e)*ee" using dvdE by blast
  from dle dddef eedef have sdle: "dd < ee"  by (metis nat_mult_less_cancel_disj)
  from eltwod dddef eedef  have eeltwod: "ee < 2*dd" by (metis mult.left_commute nat_mult_less_cancel_disj)
  obtain r::nat where rdef: "r = ee" using real_of_nat_div by blast
  obtain s::nat where sdef: "s = 2*dd - ee"  by blast
  from rdef sdef sdle have sler: "s < r" by linarith
  hence sler2: "s^2 < r^2" using pos2 power_strict_mono by blast
  from sler have rsqminusssq: "r^2 - s^2 \<noteq> 0" by (simp add: linorder_not_le power2_nat_le_eq_le)
  from rdef sdef  have rcongs: "2 dvd (r - s)" by (simp add: eeltwod order_less_imp_le)
  from rcongs sler  have twodivdifsq: "2 dvd (r^2 - s^2)" by simp
  from rcongs sler  have twodivsumsq: "2 dvd (r^2 + s^2)" by simp
  from rcongs twodivdifsq twodivsumsq sler obtain x y z ::nat where xdef: "x = r*s" and ydef: "y = (r^2 - s^2)/2" and zdef: "z = (r^2 + s^2)/2"  by  (smt Suc_1 of_nat_1 real_of_nat_div semiring_1_class.of_nat_simps(2))
  from ydef have twoy: "2*y = r^2-s^2" by linarith
  from zdef  have "(r^2 + 2*s^2 - s^2)/2 = z" by simp
  from this sler2 ydef have "s^2 + y = z" by linarith
  hence "(s^2 + y)^2 = z^2" by simp
  hence "(s^2)^2 + 2*(s^2)*y + y^2 = z^2" by (simp add: power2_sum)
  hence "(2*y + s^2)*s^2 + y^2 = z^2" by (simp add: add.commute power2_eq_square semiring_normalization_rules(1) semiring_normalization_rules(16))
  from this twoy have "(r^2-s^2 + s^2)*s^2 + y^2 = z^2" by simp
  hence "r^2*s^2 + y^2 = z^2" by (simp add: less_or_eq_imp_le sler2)
  from this xdef have Pythxyz: "x^2 + y^2 = z^2" by (simp add: power_mult_distrib)
  from xdef ydef zdef have "x+y+z = r*s + (r^2-s^2)/2 + (r^2+s^2)/2"  by (simp add: zdef)
  hence "x+y+z = r*s + ((r^2-s^2) + (r^2+s^2))/2" by simp
  hence "x+y+z = r*s + (2*r^2)/2"  using sler2 by auto
  hence "x+y+z = r*s + r^2" by linarith
  hence "x+y+z = r*(s + r)" by (simp add: distrib_left power2_eq_square)
  from this rdef sdef have "x+y+z = ee*(2*dd-ee + ee)" by blast
  hence sumxyz: "x+y+z = 2*dd*ee" using eeltwod by auto
  from ddvdn dddef have dddvdn: "dd dvd n" by (metis dvd_mult_right)
  from edvdn eedef have eeevdn: "ee dvd n" by (metis dvd_mult_right)
  from dddef eedef have gcdgcd: "gcd dd ee = 1"  by (metis dle gcd_eq_0_iff gcd_mult_distrib_nat gr_implies_not0 mult_eq_self_implies_10)
  from dddvdn eeevdn gcdgcd have "(dd*ee) dvd n" using divides_mult by blast
  then obtain k::nat where kdef: "n = k*(dd*ee)" by (metis dvd_mult_div_cancel mult.commute)
  obtain a b c::nat where adef: "a = k*x" and bdef: "b = k*y" and cdef: "c = k*z" by simp
  from sumxyz adef bdef cdef kdef have sumabc: "a+b+c = 2*n" by (metis Groups.mult_ac(3) ab_semigroup_mult_class.mult_ac(1) distrib_left)
  from Pythxyz adef bdef cdef have Pythabc: "a^2 + b^2 = c^2" by (metis add_mult_distrib2 semiring_normalization_rules(30))
  from adef have a0: "a \<noteq> 0" using eeltwod kdef n0 sdef sler xdef by auto
  from bdef  have b0: "b \<noteq> 0" using kdef n0 sler2 twoy by auto
  from a0 b0 Pythabc sumabc show ?thesis  by blast
qed

lemma factorizationinprimes2:  "(k::nat) \<noteq> 0  \<Longrightarrow> (\<Prod>x\<in>prime_factors k. x ^ (2*multiplicity x k)) = k^2"
proof-
  assume "k \<noteq> 0"
  hence "k^2 \<noteq> 0" by simp
  hence  "(\<Prod>x\<in>prime_factors (k^2). x ^ multiplicity x (k^2)) = k^2" using prime_factorization_nat by auto
  hence "(\<Prod>x\<in>prime_factors (k^2). x ^ ( 2*multiplicity x k )) = k^2" by (metis (no_types, lifting) ASSUMPTION_I \<open>k \<noteq> 0\<close> in_prime_factors_imp_prime prime_elem_multiplicity_power_distrib prime_imp_prime_elem' prod.cong)
  thus ?thesis by (simp add: prime_factors_power)
qed

lemma MultSq:
  fixes n k :: nat
  assumes n0: "n \<noteq> 0"
    and Sq: "n = k^2"
  shows "\<forall> p. p \<in> prime_factors n \<longrightarrow> even (multiplicity p n)"
proof-
  from n0 have k0: "k \<noteq> 0"  by (simp add: Sq)
  hence "(\<Prod>x\<in>prime_factors k. x ^ (2*multiplicity x k)) = n" using factorizationinprimes2 Sq by blast
  thus ?thesis by (simp add: ASSUMPTION_I Sq in_prime_factors_imp_prime k0 prime_elem_multiplicity_power_distrib)
qed

lemma MultSqConverse:
  fixes n :: nat
  assumes n0: "n \<noteq> 0" and
    PrimePowSq: "\<forall> p. p \<in> prime_factors n \<longrightarrow> even (multiplicity p n)"
  shows "\<exists> k. n = k^2"
proof-
  have "\<forall> p. p \<in> prime_factors n \<longrightarrow> 2*((multiplicity p n) div 2) = multiplicity p n" using PrimePowSq dvd_mult_div_cancel by blast
  obtain k where Hk: "(\<Prod>x\<in>prime_factors n. x ^ ((multiplicity x n)div 2)) = k" by auto
  from Hk have "(\<Prod>x\<in>prime_factors n. x ^ ((multiplicity x n)div 2))^2 = k^2" by simp
  hence "(\<Prod>x\<in>prime_factors n. ( x ^ ((multiplicity x n)div 2) )^2 ) = k^2" by (metis (full_types) prod_power_distrib)
  hence "(\<Prod>x\<in>prime_factors n. x ^ (2*((multiplicity x n)div 2)) ) = k^2" by (simp add: \<open>(\<Prod>x\<in>prime_factors n. (x ^ (multiplicity x n div 2))\<^sup>2) = k\<^sup>2\<close> power_even_eq)
  hence "(\<Prod>x\<in>prime_factors n. x ^ (multiplicity x n) ) = k^2" using \<open>\<forall>p. p \<in># prime_factorization n \<longrightarrow> 2 * (multiplicity p n div 2) = multiplicity p n\<close> by auto
  thus ?thesis  using n0 prime_factorization_nat by auto
qed

lemma MultRelPrimes:
  fixes a b p :: nat
  assumes relprimes: "gcd a b = 1"
    and "prime p"
  shows "multiplicity p a = 0 \<or> multiplicity p b = 0"
  by (metis gcd_greatest_iff multiplicity_unit_left not_dvd_imp_multiplicity_0 relprimes)

lemma MultRelPrimes2:
  fixes a b p :: nat
  assumes relprimes: "gcd a b = 1"
    and "prime p"
  shows "multiplicity p a = multiplicity p (a*b) \<or> multiplicity p b =  multiplicity p (a*b)"
  by (smt ASSUMPTION_I MultRelPrimes One_nat_def assms(2) gcd.commute gcd_0_nat gcd_greatest_iff mult.right_neutral mult_is_0 multiplicity_normalize_left multiplicity_one_nat multiplicity_prime_elem_times_other multiplicity_unit_left multiplicity_zero not_dvd_imp_multiplicity_0 prime_elem_multiplicity_mult_distrib prime_imp_prime_elem' relprimes zero_neq_one zero_power2)

lemma EvenMultRelPrimes:
  fixes a b p :: nat
  assumes relprimes: "gcd a b = 1"
    and pprime: "prime p"
    and evenmultab:  "even (multiplicity p (a*b))"
  shows "even (multiplicity p a)"
  by (metis ASSUMPTION_I add.right_neutral assms(2) assms(3) dvd_0_right gcd_greatest_iff multiplicity_unit_left multiplicity_zero not_dvd_imp_multiplicity_0 prime_elem_multiplicity_mult_distrib prime_imp_prime_elem' relprimes)

lemma primeincl: "b \<noteq> 0 \<Longrightarrow> (a::nat) dvd b \<Longrightarrow>  p \<in> prime_factors a \<Longrightarrow> p \<in> prime_factors b"
proof-
  assume b0: "b \<noteq> 0"
  assume advdb:" a dvd b"
  assume "p \<in> prime_factors a"
  hence pprime: "prime p" and pdvda: "p dvd a" by auto
  have pdvdb: "p dvd b" using \<open>a dvd b\<close> gcd_nat.trans pdvda by blast
  from pprime pdvdb show ?thesis using b0 in_prime_factors_iff by blast
qed

lemma sqProdnatAsym: "b \<noteq> 0 \<Longrightarrow> gcd a b = 1 \<Longrightarrow> k^2 = (a::nat) * b \<Longrightarrow> (\<exists> r. r^2 = a)"
proof -
  assume b0: "b \<noteq> 0"
  assume GCDab1: "gcd a b = 1"
  assume ksqeqab: "k^2 = a*b"
  have "\<forall> p. p \<in> prime_factors (k^2) \<longrightarrow> even (multiplicity p (k^2))" by (metis MultSq even_zero multiplicity_zero)
  hence "\<forall> p. p \<in> prime_factors (k^2) \<longrightarrow> even (multiplicity p (a*b))"  by (simp add: ksqeqab)
  hence "\<forall> p. p \<in> prime_factors (k^2) \<longrightarrow> even (multiplicity p a)"
    using EvenMultRelPrimes GCDab1 in_prime_factors_imp_prime
    by metis
  hence "\<forall> p. p \<in> prime_factors a \<longrightarrow> even (multiplicity p a)" by (metis b0 dvdI ksqeqab no_zero_divisors primeincl)
  thus ?thesis by (metis MultSqConverse zero_power2)
qed

lemma sqProdnat: "k \<noteq> 0 \<Longrightarrow> gcd a b = 1 \<Longrightarrow> k^2 = (a::nat) * b \<Longrightarrow> (\<exists> r s. r^2 = a \<and> s^2 = b)"
  by (metis gcd.commute mult.commute mult_not_zero power_not_zero sqProdnatAsym)

lemma preatleastoneisoddPyth: " (a::nat)^2 + b^2 = c^2 \<Longrightarrow> \<not> ( odd a \<or> odd b)  \<Longrightarrow> \<not>( Gcd {a, b, c} = 1 )"
proof -
  assume Pyth:  "a^2 + b^2 = c^2"
  assume "\<not> ( odd a \<or> odd b)"
  hence evena: "even a" and evenb: "even b" by auto
  hence "even (a^2)" and "even (b^2)" by auto
  hence "even (a^2 + b^2)" by simp
  hence "even (c^2)" using Pyth by simp
  hence evenc: "even c" by simp
  from evena evenb evenc obtain aa bb cc :: nat where "a = 2*aa" and "b = 2*bb" and "c = 2*cc" by (meson evenE)
  hence "Gcd { 2*aa,  2*bb,  2*cc} = Gcd {a, b, c}" by simp
  hence "2*(Gcd { aa,  bb,  cc}) =  Gcd {a, b, c}" by (simp add: gcd_mult_distrib_nat)
  thus ?thesis by auto
qed

lemma atleastoneisoddPyth: " (a::nat)^2 + b^2 = c^2 \<Longrightarrow> Gcd {a, b, c} = 1  \<Longrightarrow>  odd a \<or> odd b"
  using preatleastoneisoddPyth by blast

lemma odddiv: "(n::nat) \<noteq> 0 \<Longrightarrow> d dvd (2*n) \<Longrightarrow> odd d \<Longrightarrow> d dvd n"
proof -
  assume a1: "d dvd 2 * n"
  assume a2: "odd d"
  have f3: "d dvd n * 2"
    using a1 by (simp add: mult.commute)
  have "gcd d 2 = 1"
    using a2 by (meson coprime_imp_gcd_eq_1 coprime_right_2_iff_odd)
  hence "d dvd n * 1"
    using f3 by (metis (no_types) dvd_triv_right  gcd_greatest_iff gcd_mult_distrib_nat)
  thus ?thesis
    by simp
qed

lemma PeriPythToShortDivRelPrimaodd:
  fixes n :: nat
  assumes  n0: "n \<noteq> 0"
    and aodd:  "odd a"
    and b0: " b \<noteq> 0"
    and Pythabc: "a^2 + b^2 = c^2"
    and sumabc: "a + b + c = 2*n"
    and Gcdabc1: " Gcd {a, b, c} = 1"
  shows "\<exists> d e. d dvd n \<and> e dvd n \<and> d < e \<and> e < 2*d"
proof-
  from aodd have a0: "a \<noteq> 0" by (meson even_zero)
  from Pythabc a0 have "b^2 < c^2" by (metis add_diff_cancel_right' aodd odd_pos zero_less_diff zero_less_power)
  hence blc: "b < c" using power_less_imp_less_base by blast
  then obtain v::nat where vdef: "b + v = c" using less_imp_add_positive by blast
  then obtain u::nat where udef: "u = c + b" by simp
  from Pythabc  have  "a^2+b^2 = (b+v)^2" using vdef by simp
  hence "a^2 + b^2 = 2*b*v + v^2 + b^2"  by (simp add: power2_sum)
  hence "a^2  = 2*b*v + v^2 " by simp
  hence "a^2  = (2*b + v)*v " by (simp add: power2_eq_square semiring_normalization_rules(1))
  hence auv: "a^2 = u*v" by (simp add: udef vdef)
  from auv aodd have uodd: "odd u"
    by (metis even_mult_iff even_power)
  from auv aodd have vodd: "odd v"
    using udef uodd vdef by auto
  from uodd vodd have gcduvodd: "odd (gcd u v)" using gcd_nat.bounded_iff by blast
  from udef vdef have "u + v = 2*c" by simp
  hence "(gcd u v) dvd (2*c)" by (metis dvd_add gcd_dvd1 gcd_dvd2)
  from this gcduvodd have gcduvdvdc: "(gcd u v) dvd c"  using blc gr_implies_not0 odddiv by blast
  from udef vdef have bdef: "u - v = 2*b" by simp
  hence "(gcd u v) dvd (2*b)"  by (metis dvd_diff_nat gcd_nat.cobounded1 gcd_nat.cobounded2)
  from this gcduvodd have gcduvdvdb: "(gcd u v) dvd b" using b0 odddiv by blast
  from auv have  "(gcd u v)^2 dvd (a^2)"  by (simp add: mult_dvd_mono power2_eq_square)
  hence gcduvdvda: "(gcd u v) dvd a" by simp
  from gcduvdvda gcduvdvdb gcduvdvdc have "(gcd u v) dvd (Gcd {a, b, c})" by simp
  from Gcdabc1 this  have gcduv1: "gcd u v = 1" by simp
  from gcduv1 auv obtain r s::nat where rdef: "r^2 = u" and sdef: "s^2 = v"
    by (meson a0 sqProdnat)
  from rdef sdef auv  have "a^2 = (r*s)^2"  by (simp add: power_mult_distrib)
  hence ars: "a = r*s" by simp
  from rdef have rodd: "odd r"  using even_power pos2 uodd by blast
  from sdef have sodd: "odd s"  using even_power pos2 vodd by blast
  obtain e::nat where edef: "e = r" by simp
  from rodd sodd obtain d::nat where ddef: "2*d = r+s" by (metis evenE odd_even_add)
  have slr: "s < r" by (metis \<open>u + v = 2 * c\<close> add_eq_self_zero b0 linorder_neqE_nat mult_2 nat_mult_eq_cancel_disj not_add_less2 odd_pos order_less_imp_le pos2 power_strict_mono rdef rodd sdef semiring_normalization_rules(23) udef vdef)
  from slr ddef edef have dle: "d < e"  by linarith
  from ddef edef have dltwoe: "e < 2*d" by (simp add: odd_pos sodd)
  from sumabc rdef sdef have "a + u = 2*n" using udef by auto
  hence "a + r^2 = 2*n"  using rdef by blast
  from this ars  have "r*s + r^2 = 2*n" by simp
  hence  "(s + r)*r = 2*n" by (metis power2_eq_square semiring_normalization_rules(1) semiring_normalization_rules(7))
  hence "2*d*e = 2*n" using ddef edef by (simp add: semiring_normalization_rules(24))
  hence den: "d*e = n" by simp
  from den have ddvdn: "d dvd n" using dvdI by blast
  from den have edvdn: "e dvd n" using dvd_triv_right by blast
  show ?thesis  using ddvdn dle dltwoe edvdn by blast
qed

lemma PeriPythToShortDivRelPrim:
  fixes n :: nat
  assumes  n0: "n \<noteq> 0"
    and a0:  "a \<noteq> 0"
    and b0: " b \<noteq> 0"
    and Pythabc: "a^2 + b^2 = c^2"
    and sumabc: "a + b + c = 2*n"
    and Gcdabc1: " Gcd {a, b, c} = 1"
  shows "\<exists> d e. d dvd n \<and> e dvd n \<and> d < e \<and> e < 2*d"
proof (cases "odd a")
  case True
  hence aodd: "odd a" by simp
  from n0 aodd b0 Pythabc sumabc Gcdabc1  show ?thesis  using PeriPythToShortDivRelPrimaodd  by blast
next
  case False
  hence bodd: "odd b" using Gcdabc1 Pythabc atleastoneisoddPyth by blast
  from Pythabc have Pythbac: "b^2 + a^2 = c^2" by simp
  from sumabc have sumbac: "b + a + c = 2*n" by simp
  from Gcdabc1 have Gcdbac1: "Gcd {b, a, c} = 1"  by (simp add: insert_commute)
  from n0 bodd a0 Pythbac sumbac Gcdbac1  show ?thesis  using PeriPythToShortDivRelPrimaodd by blast
qed

text {*
Given a nonzero natural number n, if 2*n is the perimeter of a
Pythagorean triangle then n has a pair of divisors d and e satisfying d < e < 2*d.
*}

theorem PeriPythToShortDiv:
  fixes n :: nat
  assumes  n0: "n \<noteq> 0"
    and peripyth: "\<exists> a b c.  a \<noteq> 0 \<and> b \<noteq> 0 \<and> a^2 + b^2 = c^2 \<and> a + b + c = 2*n"
  shows "\<exists> d e. d dvd n \<and> e dvd n \<and> d < e \<and> e < 2*d"
proof-
  from peripyth obtain a b c :: nat where a0: "a \<noteq> 0" and b0: "b \<noteq> 0" and Pythabc: "a^2 + b^2 = c^2" and sumabc: "a + b + c = 2*n" by auto
  have "(Gcd {a, b, c}) dvd a" by simp
  then obtain x :: nat where xdef: "a = (Gcd {a, b, c})*x" using dvdE by blast
  have "(Gcd {a, b, c}) dvd b" by (meson Gcd_dvd_nat insertCI)
  then obtain y :: nat where ydef: "b = (Gcd {a, b, c})*y" using dvdE by blast
  have "(Gcd {a, b, c}) dvd c" by (meson Gcd_dvd_nat insertCI)
  then obtain z :: nat where zdef: "c = (Gcd {a, b, c})*z" using dvdE by blast
  from a0 xdef have x0: "x \<noteq> 0"  using mult_not_zero by fastforce
  from b0 ydef have y0: "y \<noteq> 0"  using mult_not_zero by fastforce
  from a0 have Gcdabc0: "Gcd {a, b, c} \<noteq> 0" by auto
  from  Gcdabc0 Pythabc xdef ydef zdef have Pythxyz: "x^2 + y^2 = z^2" by (smt add_mult_distrib2 nat_mult_eq_cancel_disj power_eq_0_iff power_mult_distrib)
  from Gcdabc0 xdef ydef zdef have "Gcd {a, b, c} = Gcd {(Gcd {a, b, c})*x, (Gcd {a, b, c})*y, (Gcd {a, b, c})*z}" by simp
  hence "Gcd {a, b, c} = (Gcd {a, b, c})*Gcd {x, y, z}" by (simp add: gcd_mult_distrib_nat)
  hence Gcdxyz1: "Gcd {x, y, z} = 1" using Gcdabc0 by auto
  from xdef ydef zdef  sumabc have gcdxyz2n:  "(Gcd {a, b, c})*(x + y + z) = 2*n"  by (metis distrib_left)
  from this Pythxyz obtain  nn:: nat where nndef: "x+y+z = 2*nn" using PerPythEven dvdE by blast
  from  gcdxyz2n  nndef  have Gcdnn: "(Gcd {a, b, c})*nn = n" by auto
  from this n0 have nn0: "nn \<noteq> 0" using mult_not_zero by blast
  from nn0 x0 y0 Pythxyz nndef Gcdxyz1  have "\<exists> d e. d dvd nn \<and> e dvd nn \<and> d < e \<and> e < 2*d" using PeriPythToShortDivRelPrim by blast
  then obtain dd ee::nat where dddvdn: "dd dvd nn" and eedvdn :"ee dvd nn" and ddlee: "dd < ee" and eeltwodd: "ee < 2*dd" by auto
  then obtain d e:: nat where ddef: "d = (Gcd {a, b, c})*dd" and edef: "e = (Gcd {a, b, c})*ee" by simp
  from ddef edef ddlee have dle: "d < e"  using Gcdabc0 mult_less_mono2 by blast
  from ddef edef eeltwodd have eltwod: "e < 2*d" using Gcdabc0 by auto
  from ddef dddvdn have ddvdn: "d dvd n" using Gcdnn nat_mult_dvd_cancel_disj by blast
  from edef eedvdn have edvdn: "e dvd n" using Gcdnn nat_mult_dvd_cancel_disj by blast
  from ddvdn edvdn show ?thesis using dle eltwod by blast
qed

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_SSortPermutes
  imports "../../Test_Base"
begin

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

fun ssortminimum1 :: "int => int list => int" where
  "ssortminimum1 x (nil2) = x"
| "ssortminimum1 x (cons2 y1 ys1) =
     (if y1 <= x then ssortminimum1 y1 ys1 else ssortminimum1 x ys1)"

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

(*fun did not finish the proof*)
function ssort :: "int list => int list" where
  "ssort (nil2) = nil2"
| "ssort (cons2 y ys) =
     (let m :: int = ssortminimum1 y ys
     in cons2
          m
          (ssort
             (deleteBy
                (% (z :: int) => % (x2 :: int) => (z = x2)) m (cons2 y ys))))"
  by pat_completeness auto

theorem property0 :
  "isPermutation (ssort xs) xs"
  oops

end


theory Ln_Arctan_Series
imports Complex_Main Summation "~~/src/HOL/Multivariate_Analysis/Complex_Transcendental"
begin

lemma Ln_series:
  fixes z :: complex
  assumes "norm z < 1"
  shows   "(\<lambda>n. (-1)^Suc n / of_nat n * z^n) sums ln (1 + z)" (is "(\<lambda>n. ?f n * z^n) sums _")
proof -
  let ?F = "\<lambda>z. \<Sum>n. ?f n * z^n" and ?F' = "\<lambda>z. \<Sum>n. diffs ?f n * z^n"
  have r: "conv_radius ?f = 1"
    by (intro conv_radius_ratio_limit_nonzero[of _ 1])
       (simp_all add: norm_divide LIMSEQ_Suc_n_over_n del: of_nat_Suc)

  have "\<exists>c. \<forall>z\<in>ball 0 1. ln (1 + z) - ?F z = c"
  proof (rule has_field_derivative_zero_constant)
    fix z :: complex assume z': "z \<in> ball 0 1"
    hence z: "norm z < 1" by (simp add: dist_0_norm)
    def t \<equiv> "of_real (1 + norm z) / 2 :: complex"
    from z have t: "norm z < norm t" "norm t < 1" unfolding t_def
      by (simp_all add: field_simps norm_divide del: of_real_add)

    have "Re (-z) \<le> norm (-z)" by (rule complex_Re_le_cmod)
    also from z have "... < 1" by simp
    finally have "((\<lambda>z. ln (1 + z)) has_field_derivative inverse (1+z)) (at z)"
      by (auto intro!: derivative_eq_intros)
    moreover have "(?F has_field_derivative ?F' z) (at z)" using t r
      by (intro termdiffs_strong[of _ t] summable_in_conv_radius) simp_all
    ultimately have "((\<lambda>z. ln (1 + z) - ?F z) has_field_derivative (inverse (1 + z) - ?F' z))
                       (at z within ball 0 1)"
      by (intro derivative_intros) (simp_all add: at_within_open[OF z'])
    also have "(\<lambda>n. of_nat n * ?f n * z ^ (n - Suc 0)) sums ?F' z" using t r
      by (intro diffs_equiv termdiff_converges[OF t(1)] summable_in_conv_radius) simp_all
    from sums_split_initial_segment[OF this, of 1]
      have "(\<lambda>i. (-z) ^ i) sums ?F' z" by (simp add: power_minus[of z] del: of_nat_Suc)
    hence "?F' z = inverse (1 + z)" using z by (simp add: sums_iff suminf_geometric divide_inverse)
    also have "inverse (1 + z) - inverse (1 + z) = 0" by simp
    finally show "((\<lambda>z. ln (1 + z) - ?F z) has_field_derivative 0) (at z within ball 0 1)" .
  qed simp_all
  then obtain c where c: "\<And>z. z \<in> ball 0 1 \<Longrightarrow> ln (1 + z) - ?F z = c" by blast
  from c[of 0] have "c = 0" by (simp only: powser_zero) simp
  with c[of z] assms have "ln (1 + z) = ?F z" by (simp add: dist_0_norm)
  moreover have "summable (\<lambda>n. ?f n * z^n)" using assms r
    by (intro summable_in_conv_radius) simp_all
  ultimately show ?thesis by (simp add: sums_iff)
qed

lemma Ln_approx_linear:
  fixes z :: complex
  assumes "norm z < 1"
  shows   "norm (ln (1 + z) - z) \<le> norm z^2 / (1 - norm z)"
proof -
  let ?f = "\<lambda>n. (-1)^Suc n / of_nat n"
  from assms have "(\<lambda>n. ?f n * z^n) sums ln (1 + z)" using Ln_series by simp
  moreover have "(\<lambda>n. (if n = 1 then 1 else 0) * z^n) sums z" using powser_sums_if[of 1] by simp
  ultimately have "(\<lambda>n. (?f n - (if n = 1 then 1 else 0)) * z^n) sums (ln (1 + z) - z)"
    by (subst left_diff_distrib, intro sums_diff) simp_all
  from sums_split_initial_segment[OF this, of "Suc 1"]
    have "(\<lambda>i. (-(z^2)) * inverse (2 + of_nat i) * (- z)^i) sums (Ln (1 + z) - z)"
    by (simp add: power2_eq_square mult_ac power_minus[of z] divide_inverse)
  hence "(Ln (1 + z) - z) = (\<Sum>i. (-(z^2)) * inverse (of_nat (i+2)) * (-z)^i)"
    by (simp add: sums_iff)
  also have A: "summable (\<lambda>n. norm z^2 * (inverse (real_of_nat (Suc (Suc n))) * cmod z ^ n))"
    by (rule summable_mult, rule summable_comparison_test_ev[OF _ summable_geometric[of "norm z"]])
       (auto simp: assms field_simps intro!: always_eventually)
  hence "norm (\<Sum>i. (-(z^2)) * inverse (of_nat (i+2)) * (-z)^i) \<le>
             (\<Sum>i. norm (-(z^2) * inverse (of_nat (i+2)) * (-z)^i))"
    by (intro summable_norm)
       (auto simp: norm_power norm_inverse norm_mult mult_ac simp del: of_nat_add of_nat_Suc)
  also have "norm ((-z)^2 * (-z)^i) * inverse (of_nat (i+2)) \<le> norm ((-z)^2 * (-z)^i) * 1" for i
    by (intro mult_left_mono) (simp_all add: divide_simps)
  hence "(\<Sum>i. norm (-(z^2) * inverse (of_nat (i+2)) * (-z)^i)) \<le>
           (\<Sum>i. norm (-(z^2) * (-z)^i))" using A assms
    apply (simp_all only: norm_power norm_inverse norm_divide norm_mult)
    apply (intro suminf_le summable_mult summable_geometric)
    apply (auto simp: norm_power field_simps simp del: of_nat_add of_nat_Suc)
    done
  also have "... = norm z^2 * (\<Sum>i. norm z^i)" using assms
    by (subst suminf_mult [symmetric]) (auto intro!: summable_geometric simp: norm_mult norm_power)
  also have "(\<Sum>i. norm z^i) = inverse (1 - norm z)" using assms
    by (subst suminf_geometric) (simp_all add: divide_inverse)
  also have "norm z^2 * ... = norm z^2 / (1 - norm z)" by (simp add: divide_inverse)
  finally show ?thesis .
qed

lemma Arctan_series:
  assumes z: "norm (z :: complex) < 1"
  defines "g \<equiv> \<lambda>n. if odd n then -\<i>*\<i>^n / n else 0"
  defines "h \<equiv> \<lambda>z n. (-1)^n / of_nat (2*n+1) * (z::complex)^(2*n+1)"
  shows   "(\<lambda>n. g n * z^n) sums Arctan z"
  and     "h z sums Arctan z"
proof -
  def G \<equiv> "\<lambda>z. (\<Sum>n. g n * z^n)"
  have summable: "summable (\<lambda>n. g n * u^n)" if "norm u < 1" for u
  proof (cases "u = 0")
    assume u: "u \<noteq> 0"
    have "(\<lambda>n. ereal (norm (h u n) / norm (h u (Suc n)))) = (\<lambda>n. ereal (inverse (norm u)^2) *
              ereal ((2 + inverse (real (Suc n))) / (2 - inverse (real (Suc n)))))"
    proof
      fix n
      have "ereal (norm (h u n) / norm (h u (Suc n))) =
             ereal (inverse (norm u)^2) * ereal ((of_nat (2*Suc n+1) / of_nat (Suc n)) /
                 (of_nat (2*Suc n-1) / of_nat (Suc n)))"
      by (simp add: h_def norm_mult norm_power norm_divide divide_simps
                    power2_eq_square eval_nat_numeral del: of_nat_add of_nat_Suc)
      also have "of_nat (2*Suc n+1) / of_nat (Suc n) = (2::real) + inverse (real (Suc n))"
        by (auto simp: divide_simps simp del: of_nat_Suc) simp_all?
      also have "of_nat (2*Suc n-1) / of_nat (Suc n) = (2::real) - inverse (real (Suc n))"
        by (auto simp: divide_simps simp del: of_nat_Suc) simp_all?
      finally show "ereal (norm (h u n) / norm (h u (Suc n))) = ereal (inverse (norm u)^2) *
              ereal ((2 + inverse (real (Suc n))) / (2 - inverse (real (Suc n))))" .
    qed
    also have "\<dots> ----> ereal (inverse (norm u)^2) * ereal ((2 + 0) / (2 - 0))"
      by (intro tendsto_intros LIMSEQ_inverse_real_of_nat) simp_all
    finally have "liminf (\<lambda>n. ereal (cmod (h u n) / cmod (h u (Suc n)))) = inverse (norm u)^2"
      by (intro lim_imp_Liminf) simp_all
    moreover from power_strict_mono[OF that, of 2] u have "inverse (norm u)^2 > 1"
      by (simp add: divide_simps)
    ultimately have A: "liminf (\<lambda>n. ereal (cmod (h u n) / cmod (h u (Suc n)))) > 1" by simp
    from u have "summable (h u)"
      by (intro summable_norm_cancel[OF ratio_test_convergence[OF _ A]])
         (auto simp: h_def norm_divide norm_mult norm_power simp del: of_nat_Suc
               intro!: mult_pos_pos divide_pos_pos always_eventually)
    thus "summable (\<lambda>n. g n * u^n)"
      by (subst summable_mono_reindex[of "\<lambda>n. 2*n+1", symmetric])
         (auto simp: power_mult subseq_def g_def h_def elim!: oddE)
  qed (simp add: h_def)

  have "\<exists>c. \<forall>u\<in>ball 0 1. Arctan u - G u = c"
  proof (rule has_field_derivative_zero_constant)
    fix u :: complex assume "u \<in> ball 0 1"
    hence u: "norm u < 1" by (simp add: dist_0_norm)
    def K \<equiv> "(norm u + 1) / 2"
    from u and abs_Im_le_cmod[of u] have Im_u: "\<bar>Im u\<bar> < 1" by linarith
    from u have K: "0 \<le> K" "norm u < K" "K < 1" by (simp_all add: K_def)
    hence "(G has_field_derivative (\<Sum>n. diffs g n * u ^ n)) (at u)" unfolding G_def
      by (intro termdiffs_strong[of _ "of_real K"] summable) simp_all
    also have "(\<lambda>n. diffs g n * u^n) = (\<lambda>n. if even n then (\<i>*u)^n else 0)"
      by (intro ext) (simp_all del: of_nat_Suc add: g_def diffs_def power_mult_distrib)
    also have "suminf \<dots> = (\<Sum>n. (-(u^2))^n)"
      by (subst suminf_mono_reindex[of "\<lambda>n. 2*n", symmetric])
         (auto elim!: evenE simp: subseq_def power_mult power_mult_distrib)
    also from u have "norm u^2 < 1^2" by (intro power_strict_mono) simp_all
    hence "(\<Sum>n. (-(u^2))^n) = inverse (1 + u^2)"
      by (subst suminf_geometric) (simp_all add: norm_power inverse_eq_divide)
    finally have "(G has_field_derivative inverse (1 + u\<^sup>2)) (at u)" .
    from DERIV_diff[OF has_field_derivative_Arctan this] Im_u u
      show "((\<lambda>u. Arctan u - G u) has_field_derivative 0) (at u within ball 0 1)"
      by (simp_all add: dist_0_norm at_within_open[OF _ open_ball])
  qed simp_all
  then obtain c where c: "\<And>u. norm u < 1 \<Longrightarrow> Arctan u - G u = c" by (auto simp: dist_0_norm)
  from this[of 0] have "c = 0" by (simp add: G_def g_def powser_zero)
  with c z have "Arctan z = G z" by simp
  with summable[OF z] show "(\<lambda>n. g n * z^n) sums Arctan z" unfolding G_def by (simp add: sums_iff)
  thus "h z sums Arctan z" by (subst (asm) sums_mono_reindex[of "\<lambda>n. 2*n+1", symmetric])
                              (auto elim!: oddE simp: subseq_def power_mult g_def h_def)
qed

definition "moebius a b c d = (\<lambda>z. (a*z+b) / (c*z+d :: 'a :: field))"

lemma moebius_inverse:
  assumes "a * d \<noteq> b * c" "c * z + d \<noteq> 0"
  shows   "moebius d (-b) (-c) a (moebius a b c d z) = z"
proof -
  from assms have "(-c) * moebius a b c d z + a \<noteq> 0" unfolding moebius_def
    by (simp add: field_simps)
  with assms show ?thesis
    unfolding moebius_def by (simp add: moebius_def divide_simps) (simp add: algebra_simps)?
qed

lemma moebius_inverse':
  assumes "a * d \<noteq> b * c" "c * z - a \<noteq> 0"
  shows   "moebius a b c d (moebius d (-b) (-c) a z) = z"
  using assms moebius_inverse[of d a "-b" "-c" z]
  by (auto simp: algebra_simps)

lemma Arctan_def_moebius: "Arctan z = \<i>/2 * Ln (moebius (-\<i>) 1 \<i> 1 z)"
  by (simp add: Arctan_def moebius_def add_ac)

lemma Ln_conv_Arctan:
  assumes "z \<noteq> -1"
  shows   "Ln z = -2*\<i> * Arctan (moebius 1 (- 1) (- \<i>) (- \<i>) z)"
proof -
  have "Arctan (moebius 1 (- 1) (- \<i>) (- \<i>) z) =
             \<i>/2 * Ln (moebius (- \<i>) 1 \<i> 1 (moebius 1 (- 1) (- \<i>) (- \<i>) z))"
    by (simp add: Arctan_def_moebius)
  also from assms have "\<i> * z \<noteq> \<i> * (-1)" by (subst mult_left_cancel) simp
  hence "\<i> * z - -\<i> \<noteq> 0" by (simp add: eq_neg_iff_add_eq_0)
  from moebius_inverse'[OF _ this, of 1 1]
    have "moebius (- \<i>) 1 \<i> 1 (moebius 1 (- 1) (- \<i>) (- \<i>) z) = z" by simp
  finally show ?thesis by (simp add: field_simps)
qed

lemma ln_series_quadratic:
  assumes x: "x > (0::real)"
  shows "(\<lambda>n. (2*((x - 1) / (x + 1)) ^ (2*n+1) / of_nat (2*n+1))) sums ln x"
proof -
  def y \<equiv> "of_real ((x-1)/(x+1)) :: complex"
  from x have x': "complex_of_real x \<noteq> of_real (-1)"  by (subst of_real_eq_iff) auto
  from x have "\<bar>x - 1\<bar> < \<bar>x + 1\<bar>" by linarith
  hence "norm (complex_of_real (x - 1) / complex_of_real (x + 1)) < 1"
    by (simp add: norm_divide del: of_real_add of_real_diff)
  hence "norm (\<i> * y) < 1" unfolding y_def by (subst norm_mult) simp
  hence "(\<lambda>n. (-2*\<i>) * ((-1)^n / of_nat (2*n+1) * (\<i>*y)^(2*n+1))) sums ((-2*\<i>) * Arctan (\<i>*y))"
    by (intro Arctan_series sums_mult) simp_all
  also have "(\<lambda>n. (-2*\<i>) * ((-1)^n / of_nat (2*n+1) * (\<i>*y)^(2*n+1))) =
                 (\<lambda>n. (-2*\<i>) * ((-1)^n * (\<i>*y*(-y\<^sup>2)^n)/of_nat (2*n+1)))"
    by (intro ext) (simp_all add: power_mult power_mult_distrib)
  also have "\<dots> = (\<lambda>n. 2*y* ((-1) * (-y\<^sup>2))^n/of_nat (2*n+1))"
    by (intro ext, subst power_mult_distrib) (simp add: algebra_simps power_mult)
  also have "\<dots> = (\<lambda>n. 2*y^(2*n+1) / of_nat (2*n+1))"
    by (subst power_add, subst power_mult) (simp add: mult_ac)
  also have "\<dots> = (\<lambda>n. of_real (2*((x-1)/(x+1))^(2*n+1) / of_nat (2*n+1)))"
    by (intro ext) (simp add: y_def)
  also have "\<i> * y = (of_real x - 1) / (-\<i> * (of_real x + 1))"
    by (subst divide_divide_eq_left [symmetric]) (simp add: y_def)
  also have "\<dots> = moebius 1 (-1) (-\<i>) (-\<i>) (of_real x)" by (simp add: moebius_def algebra_simps)
  also from x' have "-2*\<i>*Arctan \<dots> = Ln (of_real x)" by (intro Ln_conv_Arctan [symmetric]) simp_all
  also from x have "\<dots> = ln x" by (rule Ln_of_real)
  finally show ?thesis by (subst (asm) sums_of_real_iff)
qed

end


(*  Title:      ZF/AC/WO1_AC.thy
    Author:     Krzysztof Grabczewski

The proofs of WO1 \<Longrightarrow> AC1 and WO1 \<Longrightarrow> AC10(n) for n >= 1

The latter proof is referred to as clear by the Rubins.
However it seems to be quite complicated.
The formal proof presented below is a mechanisation of the proof
by Lawrence C. Paulson which is the following:

Assume WO1.  Let s be a set of infinite sets.

Suppose x \<in> s.  Then x is equipollent to |x| (by WO1), an infinite cardinal
call it K.  Since K = K \<oplus> K = |K+K| (by InfCard_cdouble_eq) there is an
isomorphism h \<in> bij(K+K, x).  (Here + means disjoint sum.)

So there is a partition of x into 2-element sets, namely

        {{h(Inl(i)), h(Inr(i))} . i \<in> K}

So for all x \<in> s the desired partition exists.  By AC1 (which follows from WO1)
there exists a function f that chooses a partition for each x \<in> s.  Therefore we
have AC10(2).

*)

theory WO1_AC
imports AC_Equiv
begin

(* ********************************************************************** *)
(* WO1 \<Longrightarrow> AC1                                                            *)
(* ********************************************************************** *)

theorem WO1_AC1: "WO1 \<Longrightarrow> AC1"
by (unfold AC1_def WO1_def, fast elim!: ex_choice_fun)

(* ********************************************************************** *)
(* WO1 \<Longrightarrow> AC10(n) (n >= 1)                                               *)
(* ********************************************************************** *)

lemma lemma1: "\<lbrakk>WO1; \<forall>B \<in> A. \<exists>C \<in> D(B). P(C,B)\<rbrakk> \<Longrightarrow> \<exists>f. \<forall>B \<in> A. P(f`B,B)"
  unfolding WO1_def
apply (erule_tac x = "\<Union>({{C \<in> D (B) . P (C,B) }. B \<in> A}) " in allE)
apply (erule exE, drule ex_choice_fun, fast)
apply (erule exE)
apply (rule_tac x = "\<lambda>x \<in> A. f`{C \<in> D (x) . P (C,x) }" in exI)
apply (simp, blast dest!: apply_type [OF _ RepFunI])
done

lemma lemma2_1: "\<lbrakk>\<not>Finite(B); WO1\<rbrakk> \<Longrightarrow> |B| + |B| \<approx>  B"
  unfolding WO1_def
apply (rule eqpoll_trans)
prefer 2 apply (fast elim!: well_ord_cardinal_eqpoll)
apply (rule eqpoll_sym [THEN eqpoll_trans])
apply (fast elim!: well_ord_cardinal_eqpoll)
apply (drule spec [of _ B])
apply (clarify dest!: eqpoll_imp_Finite_iff [OF well_ord_cardinal_eqpoll])
apply (simp add: cadd_def [symmetric]
            eqpoll_refl InfCard_cdouble_eq Card_cardinal Inf_Card_is_InfCard)
done

lemma lemma2_2:
     "f \<in> bij(D+D, B) \<Longrightarrow> {{f`Inl(i), f`Inr(i)}. i \<in> D} \<in> Pow(Pow(B))"
by (fast elim!: bij_is_fun [THEN apply_type])

lemma lemma2_3:
        "f \<in> bij(D+D, B) \<Longrightarrow> pairwise_disjoint({{f`Inl(i), f`Inr(i)}. i \<in> D})"
  unfolding pairwise_disjoint_def
apply (blast dest: bij_is_inj [THEN inj_apply_equality])
done

lemma lemma2_4:
     "\<lbrakk>f \<in> bij(D+D, B); 1\<le>n\<rbrakk>
      \<Longrightarrow> sets_of_size_between({{f`Inl(i), f`Inr(i)}. i \<in> D}, 2, succ(n))"
apply (simp (no_asm_simp) add: sets_of_size_between_def succ_def)
apply (blast intro!: cons_lepoll_cong
            intro: singleton_eqpoll_1 [THEN eqpoll_imp_lepoll]
                   le_imp_subset [THEN subset_imp_lepoll]  lepoll_trans
            dest: bij_is_inj [THEN inj_apply_equality] elim!: mem_irrefl)
done

lemma lemma2_5:
     "f \<in> bij(D+D, B) \<Longrightarrow> \<Union>({{f`Inl(i), f`Inr(i)}. i \<in> D})=B"
  unfolding bij_def surj_def
apply (fast elim!: inj_is_fun [THEN apply_type])
done

lemma lemma2:
     "\<lbrakk>WO1; \<not>Finite(B); 1\<le>n\<rbrakk>
      \<Longrightarrow> \<exists>C \<in> Pow(Pow(B)). pairwise_disjoint(C) \<and>
                sets_of_size_between(C, 2, succ(n)) \<and>
                \<Union>(C)=B"
apply (drule lemma2_1 [THEN eqpoll_def [THEN def_imp_iff, THEN iffD1]],
       assumption)
apply (blast intro!: lemma2_2 lemma2_3 lemma2_4 lemma2_5)
done

theorem WO1_AC10: "\<lbrakk>WO1; 1\<le>n\<rbrakk> \<Longrightarrow> AC10(n)"
  unfolding AC10_def
apply (fast intro!: lemma1 elim!: lemma2)
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_BubSortIsSort
  imports "../../Test_Base"
begin

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

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

fun insert :: "int => int list => int list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun bubble :: "int list => (bool, (int list)) pair" where
  "bubble (nil2) = pair2 False (nil2)"
| "bubble (cons2 y (nil2)) = pair2 False (cons2 y (nil2))"
| "bubble (cons2 y (cons2 y2 xs)) =
     (if y <= y2 then
        (case bubble (cons2 y2 xs) of
           pair2 b22 ys22 => pair2 b22 (cons2 y ys22))
        else
        (case bubble (cons2 y xs) of
           pair2 b2 ys2 => pair2 True (cons2 y2 ys2)))"

(*fun did not finish the proof*)
function bubsort :: "int list => int list" where
  "bubsort x =
   (case bubble x of pair2 b1 ys => (if b1 then bubsort ys else x))"
  by pat_completeness auto

theorem property0 :
  "((bubsort xs) = (isort xs))"
  oops

end


header {* Sums in monoids*}

theory MonoidSums

imports Main
  "~~/src/HOL/Algebra/Module"
  RingModuleFacts
  FunctionLemmas
begin

text {* We build on the finite product simplifications in FiniteProduct.thy and the analogous ones
for finite sums (see "lemmas" in Ring.thy).*}

text {*Use as an intro rule*}
lemma (in comm_monoid) factors_equal:
  "\<lbrakk>a=b; c=d\<rbrakk> \<Longrightarrow> a\<otimes>\<^bsub>G\<^esub>c =  b\<otimes>\<^bsub>G\<^esub>d"
  by simp

lemma (in comm_monoid) extend_prod:
  fixes a A S
  assumes fin: "finite S" and subset: "A\<subseteq>S" and a: "a\<in>A\<rightarrow>carrier G"
  shows "(\<Otimes>\<^bsub>G\<^esub> x\<in>S. (if x\<in>A then a x else \<one>\<^bsub>G\<^esub>)) = (\<Otimes>\<^bsub>G\<^esub> x\<in>A. a x)"
  (is "(\<Otimes>\<^bsub>G\<^esub> x\<in>S. ?b x) = (\<Otimes>\<^bsub>G\<^esub> x\<in>A. a x)")
proof -
  from subset have uni:"S = A \<union> (S-A)" by auto
  from assms subset show ?thesis
    apply (subst uni)
    apply (subst finprod_Un_disjoint, auto)
    by (auto cong: finprod_cong if_cong elim: finite_subset simp add:Pi_def finite_subset)
(*Pi_def is key for automation here*)
qed

text {*Scalar multiplication distributes over scalar multiplication (on left). *}(*Add to module.*)
lemma (in module) finsum_smult:
  "[| finite A; c\<in> carrier R; g \<in> A -> carrier M |] ==>
   (c \<odot>\<^bsub>M\<^esub> finsum M g A) = finsum M (%x. c \<odot>\<^bsub>M\<^esub> g x) A "
proof (induct set: finite)
  case empty
  from `c\<in>carrier R` show ?case
    by simp
next
  case (insert a A)
  from insert.hyps insert.prems have 1: "finsum M g (insert a A) = g a \<oplus>\<^bsub>M\<^esub> finsum M g A"
    by (intro finsum_insert, auto)
  from insert.hyps insert.prems have 2: "(\<Oplus>\<^bsub>M\<^esub>x\<in>insert a A. c \<odot>\<^bsub>M\<^esub> g x) = c \<odot>\<^bsub>M\<^esub> g a \<oplus>\<^bsub>M\<^esub>(\<Oplus>\<^bsub>M\<^esub>x\<in>A. c \<odot>\<^bsub>M\<^esub> g x)"
    by (intro finsum_insert, auto)
  from insert.hyps insert.prems show ?case
    by (auto simp add:1 2 smult_r_distr finsum_closed)
qed

text {*Scalar multiplication distributes over scalar multiplication (on right). *}(*Add to module.*)
lemma (in module) finsum_smult_r:
  "[| finite A; v\<in> carrier M; f \<in> A -> carrier R |] ==>
   (finsum R f A \<odot>\<^bsub>M\<^esub> v) = finsum M (%x. f x \<odot>\<^bsub>M\<^esub> v) A "
proof (induct set: finite)
  case empty
  from `v\<in>carrier M` show ?case
    by simp
next
  case (insert a A)
  from insert.hyps insert.prems have 1: "finsum R f (insert a A) = f a \<oplus>\<^bsub>R\<^esub> finsum R f A"
    by (intro R.finsum_insert, auto)
  from insert.hyps insert.prems have 2: "(\<Oplus>\<^bsub>M\<^esub>x\<in>insert a A. f x \<odot>\<^bsub>M\<^esub> v) = f a \<odot>\<^bsub>M\<^esub> v \<oplus>\<^bsub>M\<^esub>(\<Oplus>\<^bsub>M\<^esub>x\<in>A. f x \<odot>\<^bsub>M\<^esub> v)"
    by (intro finsum_insert, auto)
  from insert.hyps insert.prems show ?case
    by (auto simp add:1 2 smult_l_distr finsum_closed)
qed

text {*A sequence of lemmas that shows that the product does not depend on the ambient group.
Note I had to dig back into the definitions of foldSet to show this. *}
(*Add the following 2 lemmas to Group.*)

lemma foldD_not_depend:
  fixes D E B f e A
  assumes h1: "LCD B D f" and h2: "LCD B E f" and h3: "D\<subseteq>E" and h4: "e\<in>D" and h5: "A\<subseteq>B" and h6: "finite B"
  shows "foldD D f e A = foldD E f e A"
proof -
  from assms have 1: "\<exists>y. (A,y)\<in>foldSetD D f e"
    apply (intro finite_imp_foldSetD, auto)
     apply (metis finite_subset)
    by (unfold LCD_def, auto)
  from 1 obtain y where 2: "(A,y)\<in>foldSetD D f e" by auto
  from assms 2 have 3: "foldD D f e A = y" by (intro LCD.foldD_equality[of B], auto)
  from h3 have 4: "foldSetD D f e \<subseteq> foldSetD E f e" by (rule foldSet_not_depend)
  from 2 4 have 5: "(A,y)\<in>foldSetD E f e" by auto
  from assms 5 have 6: "foldD E f e A = y" by (intro LCD.foldD_equality[of B], auto)
(*(A,y)\<in>f*)
  from 3 6 show ?thesis by auto
qed

lemma (in comm_monoid) finprod_all1[simp]:
  assumes fin: "finite A" and all1:" \<And>a. a\<in>A\<Longrightarrow>f a = \<one>\<^bsub>G\<^esub>"
  shows "(\<Otimes>\<^bsub>G\<^esub> a\<in>A. f a) = \<one>\<^bsub>G\<^esub>"
(*  "[| \<And>a. a\<in>A\<Longrightarrow>f a = \<one>\<^bsub>G\<^esub> |] ==> (\<Otimes>\<^bsub>G\<^esub> a\<in>A. f a) = \<one>\<^bsub>G\<^esub>" won't work with proof - *)
proof -
  from assms show ?thesis
    by (simp cong: finprod_cong)
qed

context abelian_monoid
begin
lemmas summands_equal = add.factors_equal
lemmas extend_sum = add.extend_prod
lemmas finsum_all0 = add.finprod_all1
end

end


(*
Title: Trapezoidal numbers
Author: Jose Manuel Rodriguez Caballero

We formally verify the main result from the paper [gamer1985trapezoidal]:

Definition. A natural number is trapezoidal if it is the sum of 2 or more consecutive
non-zero natural numbers.

Theorem. For any natural number  n \<noteq> 0, we have that n is a trapezoidal number if
and only if n is not a power of 2 (including 1).

References:

@article{gamer1985trapezoidal,
  title={Trapezoidal numbers},
  author={Gamer, Carlton and Roeder, David W and Watkins, John J},
  journal={Mathematics Magazine},
  volume={58},
  number={2},
  pages={108--110},
  year={1985},
  publisher={Taylor \& Francis}
}

(This code  was verified in Isabelle2018)

*)

theory TrapezoidalNumbers

imports Complex_Main PowOfTwo

begin

section {* Necessary Condition *}

primrec TSum :: "nat \<Rightarrow> nat  \<Rightarrow> nat" where
  "TSum a 0 = 0"
| "TSum a (Suc k) = (TSum a k) + (a + k)"

lemma TrapezoidalNumbersNec2_1: "(k::nat) \<ge> 1 \<Longrightarrow> odd k \<or> odd ((k::nat)+2*a-1)"
  by (meson dvd_diffD1 dvd_triv_left even_add le_add1 le_trans odd_one)

lemma TrapezoidalNumbersNec2A: "a \<ge> 1 \<and> (k::nat) \<ge> 2 \<and> odd k \<Longrightarrow> \<not> (\<exists> r. k*(k+2*a-1) = 2^r)"
  using TrapezoidalNumbersNec2_2 dvd_triv_left by blast

lemma TrapezoidalNumbersNec2B: "a \<ge> 1 \<and> (k::nat) \<ge> 2 \<and> odd (k+2*a-1) \<Longrightarrow> \<not> (\<exists> r. k*(k+2*a-1) = 2^r)"
  by (metis Nat.add_diff_assoc TrapezoidalNumbersNec2_2 dvd_triv_right mult_2 trans_le_add1)

lemma TrapezoidalNumbersNec2: "a \<ge> 1 \<and> (k::nat) \<ge> 2 \<Longrightarrow> \<not> (\<exists> r. k*(k+2*a-1) = 2^r)"
  by (metis TrapezoidalNumbersNec2A TrapezoidalNumbersNec2B TrapezoidalNumbersNec2_1 add_leD2 one_add_one)

lemma HDGFHFreal: "(k::real)*(k+2*a-1) + 2*(a + k) = (k+1)*((k+1)+2*a-1)"
  by (smt mult.commute semiring_normalization_rules(3))

lemma HDGFHF: "a \<ge> 1 \<Longrightarrow> (k::nat)*(k+2*a-1) + 2*(a + k) = (Suc k)*((Suc k)+2*a-1)"
proof (rule classical)
  obtain kk where "kk = real k" by simp
  obtain aa where "aa = real a" by simp
  assume "a \<ge> 1"
  assume "\<not> (k*(k+2*a-1) + 2*(a + k) = (Suc k)*((Suc k)+2*a-1))"
  hence "(k*(k+2*a-1) + 2*(a + k) \<noteq> (k+1)*((k+1)+2*a-1))" by simp
  hence "real  (k*(k+2*a-1) + 2*(a + k)) \<noteq> real ((k+1)*((k+1)+2*a-1))"
    using of_nat_eq_iff by blast
  hence  "(kk*(kk+2*aa-1) + 2*(aa + kk)) \<noteq> ((kk+1)*((kk+1)+2*aa-1))"
    using diff_mult_distrib2 by auto
  hence False
    using \<open>k * (k + 2 * a - 1) + 2 * (a + k) \<noteq> (k + 1) * (k + 1 + 2 * a - 1)\<close> diff_mult_distrib2 by auto
  thus ?thesis by blast
qed

lemma TrapezoidalNumbersNec1: "a \<ge> 1 \<Longrightarrow> 2*TSum a k =  k*(k+2*a-1)"
proof (induction k)
  case 0
  thus ?case by auto
next
  case (Suc k)
  hence "2*TSum a k + 2*(a + k) =  k*(k+2*a-1) + 2*(a + k)" by auto
  hence "2*(TSum a k + (a + k)) =  k*(k+2*a-1) + 2*(a + k)"
    by simp
  hence  "2*(TSum a (Suc k)) =  k*(k+2*a-1) + 2*(a + k)" by simp
  hence "2*(TSum a (Suc k)) =  (Suc k)*((Suc k)+2*a-1)"
    using HDGFHF \<open>a \<ge> 1\<close> by auto
  thus ?case
    by blast
qed

theorem TrapezoidalNumbersNec: "( \<exists> a k. a \<ge> 1 \<and> k \<ge> 2 \<and> n = (TSum a k) ) \<Longrightarrow> \<not> (\<exists> r. n = 2^r)"
proof-
  assume "\<exists> a k. a \<ge> 1 \<and> k \<ge> 2 \<and> n = (TSum a k)"
  then obtain a k where "a \<ge> 1" and "k \<ge> 2" and "n = (TSum a k)" by auto
  from \<open>n = (TSum a k)\<close> have \<open>2*n = k*(k+2*a-1)\<close>
    using TrapezoidalNumbersNec1 \<open>a \<ge> 1\<close> by blast
  have "\<not> (\<exists> r. 2*n = 2^r)"
    using TrapezoidalNumbersNec2 \<open>1 \<le> a\<close> \<open>2 * n = k * (k + 2 * a - 1)\<close> \<open>2 \<le> k\<close> by auto
  hence "\<not> (\<exists> r. n = 2^r)"  by (rule TrapezoidalNumbersNec3)
  thus ?thesis by blast
qed

section {* Sufficient Condition *}

lemma TrapezoidalNumbersSuf_1C_BOUNDED: "\<forall> N  n. (n \<le> (N::nat) \<longrightarrow> (n \<noteq> 0 \<longrightarrow>  ( \<exists> r t.  n = 2^r*t \<and> odd t ) ))"
  using TrapezoidalNumbersSuf_1C_BOUNDEDNonQ by blast

lemma TrapezoidalNumbersSuf_1C: "(n::nat) \<noteq> 0 \<longrightarrow> ( \<exists> r t.  n = 2^r*t \<and> odd t )"
  using TrapezoidalNumbersSuf_1C_BOUNDED by blast

lemma TrapezoidalNumbersSuf_1B: "n \<noteq> 0 \<Longrightarrow>  ( \<forall> d.  d dvd (n::nat) \<and> odd d \<longrightarrow> d = 1 )  \<Longrightarrow> (\<exists> r. n = 2^r)"
proof-
  assume \<open>n \<noteq> 0\<close>
  assume \<open>  \<forall> d.  d dvd (n::nat) \<and> odd d \<longrightarrow> d = 1 \<close>
  from \<open>n \<noteq> 0\<close> have \<open> \<exists> r t.  n = 2^r*t \<and> odd t \<close>
    using TrapezoidalNumbersSuf_1C by blast
  then obtain r t where \<open> n = 2^r*t \<close> and \<open>odd t\<close> by blast
  from \<open> n = 2^r*t \<close>  have \<open>t dvd n\<close>
    by simp
  from \<open> \<forall> d.  d dvd (n::nat) \<and> odd d \<longrightarrow> d = 1\<close> \<open>odd t\<close> \<open>t dvd n\<close>  have \<open>t = 1\<close>
    by blast
  from \<open> n = 2^r*t \<close> this have \<open>n = 2^r\<close>
    using nat_mult_1_right by blast
  hence \<open>\<exists> r. n = 2^r\<close> by blast
  thus ?thesis by blast
qed

lemma TrapezoidalNumbersSuf_1A: "n \<noteq> 0 \<Longrightarrow> (\<not> ( \<exists> d. d \<ge> 2 \<and> d dvd (n::nat) \<and> odd d ) \<longrightarrow> (\<exists> r. n = 2^r))"
  by (metis One_nat_def Suc_leI TrapezoidalNumbersSuf_1B dvd_1_left dvd_pos_nat gr0I linorder_neqE_nat  nat_dvd_not_less numeral_2_eq_2)

lemma TrapezoidalNumbersSuf_1: "n \<noteq> 0 \<Longrightarrow> (\<not> (\<exists> r. n = 2^r) \<longrightarrow> ( \<exists> d. d \<ge> 2 \<and> d dvd (n::nat) \<and> odd d) )"
  using TrapezoidalNumbersSuf_1A by blast

lemma TrapezoidalNumbersSuf_2A2: "n \<noteq> 0 \<Longrightarrow> \<exists> d. d \<ge> 2 \<and> d dvd (n::nat) \<and> odd d \<and> d^2 \<ge> 2*n \<Longrightarrow> ( \<exists> a k. a \<ge> 1 \<and> k \<ge> 2 \<and> 2*n = k*(k+2*a-1) )"
proof -
  assume \<open>n \<noteq> 0\<close>
  assume \<open>\<exists> d. d \<ge> 2 \<and> d dvd (n::nat) \<and> odd d \<and> d^2 \<ge> 2*n\<close>
  obtain d where \<open>d \<ge> 2\<close> and \<open>d dvd n\<close> and \<open>odd d\<close> and \<open>d^2 \<ge> 2*n\<close>
    using \<open>\<exists>d\<ge>2. d dvd n \<and> odd d \<and> 2 * n \<le> d\<^sup>2\<close> by blast
  obtain e where \<open>d*e = n\<close>
    using \<open>d dvd n\<close> dvd_mult_div_cancel by blast
  obtain k where \<open>k = 2*e\<close> by simp
  have \<open>d \<ge> k\<close>
    by (metis \<open>2 * n \<le> d\<^sup>2\<close> \<open>2 \<le> d\<close> \<open>d * e = n\<close> \<open>k = 2 * e\<close> less_le_trans mult.left_commute nat_mult_le_cancel_disj pos2 power2_eq_square)
  have \<open>even (d - k + 1)\<close>
    using \<open>k = 2 * e\<close> \<open>k \<le> d\<close> \<open>odd d\<close> by auto
  then   obtain a::nat where \<open> 2*a  = d - k + 1\<close>
    using  \<open>odd d\<close>  by (metis evenE)
  from \<open> 2*a  = d - k + 1\<close> \<open>k = 2 * e\<close>  \<open>d * e = n\<close> have \<open>k * (k + 2*a - 1) = 2*n\<close>
    by auto
  have \<open>a \<ge> 1\<close>
    using \<open>2 * a = d - k + 1\<close> by auto
  have \<open>e \<ge> 1\<close>
    using \<open>d * e = n\<close> \<open>n \<noteq> 0\<close> by auto
  from \<open>k = 2 * e\<close> have \<open>k \<ge> 2\<close>
    using \<open>1 \<le> e\<close> by linarith
  show ?thesis
    using \<open>1 \<le> a\<close> \<open>2 \<le> k\<close> \<open>k * (k + 2 * a - 1) = 2 * n\<close> by fastforce
qed

lemma TrapezoidalNumbersSuf_2A1: "n \<noteq> 0 \<Longrightarrow> \<exists> d. d \<ge> 2 \<and> d dvd (n::nat) \<and> odd d \<and> d^2 \<le> 2*n \<Longrightarrow> ( \<exists> a k. a \<ge> 1 \<and> k \<ge> 2 \<and> 2*n = k*(k+2*a-1) )"
proof -
  assume \<open>n \<noteq> 0\<close>
  assume \<open>\<exists> d. d \<ge> 2 \<and> d dvd (n::nat) \<and> odd d \<and> d^2 \<le> 2*n\<close>
  obtain d where \<open>d \<ge> 2\<close> and \<open>d dvd n\<close> and \<open>odd d\<close> and \<open>d^2 \<le> 2*n\<close>
    using \<open>\<exists>d\<ge>2. d dvd n \<and> odd d \<and> 2 * n \<ge> d\<^sup>2\<close> by blast
  obtain e where \<open>d*e = n\<close>
    using \<open>d dvd n\<close> dvd_mult_div_cancel by blast
  have \<open>d*(2*e) = 2*n\<close>
    using \<open>d * e = n\<close> mult.left_commute by blast
  from \<open>d*(2*e) = 2*n\<close> \<open>d^2 \<le> 2*n\<close>  have \<open>2*e \<ge> d\<close>
    by (metis \<open>2 \<le> d\<close> less_le_trans nat_mult_le_cancel_disj pos2 power2_eq_square)
  obtain k where \<open>k = d\<close>
    by simp
  have \<open>2*e  \<ge> k - 1 \<close>
    using \<open>d \<le> 2 * e\<close> \<open>k = d\<close> by linarith
  have \<open>even (2*e - k - 1)\<close>
    by (simp add: \<open>k = d\<close> \<open>odd d\<close>)
  obtain a where \<open>2*a = 2*e - k + 1\<close>
    by (metis One_nat_def Suc_leI \<open>d \<le> 2 * e\<close> \<open>even (2 * e - k - 1)\<close> \<open>k = d\<close> \<open>odd d\<close> dvdE dvd_triv_left even_diff_nat le_neq_implies_less linorder_not_le zero_less_diff)
  have \<open>k \<ge> 2\<close>
    by (simp add: \<open>2 \<le> d\<close> \<open>k = d\<close>)
  have \<open>a \<ge> 1\<close>
    using \<open>2 * a = 2 * e - k + 1\<close> by auto
  have \<open>k * (k + 2*a - 1) = 2*n\<close>
    by (simp add: \<open>2 * a = 2 * e - k + 1\<close> \<open>d * (2 * e) = 2 * n\<close> \<open>d \<le> 2 * e\<close> \<open>k = d\<close>)
  show ?thesis
    using \<open>1 \<le> a\<close> \<open>2 \<le> d\<close> \<open>k * (k + 2 * a - 1) = 2 * n\<close> \<open>k = d\<close> by fastforce
qed

lemma TrapezoidalNumbersSuf_2A: "n \<noteq> 0 \<Longrightarrow> \<exists> d. d \<ge> 2 \<and> d dvd (n::nat) \<and> odd d \<Longrightarrow> ( \<exists> a k. a \<ge> 1 \<and> k \<ge> 2 \<and> 2*n = k*(k+2*a-1) )"
  by (metis TrapezoidalNumbersSuf_2A1 TrapezoidalNumbersSuf_2A2 nat_le_linear)

lemma TrapezoidalNumbersSuf_2: "n \<noteq> 0 \<Longrightarrow> \<exists> d. d \<ge> 2 \<and> d dvd (n::nat) \<and> odd d \<Longrightarrow> ( \<exists> a k. a \<ge> 1 \<and> k \<ge> 2 \<and> n = (TSum a k) )"
  by (metis Suc_mult_cancel1 TrapezoidalNumbersNec1 TrapezoidalNumbersSuf_2A numeral_2_eq_2)

theorem TrapezoidalNumbersSuf: "n \<noteq> 0 \<Longrightarrow>  \<not> (\<exists> r. n = 2^r) \<Longrightarrow> ( \<exists> a k. a \<ge> 1 \<and> k \<ge> 2 \<and> n = (TSum a k) )"
  using TrapezoidalNumbersSuf_1 TrapezoidalNumbersSuf_2 by blast

section {* Main result *}

theorem TrapezoidalNumbers: "n \<noteq> 0 \<Longrightarrow>  ( \<exists> a k. a \<ge> 1 \<and> k \<ge> 2 \<and> n = (TSum a k) ) \<longleftrightarrow>  \<not> (\<exists> r. n = 2^r)"
  using TrapezoidalNumbersNec TrapezoidalNumbersSuf by blast

end


(*  Title:      Containers/Card_Datatype.thy
    Author:     Andreas Lochbihler, ETH Zurich *)

theory Card_Datatype
imports "HOL-Library.Cardinality"
begin

section \<open>Definitions to prove equations about the cardinality of data types\<close>

subsection \<open>Specialised @{term range} constants\<close>

definition rangeIt :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a set"
where "rangeIt x f = range (\<lambda>n. (f ^^ n) x)"

definition rangeC :: "('a \<Rightarrow> 'b) set \<Rightarrow> 'b set"
where "rangeC F = (\<Union>f \<in> F. range f)"

lemma infinite_rangeIt:
  assumes inj: "inj f"
  and x: "\<forall>y. x \<noteq> f y"
  shows "\<not> finite (rangeIt x f)"
proof -
  have "inj (\<lambda>n. (f ^^ n) x)"
  proof(rule injI)
    fix n m
    assume "(f ^^ n) x = (f ^^ m) x"
    thus "n = m"
    proof(induct n arbitrary: m)
      case 0
      thus ?case using x by(cases m)(auto intro: sym)
    next
      case (Suc n)
      thus ?case using x by(cases m)(auto intro: sym dest: injD[OF inj])
    qed
  qed
  thus ?thesis
    by(auto simp add: rangeIt_def dest: finite_imageD)
qed

lemma in_rangeC: "f \<in> A \<Longrightarrow> f x \<in> rangeC A"
by(auto simp add: rangeC_def)

lemma in_rangeCE: assumes "y \<in> rangeC A"
  obtains f x where "f \<in> A" "y = f x"
using assms by(auto simp add: rangeC_def)

lemma in_rangeC_singleton: "f x \<in> rangeC {f}"
by(auto simp add: rangeC_def)

lemma in_rangeC_singleton_const: "x \<in> rangeC {\<lambda>_. x}"
by(rule in_rangeC_singleton)

lemma rangeC_rangeC: "f \<in> rangeC A \<Longrightarrow> f x \<in> rangeC (rangeC A)"
by(auto simp add: rangeC_def)

lemma rangeC_eq_empty: "rangeC A = {} \<longleftrightarrow> A = {}"
by(auto simp add: rangeC_def)

lemma Ball_rangeC_iff:
  "(\<forall>x \<in> rangeC A. P x) \<longleftrightarrow> (\<forall>f \<in> A. \<forall>x. P (f x))"
by(auto intro: in_rangeC elim: in_rangeCE)

lemma Ball_rangeC_singleton:
  "(\<forall>x \<in> rangeC {f}. P x) \<longleftrightarrow> (\<forall>x. P (f x))"
by(simp add: Ball_rangeC_iff)

lemma Ball_rangeC_rangeC:
  "(\<forall>x \<in> rangeC (rangeC A). P x) \<longleftrightarrow> (\<forall>f \<in> rangeC A. \<forall>x. P (f x))"
by(simp add: Ball_rangeC_iff)

lemma finite_rangeC:
  assumes inj: "\<forall>f \<in> A. inj f"
  and disjoint: "\<forall>f \<in> A. \<forall>g \<in> A. f \<noteq> g \<longrightarrow> (\<forall>x y. f x \<noteq> g y)"
  shows "finite (rangeC (A :: ('a \<Rightarrow> 'b) set)) \<longleftrightarrow> finite A \<and> (A \<noteq> {} \<longrightarrow> finite (UNIV :: 'a set))"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  thus ?rhs using inj disjoint
  proof(induct "rangeC A" arbitrary: A rule: finite_psubset_induct)
    case (psubset A)
    show ?case
    proof(cases "A = {}")
      case True thus ?thesis by simp
    next
      case False
      then obtain f A' where A: "A = insert f A'" and f: "f \<in> A" "f \<notin> A'"
        by(fastforce dest: mk_disjoint_insert)
      from A have rA: "rangeC A = rangeC A' \<union> range f"
        by(auto simp add: rangeC_def)

      have "\<not> range f \<subseteq> rangeC A'"
      proof
        assume "range f \<subseteq> rangeC A'"
        moreover obtain x where x: "x \<in> range f" by auto
        ultimately have "x \<in> rangeC A'" by auto
        then obtain g where "g \<in> A'" "x \<in> range g" by(auto simp add: rangeC_def)
        with \<open>f \<notin> A'\<close> A have "g \<in> A" "f \<noteq> g" by auto
        with \<open>f \<in> A\<close> have "\<And>x y. f x \<noteq> g y" by(rule psubset.prems[rule_format])
        thus False using x \<open>x \<in> range g\<close> by auto
      qed
      hence "rangeC A' \<subset> rangeC A" unfolding rA by auto
      hence "finite A' \<and> (A' \<noteq> {} \<longrightarrow> finite (UNIV :: 'a set))"
        using psubset.prems
        by -(erule psubset.hyps, auto simp add: A)
      with A have "finite A" by simp
      moreover with \<open>finite (rangeC A)\<close> A \<open>\<forall>f \<in> A. inj f\<close>
      have "finite (UNIV :: 'a set)"
        by(auto simp add: rangeC_def dest: finite_imageD)
      ultimately show ?thesis by blast
    qed
  qed
qed(auto simp add: rangeC_def)

lemma finite_rangeC_singleton_const:
  "finite (rangeC {\<lambda>_. x})"
by(auto simp add: rangeC_def image_def)

lemma card_Un:
  "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> card (A \<union> B) = card (A) + card (B) - card(A \<inter> B)"
by(subst card_Un_Int) simp_all

lemma card_rangeC_singleton_const:
  "card (rangeC {\<lambda>_. f}) = 1"
by(simp add: rangeC_def image_def)

lemma card_rangeC:
  assumes inj: "\<forall>f \<in> A. inj f"
  and disjoint: "\<forall>f \<in> A. \<forall>g \<in> A. f \<noteq> g \<longrightarrow> (\<forall>x y. f x \<noteq> g y)"
  shows "card (rangeC (A :: ('a \<Rightarrow> 'b) set)) = CARD('a) * card A"
  (is "?lhs = ?rhs")
proof(cases "finite (UNIV :: 'a set) \<and> finite A")
  case False
  thus ?thesis using False finite_rangeC[OF assms]
    by(auto simp add: card_eq_0_iff rangeC_eq_empty)
next
  case True
  { fix f
    assume "f \<in> A"
    hence "card (range f) = CARD('a)" using inj by(simp add: card_image) }
  thus ?thesis using disjoint True unfolding rangeC_def
    by(subst card_UN_disjoint) auto
qed

lemma rangeC_Int_rangeC:
  "\<lbrakk> \<forall>f \<in> A. \<forall>g \<in> B. \<forall>x y. f x \<noteq> g y \<rbrakk> \<Longrightarrow> rangeC A \<inter> rangeC B = {}"
by(auto simp add: rangeC_def)

lemmas rangeC_simps =
  in_rangeC_singleton
  in_rangeC_singleton_const
  rangeC_rangeC
  rangeC_eq_empty
  Ball_rangeC_singleton
  Ball_rangeC_rangeC
  finite_rangeC
  finite_rangeC_singleton_const
  card_rangeC_singleton_const
  card_rangeC
  rangeC_Int_rangeC

bundle card_datatype =
  rangeC_simps [simp]
  card_Un [simp]
  fun_eq_iff [simp]
  Int_Un_distrib [simp]
  Int_Un_distrib2 [simp]
  card_eq_0_iff [simp]
  imageI [simp] image_eqI [simp del]
  conj_cong [cong]
  infinite_rangeIt [simp]

subsection \<open>Cardinality primitives for polymorphic HOL types\<close>

ML \<open>
structure Card_Simp_Rules = Named_Thms
(
  val name = @{binding card_simps}
  val description = "Simplification rules for cardinality of types"
)
\<close>
setup \<open>Card_Simp_Rules.setup\<close>

definition card_fun :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where "card_fun a b = (if a \<noteq> 0 \<and> b \<noteq> 0 \<or> b = 1 then b ^ a else 0)"

lemma CARD_fun [card_simps]:
  "CARD('a \<Rightarrow> 'b) = card_fun CARD('a) CARD('b)"
by(simp add: card_fun card_fun_def)

definition card_sum :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where "card_sum a b = (if a = 0 \<or> b = 0 then 0 else a + b)"

lemma CARD_sum [card_simps]:
  "CARD('a + 'b) = card_sum CARD('a) CARD('b)"
by(simp add: card_UNIV_sum card_sum_def)

definition card_option :: "nat \<Rightarrow> nat"
where "card_option n = (if n = 0 then 0 else Suc n)"

lemma CARD_option [card_simps]:
  "CARD('a option) = card_option CARD('a)"
by(simp add: card_option_def card_UNIV_option)

definition card_prod :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where "card_prod a b = a * b"

lemma CARD_prod [card_simps]:
  "CARD('a * 'b) = card_prod CARD('a) CARD('b)"
by(simp add: card_prod_def)

definition card_list :: "nat \<Rightarrow> nat"
where "card_list _ = 0"

lemma CARD_list [card_simps]: "CARD('a list) = card_list CARD('a)"
by(simp add: card_list_def infinite_UNIV_listI)

end