(*
  Author:   Benedikt Seidl
  License:  GPL-3.0-or-later
*)

theory Graph
  imports Main
begin

type_synonym 'a graph = "'a set \<times> 'a set set"

locale graph =
  fixes
    G :: "'a graph"
  fixes
    V :: "'a set"
  fixes
    E :: "'a set set"
  defines
    "V \<equiv> fst G"
  defines
    "E \<equiv> snd G"
  assumes
    finite_vertices: "finite V"
  assumes
    nonempty_vertices: "V \<noteq> {}"
  assumes
    edges: "E \<subseteq> {e. e \<subseteq> V \<and> card e = 2}"
begin

lemma finite_edges: "finite E"
proof -
  from finite_vertices have "finite {e. e \<subseteq> V}"
    by fast
  hence "finite {e. e \<subseteq> V \<and> card e = 2}"
    by fast
  with edges show "finite E"
    by (rule Finite_Set.finite_subset)
qed

lemma edge_vertices: "e \<in> E \<Longrightarrow> \<exists>v w. e = {v, w}"
proof -
  fix e assume "e \<in> E"

  then have "card e = Suc (Suc 0)" using edges by auto

  then obtain v e' where "e = insert v e'" and "card e' = Suc 0"
    using card_eq_SucD by metis

  then show "\<exists>v w. e = {v, w}"
    using card_eq_SucD
    by blast
qed

subsection \<open>Adjacency and Neighborhood\<close>

definition adjacent :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "adjacent v w \<equiv> {v, w} \<in> E"

definition neighborhood :: "'a \<Rightarrow> 'a set" where
  "neighborhood v \<equiv> {w \<in> V. {v, w} \<in> E}"

definition deg :: "'a \<Rightarrow> nat" where
  "deg v \<equiv> card {e \<in> E. v \<in> e}"

definition isolated :: "'a \<Rightarrow> bool" where
  "isolated v \<equiv> deg v = 0"

definition leaf :: "'a \<Rightarrow> bool" where
  "leaf v \<equiv> deg v = 1"

definition \<delta> :: nat where
  "\<delta> \<equiv> Min {deg v | v. v \<in> V}"

definition \<Delta> :: nat where
  "\<Delta> \<equiv> Max {deg v | v. v \<in> V}"

lemma adjacent_comm: "adjacent v w \<longleftrightarrow> adjacent w v"
proof -
  have "{v, w} = {w, v}"
    by fast
  thus "adjacent v w \<longleftrightarrow> adjacent w v"
    unfolding adjacent_def by simp
qed

lemma deg_card_neighborhood: "deg v = card (neighborhood v)"
proof -

  define f :: "'a \<Rightarrow> 'a set" where "f \<equiv> \<lambda>w. {v, w}"

  have "bij_betw f {w \<in> V. {v, w} \<in> E} {e \<in> E. v \<in> e}"
    unfolding bij_betw_def
  proof
    show "inj_on f {w \<in> V. {v, w} \<in> E}"
      unfolding inj_on_def f_def
      by (simp add: doubleton_eq_iff)
  next
    show "f ` {w \<in> V. {v, w} \<in> E} = {e \<in> E. v \<in> e}"
      unfolding f_def image_def
    proof auto
      fix e
      assume "e \<in> E" and "v \<in> e"

      then obtain w where "e = {v, w}"
        using edge_vertices by blast

      then show "\<exists>w. w \<in> V \<and> {v, w} \<in> E \<and> e = {v, w}"
        using edges \<open>e \<in> E\<close> by blast
    qed
  qed

  then have "card {w \<in> V. {v, w} \<in> E} = card {e \<in> E. v \<in> e}"
    using bij_betw_same_card by auto

  then show ?thesis
    unfolding deg_def neighborhood_def by simp
qed

lemma sum_deg: "(\<Sum>v \<in> V. deg v) = 2 * card E"
  oops

lemma even_edges_odd: "even (card {v \<in> V. odd (deg v)})"
  oops

lemma same_deg: "card V \<ge> 2 \<Longrightarrow> \<exists>v \<in> V. \<exists>w \<in> V. v \<noteq> w \<and> deg v = deg w"
  oops

subsection \<open>Subgraphs and Isomorphism\<close>

definition subgraph :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
  "subgraph W F \<equiv> graph (W, F) \<and> W \<subseteq> V \<and> F \<subseteq> E"

definition induced_subgraph :: "'a set \<Rightarrow> 'a set \<times> 'a set set" where
  "induced_subgraph W \<equiv> (V \<inter> W, {e \<in> E. e \<subseteq> W})"

definition isomorphic :: "'b set \<Rightarrow> 'b set set \<Rightarrow> bool" where
  "isomorphic W F \<equiv> graph (W, F) \<and> (\<exists>f. \<forall>v \<in> V. \<forall>w \<in> V. {v, w} \<in> E \<longleftrightarrow> {f v, f w} \<in> F)"

end

subsection \<open>Notation\<close>

abbreviation supgraph :: "'a graph \<Rightarrow> 'a graph \<Rightarrow> bool" (infix "\<subseteq>\<^sub>G" 50) where
  "G \<subseteq>\<^sub>G H \<equiv> graph.subgraph H (fst G) (snd G)"

abbreviation induced_subgraph :: "'a graph \<Rightarrow> 'a set \<Rightarrow> 'a graph" ("_[_](\<^sub>G)" 51) where
  "G[V]\<^sub>G \<equiv> graph.induced_subgraph G V"

abbreviation isomorphic :: "'a graph \<Rightarrow> 'b graph \<Rightarrow> bool" (infix "\<sim>\<^sub>G" 50) where
  "G \<sim>\<^sub>G H \<equiv> graph.isomorphic G (fst H) (snd H)"

lemma "G[V]\<^sub>G \<subseteq>\<^sub>G G"
  oops

lemma isomorphic_comm: "G \<sim>\<^sub>G H \<longleftrightarrow> H \<sim>\<^sub>G G"
  oops

lemma isomorphic_card:
  assumes
    "graph (V, E)"
  assumes
    "graph (W, F)"
  assumes
    "(V, E) \<sim>\<^sub>G (W, F)"
  shows
    "card V = card W" and "card E = card F"
proof -
  show "card V = card W" sorry
next
  show "card E = card F" sorry
qed

subsection \<open>Special graphs\<close>

definition path :: "nat \<Rightarrow> nat graph" ("P\<^sub>G _" 1) where
  "path n = ({1..n}, {{i, i + 1} | i. i \<in> {1..n-1}})"

definition circle :: "nat \<Rightarrow> nat graph" ("C\<^sub>G _") where
  "circle n \<equiv> ({1..n}, {{i, i + 1} | i. i \<in> {1..n-1}} \<union> {{1, n}})"

definition complete :: "nat \<Rightarrow> nat graph" ("K\<^sub>G _") where
  "complete n = ({1..n}, {{v, w} | v w. v \<in> {1..n} \<and> w \<in> {1..n} \<and> v \<noteq> w})"

lemma[simp]: "graph (C\<^sub>G n)"
  sorry

lemma[simp]: "graph (K\<^sub>G n)"
  sorry

lemma empty_edges[simp]: "finite V \<Longrightarrow> V \<noteq> {} \<Longrightarrow> graph (V, {})"
  unfolding graph_def by simp

context graph
begin

definition path :: bool where
  "path \<equiv> \<exists>n. G \<sim>\<^sub>G (P\<^sub>G n)"

definition circle :: bool where
  "circle \<equiv> \<exists>n \<ge> 3. G \<sim>\<^sub>G (C\<^sub>G n)"

definition complete :: bool where
  "complete \<equiv> \<exists>n. G \<sim>\<^sub>G (K\<^sub>G n)"

definition acyclic :: bool where
  "acyclic \<equiv> \<forall>H. H \<subseteq>\<^sub>G G \<longrightarrow> \<not> graph.circle H"

definition connected :: bool where
  "connected \<equiv> undefined"

definition tree :: bool where
  "tree \<equiv> acyclic \<and> connected"

definition spanning_tree :: "'a graph \<Rightarrow> bool" where
  "spanning_tree T \<equiv> T \<subseteq>\<^sub>G G \<and> graph.tree T \<and> V = fst T"

lemma connected_spanning_tree: "connected \<longleftrightarrow> (\<exists>T. spanning_tree T)"
  oops

end

end


(* Author: Florian Haftmann, TU Muenchen *)

section {* Comparing growth of functions on natural numbers by a preorder relation *}

theory Function_Growth
imports Main Preorder Discrete
begin

subsection {* Motivation *}

text {*
  When comparing growth of functions in computer science, it is common to adhere
  on Landau Symbols (``O-Notation'').  However these come at the cost of notational
  oddities, particularly writing @{text "f = O(g)"} for @{text "f \<in> O(g)"} etc.

  Here we suggest a different way, following Hardy (G.~H.~Hardy and J.~E.~Littlewood,
  Some problems of Diophantine approximation, Acta Mathematica 37 (1914), p.~225).
  We establish a quasi order relation @{text "\<lesssim>"} on functions such that
  @{text "f \<lesssim> g \<longleftrightarrow> f \<in> O(g)"}.  From a didactic point of view, this does not only
  avoid the notational oddities mentioned above but also emphasizes the key insight
  of a growth hierarchy of functions:
  @{text "(\<lambda>n. 0) \<lesssim> (\<lambda>n. k) \<lesssim> Discrete.log \<lesssim> Discrete.sqrt \<lesssim> id \<lesssim> \<dots>"}.
*}

subsection {* Model *}

text {*
  Our growth functions are of type @{text "\<nat> \<Rightarrow> \<nat>"}.  This is different
  to the usual conventions for Landau symbols for which @{text "\<real> \<Rightarrow> \<real>"}
  would be appropriate, but we argue that @{text "\<real> \<Rightarrow> \<real>"} is more
  appropriate for analysis, whereas our setting is discrete.

  Note that we also restrict the additional coefficients to @{text \<nat>}, something
  we discuss at the particular definitions.
*}

subsection {* The @{text "\<lesssim>"} relation *}

definition less_eq_fun :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" (infix "\<lesssim>" 50)
where
  "f \<lesssim> g \<longleftrightarrow> (\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * g m)"

text {*
  This yields @{text "f \<lesssim> g \<longleftrightarrow> f \<in> O(g)"}.  Note that @{text c} is restricted to
  @{text \<nat>}.  This does not pose any problems since if @{text "f \<in> O(g)"} holds for
  a @{text "c \<in> \<real>"}, it also holds for @{text "\<lceil>c\<rceil> \<in> \<nat>"} by transitivity.
*}

lemma less_eq_funI [intro?]:
  assumes "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * g m"
  shows "f \<lesssim> g"
  unfolding less_eq_fun_def by (rule assms)

lemma not_less_eq_funI:
  assumes "\<And>c n. c > 0 \<Longrightarrow> \<exists>m>n. c * g m < f m"
  shows "\<not> f \<lesssim> g"
  using assms unfolding less_eq_fun_def linorder_not_le [symmetric] by blast

lemma less_eq_funE [elim?]:
  assumes "f \<lesssim> g"
  obtains n c where "c > 0" and "\<And>m. m > n \<Longrightarrow> f m \<le> c * g m"
  using assms unfolding less_eq_fun_def by blast

lemma not_less_eq_funE:
  assumes "\<not> f \<lesssim> g" and "c > 0"
  obtains m where "m > n" and "c * g m < f m"
  using assms unfolding less_eq_fun_def linorder_not_le [symmetric] by blast

subsection {* The @{text "\<approx>"} relation, the equivalence relation induced by @{text "\<lesssim>"} *}

definition equiv_fun :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" (infix "\<cong>" 50)
where
  "f \<cong> g \<longleftrightarrow>
    (\<exists>c\<^sub>1>0. \<exists>c\<^sub>2>0. \<exists>n. \<forall>m>n. f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m)"

text {*
  This yields @{text "f \<cong> g \<longleftrightarrow> f \<in> \<Theta>(g)"}.  Concerning @{text "c\<^sub>1"} and @{text "c\<^sub>2"}
  restricted to @{typ nat}, see note above on @{text "(\<lesssim>)"}.
*}

lemma equiv_funI [intro?]:
  assumes "\<exists>c\<^sub>1>0. \<exists>c\<^sub>2>0. \<exists>n. \<forall>m>n. f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m"
  shows "f \<cong> g"
  unfolding equiv_fun_def by (rule assms)

lemma not_equiv_funI:
  assumes "\<And>c\<^sub>1 c\<^sub>2 n. c\<^sub>1 > 0 \<Longrightarrow> c\<^sub>2 > 0 \<Longrightarrow>
    \<exists>m>n. c\<^sub>1 * f m < g m \<or> c\<^sub>2 * g m < f m"
  shows "\<not> f \<cong> g"
  using assms unfolding equiv_fun_def linorder_not_le [symmetric] by blast

lemma equiv_funE [elim?]:
  assumes "f \<cong> g"
  obtains n c\<^sub>1 c\<^sub>2 where "c\<^sub>1 > 0" and "c\<^sub>2 > 0"
    and "\<And>m. m > n \<Longrightarrow> f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m"
  using assms unfolding equiv_fun_def by blast

lemma not_equiv_funE:
  fixes n c\<^sub>1 c\<^sub>2
  assumes "\<not> f \<cong> g" and "c\<^sub>1 > 0" and "c\<^sub>2 > 0"
  obtains m where "m > n"
    and "c\<^sub>1 * f m < g m \<or> c\<^sub>2 * g m < f m"
  using assms unfolding equiv_fun_def linorder_not_le [symmetric] by blast

subsection {* The @{text "\<prec>"} relation, the strict part of @{text "\<lesssim>"} *}

definition less_fun :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" (infix "\<prec>" 50)
where
  "f \<prec> g \<longleftrightarrow> f \<lesssim> g \<and> \<not> g \<lesssim> f"

lemma less_funI:
  assumes "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * g m"
    and "\<And>c n. c > 0 \<Longrightarrow> \<exists>m>n. c * f m < g m"
  shows "f \<prec> g"
  using assms unfolding less_fun_def less_eq_fun_def linorder_not_less [symmetric] by blast

lemma not_less_funI:
  assumes "\<And>c n. c > 0 \<Longrightarrow> \<exists>m>n. c * g m < f m"
    and "\<exists>c>0. \<exists>n. \<forall>m>n. g m \<le> c * f m"
  shows "\<not> f \<prec> g"
  using assms unfolding less_fun_def less_eq_fun_def linorder_not_less [symmetric] by blast

lemma less_funE [elim?]:
  assumes "f \<prec> g"
  obtains n c where "c > 0" and "\<And>m. m > n \<Longrightarrow> f m \<le> c * g m"
    and "\<And>c n. c > 0 \<Longrightarrow> \<exists>m>n. c * f m < g m"
proof -
  from assms have "f \<lesssim> g" and "\<not> g \<lesssim> f" by (simp_all add: less_fun_def)
  from `f \<lesssim> g` obtain n c where *:"c > 0" "\<And>m. m > n \<Longrightarrow> f m \<le> c * g m"
    by (rule less_eq_funE) blast
  { fix c n :: nat
    assume "c > 0"
    with `\<not> g \<lesssim> f` obtain m where "m > n" "c * f m < g m"
      by (rule not_less_eq_funE) blast
    then have **: "\<exists>m>n. c * f m < g m" by blast
  } note ** = this
  from * ** show thesis by (rule that)
qed

lemma not_less_funE:
  assumes "\<not> f \<prec> g" and "c > 0"
  obtains m where "m > n" and "c * g m < f m"
    | d q where "\<And>m. d > 0 \<Longrightarrow> m > q \<Longrightarrow> g q \<le> d * f q"
  using assms unfolding less_fun_def linorder_not_less [symmetric] by blast

text {*
  I did not find a proof for @{text "f \<prec> g \<longleftrightarrow> f \<in> o(g)"}.  Maybe this only
  holds if @{text f} and/or @{text g} are of a certain class of functions.
  However @{text "f \<in> o(g) \<longrightarrow> f \<prec> g"} is provable, and this yields a
  handy introduction rule.

  Note that D. Knuth ignores @{text o} altogether.  So what \dots

  Something still has to be said about the coefficient @{text c} in
  the definition of @{text "(\<prec>)"}.  In the typical definition of @{text o},
  it occurs on the \emph{right} hand side of the @{text "(>)"}.  The reason
  is that the situation is dual to the definition of @{text O}: the definition
  works since @{text c} may become arbitrary small.  Since this is not possible
  within @{term \<nat>}, we push the coefficient to the left hand side instead such
  that it become arbitrary big instead.
*}

lemma less_fun_strongI:
  assumes "\<And>c. c > 0 \<Longrightarrow> \<exists>n. \<forall>m>n. c * f m < g m"
  shows "f \<prec> g"
proof (rule less_funI)
  have "1 > (0::nat)" by simp
  from assms `1 > 0` have "\<exists>n. \<forall>m>n. 1 * f m < g m" .
  then obtain n where *: "\<And>m. m > n \<Longrightarrow> 1 * f m < g m" by blast
  have "\<forall>m>n. f m \<le> 1 * g m"
  proof (rule allI, rule impI)
    fix m
    assume "m > n"
    with * have "1 * f m < g m" by simp
    then show "f m \<le> 1 * g m" by simp
  qed
  with `1 > 0` show "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * g m" by blast
  fix c n :: nat
  assume "c > 0"
  with assms obtain q where "\<And>m. m > q \<Longrightarrow> c * f m < g m" by blast
  then have "c * f (Suc (q + n)) < g (Suc (q + n))" by simp
  moreover have "Suc (q + n) > n" by simp
  ultimately show "\<exists>m>n. c * f m < g m" by blast
qed

subsection {* @{text "\<lesssim>"} is a preorder *}

text {* This yields all lemmas relating @{text "\<lesssim>"}, @{text "\<prec>"} and @{text "\<cong>"}. *}

interpretation fun_order: preorder_equiv less_eq_fun less_fun
  where "preorder_equiv.equiv less_eq_fun = equiv_fun"
proof -
  interpret preorder: preorder_equiv less_eq_fun less_fun
  proof
    fix f g h
    show "f \<lesssim> f"
    proof
      have "\<exists>n. \<forall>m>n. f m \<le> 1 * f m" by auto
      then show "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * f m" by blast
    qed
    show "f \<prec> g \<longleftrightarrow> f \<lesssim> g \<and> \<not> g \<lesssim> f"
      by (fact less_fun_def)
    assume "f \<lesssim> g" and "g \<lesssim> h"
    show "f \<lesssim> h"
    proof
      from `f \<lesssim> g` obtain n\<^sub>1 c\<^sub>1
        where "c\<^sub>1 > 0" and P\<^sub>1: "\<And>m. m > n\<^sub>1 \<Longrightarrow> f m \<le> c\<^sub>1 * g m"
        by rule blast
      from `g \<lesssim> h` obtain n\<^sub>2 c\<^sub>2
        where "c\<^sub>2 > 0" and P\<^sub>2: "\<And>m. m > n\<^sub>2 \<Longrightarrow> g m \<le> c\<^sub>2 * h m"
        by rule blast
      have "\<forall>m>max n\<^sub>1 n\<^sub>2. f m \<le> (c\<^sub>1 * c\<^sub>2) * h m"
      proof (rule allI, rule impI)
        fix m
        assume Q: "m > max n\<^sub>1 n\<^sub>2"
        from P\<^sub>1 Q have *: "f m \<le> c\<^sub>1 * g m" by simp
        from P\<^sub>2 Q have "g m \<le> c\<^sub>2 * h m" by simp
        with `c\<^sub>1 > 0` have "c\<^sub>1 * g m \<le> (c\<^sub>1 * c\<^sub>2) * h m" by simp
        with * show "f m \<le> (c\<^sub>1 * c\<^sub>2) * h m" by (rule order_trans)
      qed
      then have "\<exists>n. \<forall>m>n. f m \<le> (c\<^sub>1 * c\<^sub>2) * h m" by rule
      moreover from `c\<^sub>1 > 0` `c\<^sub>2 > 0` have "c\<^sub>1 * c\<^sub>2 > 0" by simp
      ultimately show "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * h m" by blast
    qed
  qed
  from preorder.preorder_equiv_axioms show "class.preorder_equiv less_eq_fun less_fun" .
  show "preorder_equiv.equiv less_eq_fun = equiv_fun"
  proof (rule ext, rule ext, unfold preorder.equiv_def)
    fix f g
    show "f \<lesssim> g \<and> g \<lesssim> f \<longleftrightarrow> f \<cong> g"
    proof
      assume "f \<cong> g"
      then obtain n c\<^sub>1 c\<^sub>2 where "c\<^sub>1 > 0" and "c\<^sub>2 > 0"
        and *: "\<And>m. m > n \<Longrightarrow> f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m"
        by rule blast
      have "\<forall>m>n. f m \<le> c\<^sub>1 * g m"
      proof (rule allI, rule impI)
        fix m
        assume "m > n"
        with * show "f m \<le> c\<^sub>1 * g m" by simp
      qed
      with `c\<^sub>1 > 0` have "\<exists>c>0. \<exists>n. \<forall>m>n. f m \<le> c * g m" by blast
      then have "f \<lesssim> g" ..
      have "\<forall>m>n. g m \<le> c\<^sub>2 * f m"
      proof (rule allI, rule impI)
        fix m
        assume "m > n"
        with * show "g m \<le> c\<^sub>2 * f m" by simp
      qed
      with `c\<^sub>2 > 0` have "\<exists>c>0. \<exists>n. \<forall>m>n. g m \<le> c * f m" by blast
      then have "g \<lesssim> f" ..
      from `f \<lesssim> g` and `g \<lesssim> f` show "f \<lesssim> g \<and> g \<lesssim> f" ..
    next
      assume "f \<lesssim> g \<and> g \<lesssim> f"
      then have "f \<lesssim> g" and "g \<lesssim> f" by auto
      from `f \<lesssim> g` obtain n\<^sub>1 c\<^sub>1 where "c\<^sub>1 > 0"
        and P\<^sub>1: "\<And>m. m > n\<^sub>1 \<Longrightarrow> f m \<le> c\<^sub>1 * g m" by rule blast
      from `g \<lesssim> f` obtain n\<^sub>2 c\<^sub>2 where "c\<^sub>2 > 0"
        and P\<^sub>2: "\<And>m. m > n\<^sub>2 \<Longrightarrow> g m \<le> c\<^sub>2 * f m" by rule blast
      have "\<forall>m>max n\<^sub>1 n\<^sub>2. f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m"
      proof (rule allI, rule impI)
        fix m
        assume Q: "m > max n\<^sub>1 n\<^sub>2"
        from P\<^sub>1 Q have "f m \<le> c\<^sub>1 * g m" by simp
        moreover from P\<^sub>2 Q have "g m \<le> c\<^sub>2 * f m" by simp
        ultimately show "f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m" ..
      qed
      with `c\<^sub>1 > 0` `c\<^sub>2 > 0` have "\<exists>c\<^sub>1>0. \<exists>c\<^sub>2>0. \<exists>n.
        \<forall>m>n. f m \<le> c\<^sub>1 * g m \<and> g m \<le> c\<^sub>2 * f m" by blast
      then show "f \<cong> g" ..
    qed
  qed
qed

subsection {* Simple examples *}

text {*
  Most of these are left as constructive exercises for the reader.  Note that additional
  preconditions to the functions may be necessary.  The list here is by no means to be
  intended as complete construction set for typical functions, here surely something
  has to be added yet.
*}

text {* @{prop "(\<lambda>n. f n + k) \<cong> f"} *}

text {* @{prop "(\<lambda>n. Suc k * f n) \<cong> f"} *}

lemma "f \<lesssim> (\<lambda>n. f n + g n)"
  by rule auto

lemma "(\<lambda>_. 0) \<prec> (\<lambda>n. Suc k)"
  by (rule less_fun_strongI) auto

lemma "(\<lambda>_. k) \<prec> Discrete.log"
proof (rule less_fun_strongI)
  fix c :: nat
  have "\<forall>m>2 ^ (Suc (c * k)). c * k < Discrete.log m"
  proof (rule allI, rule impI)
    fix m :: nat
    assume "2 ^ Suc (c * k) < m"
    then have "2 ^ Suc (c * k) \<le> m" by simp
    with log_mono have "Discrete.log (2 ^ (Suc (c * k))) \<le> Discrete.log m"
      by (blast dest: monoD)
    moreover have "c * k < Discrete.log (2 ^ (Suc (c * k)))" by simp
    ultimately show "c * k < Discrete.log m" by auto
  qed
  then show "\<exists>n. \<forall>m>n. c * k < Discrete.log m" ..
qed

text {* @{prop "Discrete.log \<prec> Discrete.sqrt"} *}

lemma "Discrete.sqrt \<prec> id"
proof (rule less_fun_strongI)
  fix c :: nat
  assume "0 < c"
  have "\<forall>m>(Suc c)\<^sup>2. c * Discrete.sqrt m < id m"
  proof (rule allI, rule impI)
    fix m
    assume "(Suc c)\<^sup>2 < m"
    then have "(Suc c)\<^sup>2 \<le> m" by simp
    with mono_sqrt have "Discrete.sqrt ((Suc c)\<^sup>2) \<le> Discrete.sqrt m" by (rule monoE)
    then have "Suc c \<le> Discrete.sqrt m" by simp
    then have "c < Discrete.sqrt m" by simp
    moreover from `(Suc c)\<^sup>2 < m` have "Discrete.sqrt m > 0" by simp
    ultimately have "c * Discrete.sqrt m < Discrete.sqrt m * Discrete.sqrt m" by simp
    also have "\<dots> \<le> m" by (simp add: power2_eq_square [symmetric])
    finally show "c * Discrete.sqrt m < id m" by simp
  qed
  then show "\<exists>n. \<forall>m>n. c * Discrete.sqrt m < id m" ..
qed

lemma "id \<prec> (\<lambda>n. n\<^sup>2)"
  by (rule less_fun_strongI) (auto simp add: power2_eq_square)

lemma "(\<lambda>n. n ^ k) \<prec> (\<lambda>n. n ^ Suc k)"
  by (rule less_fun_strongI) auto

text {* @{prop "(\<lambda>n. n ^ k) \<prec> (\<lambda>n. 2 ^ n)"} *}

end


theory Homework04
  imports "BST_Demo"
begin

datatype 'a rtree = Leaf|Node "'a rtree" nat 'a "'a rtree"

fun num_nodes :: "'a rtree \<Rightarrow> nat" where
  "num_nodes Leaf = 0"|
  "num_nodes (Node l a b r) = num_nodes l + num_nodes r + 1"

fun rbst :: "'a::linorder rtree \<Rightarrow> bool" where
  "rbst Leaf = True"|
  "rbst (Node l a b r) =
    ((rbst l)\<and>
    (\<forall>x\<in>set_rtree l. x<b)\<and>
    (a = num_nodes l)\<and>
    (\<forall>x\<in>set_rtree r. b<x)\<and>
    (rbst r))"

value "rbst (Node (Node Leaf (0::nat) (1::nat) Leaf) (1::nat) 2 (Node Leaf (0::nat) 3 Leaf))"
value "set_rtree(Node (Node Leaf (0::nat) (1::nat) Leaf) (1::nat) 2 (Node Leaf (0::nat) 3 Leaf))"

fun rins :: "'a::linorder \<Rightarrow> 'a rtree \<Rightarrow> 'a rtree" where
  "rins x Leaf = (Node Leaf 0 x Leaf)"|
  "rins x (Node l a b r) = (if x<b then (Node (rins x l) (Suc a) b r) else (Node l a b (rins x r)))"

value "rins 5 (Node (Node Leaf (0::nat) (1::nat) Leaf) (1::nat) 2 (Node Leaf (0::nat) 3 Leaf))"

lemma rins_set[simp]: "set_rtree (rins x t) = insert x (set_rtree t)"
  apply(induction t)
   apply auto
  done

lemma aux1[simp]:  "(x\<notin>set_rtree t) \<Longrightarrow>num_nodes (rins x t) = Suc(num_nodes t)"
  apply(induction t arbitrary:x)
   apply auto
  done

lemma aux[simp]: "rbst(Node l a b r) \<Longrightarrow> (num_nodes l = a) "
  apply auto
  done

lemma "x\<notin>set_rtree t \<Longrightarrow> rbst t \<Longrightarrow> rbst (rins x t)"
  apply(induction t arbitrary: x rule:rbst.induct)
   apply auto
  done

fun risin:: "'a::linorder \<Rightarrow> 'a rtree \<Rightarrow> bool" where
  "risin _ Leaf = False"|
  "risin x (Node l a b r) = ((x=b)\<or>(risin x l)\<or>(risin x r))"

lemma "rbst t \<Longrightarrow> risin x t \<longleftrightarrow> x\<in>set_rtree t"
  apply(induction t)
   apply auto
  done

fun inorder :: "'a rtree \<Rightarrow> 'a list" where
  "inorder Leaf = []"|
  "inorder (Node l a b r) = inorder l @ b # inorder r"

fun rank:: "'a::linorder \<Rightarrow> _" where

end


theory HSV_chapter4 imports Complex_Main begin

(* Triangle numbers *)
fun triangle :: "nat \<Rightarrow> nat" where
  "triangle n = (if n = 0 then 0 else n + triangle (n-1))"

value "triangle 1"
value "triangle 2"
value "triangle 3"

theorem triangle_closed_form: "triangle n = (n+1) * n div 2"
  apply (induct n)
  apply simp+
  done

(* Tetrahedral numbers *)
fun tet :: "nat \<Rightarrow> nat" where
  "tet n = (if n = 0 then 0 else triangle n + tet (n-1))"

value "tet 1" (* 1 *)
value "tet 2" (* 4 *)
value "tet 3" (* 10 *)
value "tet 4" (* 20 *)
value "tet 5" (* 35 *)
value "tet 6" (* 56 *)

find_theorems "_ div ?x + _ div ?x"
thm div_add

(* Proving that closed form is equivalent to recursive definition *)
theorem "tet n = ((n + 2) * (n + 1) * n) div 6"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc k)

  (* induction hypothesis *)
  assume IH: "tet k = (k + 2) * (k + 1) * k div 6"

  (* establish a useful fact and label it "*" *)
  have "2 dvd (k + 2) * (k + 1)" by simp
  hence *: "6 dvd (k + 2) * (k + 1) * 3" by presburger

  (* establish another useful fact and label it "**" *)
  have "2 dvd (k + 2) * (k + 1) * k" by simp
  moreover have "3 dvd (k + 2) * (k + 1) * k"
  proof -
    {
      assume "k mod 3 = 0"
      hence "3 dvd k" by presburger
      hence "3 dvd (k + 2) * (k + 1) * k" by fastforce
    } moreover {
      assume "k mod 3 = 1"
      hence "3 dvd (k + 2)" by presburger
      hence "3 dvd (k + 2) * (k + 1) * k" by fastforce
    } moreover {
      assume "k mod 3 = 2"
      hence "3 dvd (k + 1)" by presburger
      hence "3 dvd (k + 2) * (k + 1) * k" by fastforce
    } ultimately
    show "3 dvd (k + 2) * (k + 1) * k" by linarith
  qed
  ultimately have **: "6 dvd (k + 2) * (k + 1) * k" by presburger

  (* the actual proof *)
  have "tet (Suc k) = triangle (Suc k) + tet k"
    by simp
  also have "... = (k + 2) * (k + 1) div 2 + tet k"
    using triangle_closed_form by simp
  also have "... = (k + 2) * (k + 1) div 2 + (k + 2) * (k + 1) * k div 6"
    using IH by simp
  also have "... = ((k + 2) * (k + 1) * 3 + (k + 2) * (k + 1) * k) div 6"
    using div_add[OF * **] by simp
  also have "... = (k + 2) * (k + 1) * (k + 3) div 6"
    by (simp add: distrib_left)
  also have "... = (Suc k + 2) * (Suc k + 1) * Suc k div 6"
    by (metis One_nat_def Suc_1 add.commute add_Suc_shift mult.assoc
        mult.commute numeral_3_eq_3 plus_1_eq_Suc)
  finally show ?case by assumption
qed

end


(*
  Author: Fred Kurz
*)
theory List_Supplement
imports Main
begin

lemma list_foot:
  assumes "l \<noteq> []"
  obtains y ys where "l = ys @ [y]"
proof -
  {
    assume a: "l \<noteq> []"
    have "\<exists>y ys. l = ys @ [y]"
      using a
      proof (induction l)
        case (Cons a l)
        then show ?case
          proof (cases "l = []")
            case True
            have "[] @ [a] = a # l"
              using True
              by simp
            thus ?thesis
              using Cons.prems(1)
              by simp
          next
            case False
            thm Cons
            then obtain y ys where "l = ys @ [y]"
              using Cons.IH
              by blast
            then have "a # l = a # ys @ [y]"
              by blast
            thus ?thesis
              by fastforce
          qed
      qed simp
  }
  thus ?thesis
    using assms that
    by blast
qed

lemma list_ex_intersection: "list_ex (\<lambda>v. list_ex ((=) v) ys) xs \<longleftrightarrow> set xs \<inter> set ys \<noteq> {}"
proof -
  {
    assume "list_ex (\<lambda>v. list_ex ((=) v) ys) xs"
    then have "\<exists>v \<in> set xs. list_ex ((=) v) ys"
      using list_ex_iff
      by fast
    moreover have "\<forall>v. list_ex ((=) v) ys = (\<exists>v' \<in> set ys. v = v')"
      using list_ex_iff
      by blast
    ultimately have "\<exists>v \<in> set xs. (\<exists>v' \<in> set ys. v = v')"
      by blast
    then obtain v v' where "v \<in> set xs" and "v' \<in> set ys" and "v = v'"
      by blast
    then have "set xs \<inter> set ys \<noteq> {}"
      by blast
  } moreover {
    assume  "set xs \<inter> set ys \<noteq> {}"
    then obtain v v' where "v \<in> set xs" and "v' \<in> set ys" and "v = v'"
      by blast
    then have "list_ex (\<lambda>v. \<exists>v' \<in> set ys. v = v') xs"
      using list_ex_iff
      by fast
    moreover have "\<forall>v. (\<exists>v' \<in> set ys. v = v') = list_ex ((=) v) ys"
      using list_ex_iff
      by blast
    ultimately have "list_ex (\<lambda>v. list_ex ((=) v) ys) xs"
      by force
  } ultimately show ?thesis
    by blast
qed

lemma length_map_upt: "length (map f [a..<b]) = b - a"
proof -
  have "length [a..<b] = b - a"
    using length_upt
    by blast
  moreover have "length (map f [a..<b]) = length [a..<b]"
    by simp
  ultimately show ?thesis
    by argo
qed

lemma not_list_ex_equals_list_all_not: "(\<not>list_ex P xs) = list_all (\<lambda>x. \<not>P x) xs"
proof -
  have "(\<not>list_ex P xs) = (\<not>Bex (set xs) P)"
    using list_ex_iff
    by blast
  also have "\<dots> = Ball (set xs) (\<lambda>x. \<not>P x)"
    by blast
  finally show ?thesis
    by (simp add: Ball_set_list_all)
qed

lemma element_of_subseqs_then_subset:
  assumes "l \<in> set (subseqs l')"
  shows"set l \<subseteq> set l'"
  using assms
proof (induction l' arbitrary: l)
  case (Cons x l')
  have "set (subseqs (x # l')) = (Cons x) ` set (subseqs l') \<union> set (subseqs l')"
    unfolding subseqs.simps(2) Let_def set_map set_append..
  then consider (A) "l \<in> (Cons x) ` set (subseqs l')"
    | (B) "l \<in> set (subseqs l')"
    using Cons.prems
    by blast
  thus ?case
    proof (cases)
      case A
      then obtain l'' where "l'' \<in> set (subseqs l')" and "l = x # l''"
        by blast
      moreover have "set l'' \<subseteq> set l'"
        using Cons.IH[of l'', OF calculation(1)].
      ultimately show ?thesis
        by auto
    next
      case B
      then show ?thesis
        using Cons.IH
        by auto
    qed
qed simp

(* TODO rewrite using list comprehension \<open>embed xs = [[x]. x \<leftarrow> xs]\<close> *)
text \<open> Embed a list into a list of singleton lists. \<close>
primrec embed :: "'a list \<Rightarrow> 'a list list"
  where "embed [] = []"
  | "embed (x # xs) = [x] # embed xs"

lemma set_of_embed_is: "set (embed xs) = { [x] | x. x \<in> set xs }"
  by (induction xs; force+)

lemma concat_is_inverse_of_embed:
  "concat (embed xs) = xs"
  by (induction xs; simp)

lemma embed_append[simp]: "embed (xs @ ys) = embed xs @ embed ys"
proof (induction xs)
  case (Cons x xs)
  have "embed (x # xs @ ys) = [x] # embed (xs @ ys)"
    try0
    by simp
  also have "\<dots> = [x] # (embed xs @ embed ys)"
    using Cons.IH
    by simp
  finally show ?case
    by fastforce
qed simp

end


theory CS_Ch4
imports Main "./CS_Ch3"
begin

(* 4.1 *)

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"
fun set :: "'a tree \<Rightarrow> 'a set" where
"set Tip = {}" |
"set (Node l v r) = (set l) \<union> {v} \<union> (set r)"

(* the hint says to use quantifiers. I initially tried doing this with a recursive definition for
   the "treele" and "treege" but ran into issues trying to do the proof. I needed more lemmas than
   I thought necessary. The set-based definition seems to work around this, probably by having all
   the properties that need to be proved about custom functions implied by the quantifier and the
   fanciness that 'auto' does. *)
fun ord :: "int tree \<Rightarrow> bool" where
"ord Tip = True" |
"ord (Node l v r) = ((ord l) \<and> (ord r) \<and> (\<forall>x\<in>(set l). x \<le> v) \<and> (\<forall>x\<in>(set r). x \<ge> v))"

fun ins :: "int tree \<Rightarrow> int \<Rightarrow> int tree" where
"ins Tip a = Node Tip a Tip" |
"ins (Node l v r) a = (if a \<le> v then Node (ins l a) v r else Node l v (ins r a))"

lemma ins_lem: "set (ins t x) = {x} \<union> set t"
apply(induction t)
apply(auto)
done

value "ins (Node Tip (-1) Tip) 0"

lemma "ord t \<Longrightarrow> ord (ins t x)"
apply(induction t arbitrary: x)
apply(auto simp add: ins_lem)
done

inductive ev :: "nat \<Rightarrow> bool" where
ev0 : "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc (Suc n)) = evn n"

lemma "ev(Suc(Suc(Suc(Suc 0))))"
apply(rule evSS)
apply(rule evSS)
apply(rule ev0)
done

lemma "ev m \<Longrightarrow> evn m"
apply(induction rule: ev.induct)
by(simp_all)

declare ev.intros[simp, intro]

lemma "evn n \<Longrightarrow> ev n"
apply(induction n rule: evn.induct)
by(simp_all)

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
apply(induction rule: star.induct)
apply(assumption)
apply(metis step)
done

(* 4.2 *)

inductive palindrome :: "'a list \<Rightarrow> bool" where
empty: "palindrome []" |
singleton: "palindrome [a]" |
step: "palindrome xs \<Longrightarrow> palindrome (a # xs @ [a])"

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

(* 4.3 *)

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

(* this lemma is required to prove the right-hand side of a subgoal, but we need to separate it
   out to apply the rule induction *)
lemma star'_rightmost_bit: "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
apply(induction rule: star.induct)
apply(auto intro: star.refl star.step)
done

lemma "star' r x y \<Longrightarrow> star r x y"
apply(induction rule: star'.induct)
apply(rule star.refl)
apply(auto simp add: star'_rightmost_bit)
done

(* this lemma is required to reorder the implications to allow induction to proceed *)
lemma star_reordered_bit: "star' r y z \<Longrightarrow> r x y \<Longrightarrow> star' r x z"
apply(induction rule: star'.induct)
apply(auto intro: refl' step')
done

lemma "star r x y \<Longrightarrow> star' r x y"
apply(induction rule: star.induct)
apply(auto simp add: star_reordered_bit intro: star'.refl')
done

(* 4.4 *)

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
iter0: "iter r 0 x x" |
iterstep: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (n+1) x z"

(* the "correction" is the introduction of the existential. not sure what the "implicit"
   meaning of a free variable is. I expect it to be a meta-\<forall> though. *)
lemma "star r x y \<Longrightarrow> \<exists>n. iter r n x y"
apply(induction rule: star.induct)
apply(auto intro: iter0 iterstep)
done

(* 4.5 *)

datatype alpha = a | b | c
inductive S :: "alpha list \<Rightarrow> bool" where
empty: "S []" |
fst: "S s \<Longrightarrow> S (a # s @ [b])" |
snd: "S s\<^sub>1 \<Longrightarrow> S s\<^sub>2 \<Longrightarrow> S (s\<^sub>1 @ s\<^sub>2)"

inductive T :: "alpha list \<Rightarrow> bool" where
empty: "T []" |
fst: "T t\<^sub>1 \<Longrightarrow> T t\<^sub>2 \<Longrightarrow> T (t\<^sub>1 @ [a] @ t\<^sub>2 @ [b])"

lemma t_implies_s: "T w \<Longrightarrow> S w"
apply(induction w rule: T.induct)
apply(auto intro: S.empty S.fst S.snd T.fst)
done

lemma t_same_form_as_s: "T s \<Longrightarrow> T (a # s @ [b])"
apply(induction s)
(* thanks try! *)
apply(metis T.empty T.fst append_Nil append_Cons)
apply(metis T.empty T.fst append_Nil append_Cons)
done

lemma t_append: "T t\<^sub>1 \<Longrightarrow> T t\<^sub>2 \<Longrightarrow> T (t\<^sub>2 @ t\<^sub>1)"
apply(induction t\<^sub>1 rule: T.induct)
apply(simp)
(* simplifying this subgoal causes metis to not terminate. additionally, trying to prove T (t\<^sub>1 @ t\<^sub>2)
   also causes non-termintation. (at least, I assume it won't terminate, I left it running in the
   background and forgot about it for a few hours... I'd be curious to dig deeper into the cause
   of the non-termination. In fact, it's even sensitive to the order of the antecedents! *)
apply (metis append_assoc T.fst)
done

(* but, this consequence is a straightforward unification with t_append! *)
lemma "T t\<^sub>1 \<Longrightarrow> T t\<^sub>2 \<Longrightarrow> T (t\<^sub>1 @ t\<^sub>2)"
apply(rule t_append)
apply(simp_all)
done

lemma s_implies_t: "S w \<Longrightarrow> T w"
apply(induction w rule: S.induct)
apply(auto simp add: T.empty t_same_form_as_s t_append)
done

lemma s_equiv_t: "S w = T w"
apply(auto simp add: s_implies_t t_implies_s)
done

(* 4.6 *)

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
inN: "aval_rel (N n) s n" |
inV: "s x = n \<Longrightarrow> aval_rel (V x) s n" |
inPlus: "aval_rel e\<^sub>1 s v\<^sub>1 \<Longrightarrow> aval_rel e\<^sub>2 s v\<^sub>2 \<Longrightarrow> aval_rel (Plus e\<^sub>1 e\<^sub>2) s (v\<^sub>1 + v\<^sub>2)"

lemma aval_rel_is_aval: "aval_rel e s v \<Longrightarrow> aval e s = v"
apply(induction rule: aval_rel.induct)
apply(auto)
done

lemma aval_is_aval_rel: "aval e s = v \<Longrightarrow> aval_rel e s v"
apply(induction e arbitrary: v)
(* The third subgoal here has a very interesting structure - the v is quantified in each antecedent,
   separately from the v generated by the induction. This makes sense, but initially surprised me. *)
apply(auto intro: inN inV inPlus)
done

lemma "aval_rel e s v \<longleftrightarrow> aval e s = v"
apply(auto) (* split the \<longleftrightarrow> *)
(* if you try to do both of these at once, it will not terminate for obvious reasons *)
apply(auto simp add: aval_rel_is_aval)
apply(auto simp add: aval_is_aval_rel)
done

(* 4.7 *)

(* copying defn's to tear out the option *)

datatype instr = LOADI val | LOAD vname | ADD

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk = n # stk" |
"exec1 (LOAD x) s stk = (s x) # stk" |
"exec1 ADD _ stk = (hd stk + hd2 stk) # tl2 stk"

(* I tried using Option.bind etc but I can't seem to get anything proven when I'm using it.
   Expanding it manually works, though. Oh well. *)
fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk" |
"exec (i # is) s stk = (exec is s (exec1 i s stk))"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

(* I originally tried to formulate these lemmas like,
"case (exec is\<^sub>1 s stk) of Some stk' \<Rightarrow> exec (is\<^sub>1 @ is\<^sub>2) s stk = exec is\<^sub>2 s stk'
                        | None \<Rightarrow> exec (is\<^sub>1 @ is\<^sub>2) s stk = None"
but was unable to prove them. *)
lemma exec_append: "exec is\<^sub>1 s stk = stk' \<Longrightarrow> exec (is\<^sub>1 @ is\<^sub>2) s stk = exec is\<^sub>2 s stk'"
apply(induction is\<^sub>1 arbitrary: stk)
apply(auto)
done

lemma "exec (comp e) s stk =  aval e s # stk"
apply(induction e arbitrary: stk)
apply(auto simp add: exec_append)
done

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
okempty: "ok n [] n" |
okLOADI: "ok n is n' \<Longrightarrow> ok n (is @ [LOADI _]) (Suc n')" |
okLOAD: "ok n is n' \<Longrightarrow> ok n (is @ [LOAD _]) (Suc n')" |
(* protip: unbound variables are universally quantified. So if you say, for example is @ [PLUS], you
   gotta prove that sucker for all values of PLUS. Pay attention to the quantifiers when things
   don't work as expected! *)
okADD: "ok n is (Suc (Suc n')) \<Longrightarrow> ok n (is @ [ADD]) (Suc n')"

lemma "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"
apply(induction rule: ok.induct)
apply(auto simp add: exec_append intro: okempty okLOADI okLOAD okADD)
done

lemma ok_append: "ok n (e2) n' \<Longrightarrow> ok n'' (e1) n \<Longrightarrow> ok n'' (e1 @ e2) n'"
apply(induction rule: ok.induct)
apply(simp)
apply (metis append_assoc ok.simps)
apply (metis append_assoc ok.simps)
apply (metis append_assoc ok.simps)
done

(* if we start with any stack, executing the result of compiling an aexp will leave one more elt
   on the stack. *)
lemma "ok n (comp e) (Suc n)"
apply(induction e arbitrary: n)
using okLOADI okempty apply fastforce
using okLOAD okempty apply fastforce
using okADD ok_append apply fastforce
done

end


header {* Matrices\label{sec.mat} *}

theory Matrices
imports
  Main
  Determinants_extension
begin

text{* This theory contains a number of notions and results about matrices, in
   particular the adjugate matrix and its fundamental property. *}

(* ------------------------------------------------------------------------- *)
subsection {* Minors *}
(* ------------------------------------------------------------------------- *)

text{* Kronecker - Delta *}
definition "\<delta> i j = (if i = j then 1 else 0)"

lemma delta_comm: "\<delta> i j = \<delta> j i"
 by(simp add: \<delta>_def)

text{* unit vector *}
definition "e i = (\<chi> j. \<delta> i j)"

text{* the minor-matrix *}
definition "minorM A i j =
  (\<chi> k l. if k = i \<and> l = j then 1 else
          if k = i \<or> l = j then 0 else
          A$k$l
  )"

lemma minorM_rows:
  fixes A :: "'a::comm_ring_1^'n^'n" and i j k :: 'n
  assumes "k \<noteq> i"
  shows "row i (minorM A i j) = e j"
        "row k (minorM A i j) = (\<chi> c. if c = j then 0 else (row k A) $ c)"
proof-
  show "row i (minorM A i j) = e j"
  by(simp_all add: minorM_def row_def e_def \<delta>_def vec_eq_iff)
next
  { fix l :: 'n
    have "(row k (minorM A i j)) $ l = (\<chi> c. if c = j then 0 else (row k A) $ c) $ l"
    proof cases
      assume caseass: "l = j"
      hence "(row k (minorM A i j)) $ l = 0"
        unfolding row_def minorM_def using assms by auto
      thus ?thesis
        using caseass by simp
    next
      assume caseass: "l \<noteq> j"
      hence "(row k (minorM A i j)) $ l = (row k A) $ l"
        unfolding row_def minorM_def using assms by simp
      thus ?thesis using caseass
        by simp
    qed
  }
  thus "row k (minorM A i j) = (\<chi> c. if c = j then 0 else (row k A) $ c)"
    unfolding vec_eq_iff minorM_def by force
qed

text{* more general than minorM\_zeros below *}
lemma minorM_eq:
  fixes A B :: "'a::comm_ring_1^'n^'n" and i j :: 'n
  assumes "\<And> k l. k \<noteq> i \<longrightarrow> l \<noteq> j \<longrightarrow> ( A $ k $ l ) = ( B $ k $ l )"
  shows "minorM A i j = minorM B i j"
proof-
  { fix k l :: 'n
    have "(minorM A i j) $ k $ l = (minorM B i j) $ k $ l"
    proof cases
      assume "k = i \<or> l = j"
      thus ?thesis
        unfolding minorM_def by simp
    next
      assume "\<not> ( k = i \<or> l = j)"
      thus ?thesis
        using assms unfolding minorM_def by auto
    qed }
  thus ?thesis unfolding vec_eq_iff
    by blast
qed

lemma minorM_zeros:
  fixes A :: "'a::comm_ring_1^'n^'n" and i j :: 'n
  assumes "row i A = e j" "column j A = e i"
  shows "A = minorM A i j"
proof-
  { fix k l :: 'n
    have "A $ k $ l = (minorM A i j) $ k $ l"
    proof cases
      assume caseass: "k = i \<and> l = j"
      then have "A $ k $ l = 1"
        using assms e_def \<delta>_def row_def
        by (metis vec_lambda_beta vec_nth_inverse)
      then show ?thesis
        using caseass minorM_def[of A i j]
        by auto
    next
      assume caseass: "\<not> (k = i \<and> l = j)"
      show ?thesis
      proof cases
        assume caseass2: "k = i \<or> l = j"
        then have "(minorM A i j) $ k $ l = 0"
          using caseass minorM_def[of A i j] by auto
        also have "A $ k $ l = 0"
          apply(cases "k = i")
          apply(metis vec_lambda_beta assms(1) e_def \<delta>_def caseass row_def[of i A])
          apply(metis (no_types) \<delta>_def assms(2) caseass2 column_def e_def vec_lambda_beta)
          done
        finally show ?thesis
          by auto
      next
        assume caseass2: "\<not> (k = i \<or> l = j)"
        thus ?thesis
          using caseass minorM_def[of A i j] by auto
      qed
    qed
  }
  thus ?thesis
    unfolding vec_eq_iff by fast
qed

(* ------------------------------------------------------------------------- *)
subsection {* Cofactors *}
(* ------------------------------------------------------------------------- *)

text{* the cofactors of A *}
definition "cofactor A i j = det (minorM A i j)"

text{* the cofactor-matrix *}
definition "cofactorM A = (\<chi> i j. cofactor A i j)"

text{* the number of rows in A (except the i-th row) where the j-th element different from 0 *}
definition "nonzerorows A i j = card { k . k \<noteq> i \<and> ( A $ k $ j ) \<noteq> 0 }"

lemma aux_det_minorM_row:
  fixes B :: "'a::comm_ring_1^'n^'n" and i j :: 'n
  assumes "row i B = e j"
  shows "det B = det (minorM B i j)"
proof-
  { fix n::nat
    have "\<forall> (B::'a^'n^'n) i j . nonzerorows B i j = n \<longrightarrow> row i B = e j
      \<longrightarrow> det B = det (minorM B i j)"
    proof (induct n)
      case 0
      { fix B :: "'a^'n^'n" and i j
        let ?nzB = "{ k . k \<noteq> i \<and> B $ k $ j \<noteq> 0 }"
        assume caseass: "nonzerorows B i j = 0" "row i B = e j"
        hence "\<forall> k. k \<noteq> i \<longrightarrow> (B $ k $ j) = 0"
          using nonzerorows_def[of B i j] by auto
        then have "column j B = e i"
          by(simp add: column_def[of j B] vec_eq_iff)
            (metis \<delta>_def caseass(2) e_def row_def vec_lambda_beta)
        hence "B = (minorM B i j)"
          using caseass minorM_zeros[of i B j] by blast }
      thus ?case by force
    next
      case (Suc n)
      { txt{* Suc.hyps is @{term "\<forall> B i j. nonzerorows B i j = n \<longrightarrow> row i B = e j
          \<longrightarrow> det B = det (minorM B i j)"} *}
        fix B:: "'a^'n^'n" and i j
        let ?nzB = "{ k . k \<noteq> i \<and> B $ k $ j \<noteq> 0 }"
        assume caseass: "nonzerorows B i j = Suc n" "row i B = e j"
        hence "card ?nzB \<noteq> 0"
          using nonzerorows_def[of B i j] by simp
        then obtain r where rcond: "r \<noteq> i \<and> ( B $ r $ j ) \<noteq> 0"
          using caseass by auto
        hence "r \<noteq> i"
          by auto

        let ?B' = "(\<chi> l. if l = r then row r B + (- (B $ r $ j)) *s row i B else row l B)"

        have "nonzerorows ?B' i j = n"
        proof-
          let ?nzB' = "{ k . k \<noteq> i \<and> ?B'$ k $ j \<noteq> 0 }"
          have "?nzB' = ?nzB - { r }"
            using caseass by (auto simp add: row_def e_def \<delta>_def)
          thus ?thesis
            using rcond caseass(1) by(simp add: nonzerorows_def)
        qed
        moreover have "row i ?B' = e j"
          using caseass `r \<noteq> i`
          by(simp add: nonzerorows_def row_def)
            (metis vec_lambda_eta )
        ultimately have "det ?B' = det (minorM ?B' i j)"
          using Suc.hyps by(simp add: nonzerorows_def row_def)

        moreover have "(minorM B i j) = (minorM ?B' i j)"
          using minorM_eq[of i j B ?B'] `row i B = e j`
          by (simp add: e_def \<delta>_def row_def)
        ultimately have "det B = det (minorM B i j)"
          using `r \<noteq> i` my_det_row_operation[of r i B "- B $ r $ j"] by simp
      }
      txt{* finished induction step *}
      thus ?case by fast
    qed
  }
  thus ?thesis using assms by blast
qed

lemma det_minorM_row:
  fixes A :: "'a::comm_ring_1^'n^'n" and i j
  shows "det (minorM A i j) = det (\<chi> k. if k = i then (e j) else row k A)"
proof-
  let ?B = "(\<chi> k. if k = i then (e j) else row k A)"

  have "(minorM ?B i j) = (minorM A i j)"
    using minorM_eq[of i j ?B A] by(simp add: row_def)
  moreover have "det ?B = det (minorM ?B i j)"
    by(simp add: aux_det_minorM_row row_def[of i ?B] vec_lambda_eta)
  ultimately show ?thesis
    by auto
qed

lemma minorM_transpose: "minorM (transpose A) i j = transpose (minorM A j i)"
  by(simp add: minorM_def transpose_def conj_commute disj_commute cong del: if_cong)

lemma det_minorM_column:
  fixes A :: "'a::comm_ring_1^'n^'n" and i j
  shows "det( minorM A i j ) = det (\<chi> r c. if c = j then \<delta> r i else A $ r $ c)"
  (is "?lm = det( ?B )" )
proof-
  have "(\<chi> r c . if r = j then (\<delta> c i) else (A $ c $ r) ) =
  (\<chi> r . if r = j then (e i) else row r (transpose A))"
    by(simp add: e_def delta_comm row_transpose column_def vec_eq_iff cong del: if_cong)

  hence "det( \<chi> r . if r = j then (e i) else row r (transpose A) ) =
  det( transpose( \<chi> r c . if c = j then (\<delta> r i) else (A $ r $ c) ) )"
    by (simp add: transpose_def)

  thus ?thesis
    by (metis (no_types) det_minorM_row det_transpose minorM_transpose)
qed

lemma cofactorM_transpose: "cofactorM (transpose A) = transpose (cofactorM A)"
  (is "?lhs = ?rhs")
  by(simp only: cofactorM_def cofactor_def minorM_transpose det_transpose)
    (simp add: transpose_def)

(* ------------------------------------------------------------------------- *)
subsection {* Scalar-matrix multiplication *}
(* ------------------------------------------------------------------------- *)

definition scalar_matrix_mult :: "('a\<Colon>ab_semigroup_mult) \<Rightarrow> ('a^'n^'m) \<Rightarrow> ('a^'n^'m)"
  (infixl "*ss" 70) where "c *ss A = (\<chi> i j. c * (A $ i $ j))"

lemma scalar_matrix_mult_monom:
  fixes A :: "'a\<Colon>comm_ring_1 poly^'n^'n"
  shows "monom 1 0 *ss A = A"
  by (simp add: monom_0 one_poly_def scalar_matrix_mult_def vec_eq_iff)

lemma scalar_minus_left:
  fixes x :: "'a\<Colon>comm_ring_1"
  shows "- x *ss A = - (x *ss A)"
  by (simp add: vec_eq_iff scalar_matrix_mult_def )

lemma one_scalar_mult_mat:
  shows "1 *ss (A::'a\<Colon>comm_ring_1^'n^'n) = A"
  unfolding scalar_matrix_mult_def
  by(simp add: vec_lambda_eta)

lemma scalar_mat_matrix_mult_left:
  "mat y ** A = y *ss A"
  by (simp add: vec_eq_iff mat_def scalar_matrix_mult_def matrix_matrix_mult_def
     if_distrib[where f="\<lambda>x. x * y" for y] setsum.If_cases)

lemma scalar_scalar_mult_assoc: "x1 *ss (x2 *ss A) = (x1 * x2) *ss A "
  unfolding scalar_matrix_mult_def
  by(simp add: mult.assoc)

lemma matrix_scalar_assoc:
  fixes A B :: "'a\<Colon>comm_ring_1^'n\<Colon>finite^'n"
  shows "A ** (a *ss B) = a *ss (A ** B)"
  unfolding scalar_matrix_mult_def matrix_matrix_mult_def vec_eq_iff
  by(auto simp add: setsum_right_distrib intro!: Cartesian_Euclidean_Space.setsum_cong_aux)

lemma matrix_scalar_mat_one:
  fixes x1 and A :: "'a\<Colon>comm_ring_1^'n\<Colon>finite^'n"
  shows "A ** (x1 *ss mat 1) = x1 *ss A"
  by(simp add: matrix_scalar_assoc matrix_mul_rid)

lemma scalar_minus_ldistrib:
  fixes A and B :: "'a::comm_ring_1^'n\<Colon>finite^'n"
  and x1 :: "('a::comm_ring_1)"
  shows "x1 *ss (A - B) = (x1 *ss A) - (x1 *ss B)"
  unfolding scalar_matrix_mult_def vec_eq_iff
  by (simp add: mult_diff_mult)

(* ------------------------------------------------------------------------- *)
subsection {* Adjugates *}
(* ------------------------------------------------------------------------- *)

definition "adjugate A = transpose (cofactorM A)"

lemma adjugate_transpose: "adjugate (transpose A) = transpose (adjugate A)"
  by (simp add: adjugate_def cofactorM_transpose)

lemma delta_id_matrix: "(\<chi> i j. (\<delta> i j) * c) = c *ss (mat 1)"
  by (simp add: scalar_matrix_mult_def mat_def \<delta>_def mult.commute)

lemma if_c_is_k: "(if c = k then A $ r $ k else A $ r $ c) = A $ r $ c"
  by simp

theorem adjugate_det:
  fixes A :: "'a::comm_ring_1^'n^'n"
  shows "adjugate A ** A = det A *ss mat 1"
proof-
  let ?U = "UNIV\<Colon>'n\<Colon>finite set"
  have adjprod: "adjugate A ** A = (\<chi> i k. (\<Sum> j\<in>?U. (cofactor A j i) * A $ j $ k))"
    by (simp add: cofactorM_def transpose_def adjugate_def matrix_matrix_mult_def)

  { fix i k :: 'n

    have "(\<Sum>j\<in>?U. (cofactor A j i) * (A $ j $ k)) =
    (\<Sum>j\<in>?U. (A $ j $ k) * det (\<chi> r c. if c = i then \<delta> r j else (A $ r $ c)))"
      by (simp add: det_minorM_column cofactor_def comm_semiring_1_class.normalizing_semiring_rules)

    also have "\<dots> = (\<Sum>j\<in>?U. det (\<chi> r c. if c = i then \<delta> r j * A $ r $ k else A $ r $ c))"
    proof-
      { fix j
        have "(A $ j $ k) * det (\<chi> r c. if c = i then \<delta> r j else (A $ r $ c)) =
        det (\<chi> r c. if c = i then \<delta> r j * (A $ r $ k) else A $ r $ c)"
        using det_col_mul[of i _ "\<chi> r c. if c = i then \<delta> r j else A $ r $ c", symmetric]
        by(simp add: \<delta>_def comm_semiring_1_class.normalizing_semiring_rules(7) cong: if_cong)
          (simp add: if_distrib[where x=1 and y = 0] cong: if_cong) }
      thus ?thesis
      by auto
    qed

    also have "\<dots> = det (\<chi> r c. if c = i then (\<Sum> j \<in> ?U. \<delta> r j * A $ r $ k) else A $ r $ c)"
      using det_linear_column_setsum[of ?U i "\<lambda>j. \<chi> r. \<delta> r j * A $ r $ k"]
      by(simp only: vec_lambda_beta finite[of ?U])

    also have "\<dots> = det (\<chi> r c. if c = i then A $ r $ k else A $ r $ c)"
    proof-
      { fix r and a :: "'a::comm_ring_1"
      have "(\<Sum>j\<in>?U. \<delta> r j * a) = a"
        by(subst setsum.remove)(auto simp add: \<delta>_def) }
      thus ?thesis
        by presburger
    qed

    also have "\<dots> = \<delta> i k * det A"
    by(cases "i=k")
      (auto simp add: \<delta>_def vec_lambda_eta if_c_is_k column_def
               intro!: my_det_identical_columns[of i k])

    finally have "(\<Sum> j \<in> ?U. cofactor A j i * A $ j $ k) = \<delta> i k * det A"
      by(simp add: cofactor_def \<delta>_def)
  }
  thus ?thesis
    using adjprod delta_id_matrix[of "det A"] by auto
qed

lemma adjugate_det_symmetric:
  shows "A ** adjugate A = det A *ss mat 1"
proof-
  have "transpose (A ** adjugate A) = det A *ss mat 1"
    using matrix_transpose_mul[of A "adjugate A"] det_transpose[of A]
    adjugate_det[of "transpose A"] adjugate_transpose[of A]
    by auto

  also have "transpose (det A *ss mat 1) = det A *ss transpose (mat 1)"
    by(simp add: transpose_def scalar_matrix_mult_def)

  finally show ?thesis
    by(subst transpose_transpose[of "A ** adjugate A", symmetric])
      (simp add: transpose_mat)
qed

(* ------------------------------------------------------------------------- *)
subsection {* Matrix multiplication *}
(* ------------------------------------------------------------------------- *)

lemma matrix_mult_left_distributes_minus:
  fixes A B C :: "'a::comm_ring_1^'n^'n"
  shows "A ** (B - C) = A ** B - A ** C"
  by (metis (hide_lams, no_types) add_diff_cancel diff_add_cancel matrix_add_ldistrib)

lemma matrix_mult_right_distributes_minus:
  fixes A B C :: "'a::comm_ring_1^'n^'n"
  shows "(A - B) ** C = A ** C - B ** C"
  unfolding matrix_matrix_mult_def vec_eq_iff
  using finite[of UNIV]
  by(induct rule: finite_induct)
    (auto simp add: left_diff_distrib)

lemma matrix_sum_mult:
  fixes A :: "('a::comm_ring_1)^'n\<Colon>finite^'n\<Colon>finite"
      and f :: "nat \<Rightarrow> ('a::comm_ring_1)^'n\<Colon>finite^'n\<Colon>finite" and n :: nat
  shows "A ** (\<Sum> k \<le> n. (f k)) = (\<Sum> k \<le> n. A ** (f k))"
  by (induct n) (simp_all add: matrix_add_ldistrib)

(* ------------------------------------------------------------------------- *)
subsection {* Powers *}
(* ------------------------------------------------------------------------- *)

primrec matpow :: "'a\<Colon>semiring_1^'n^'n \<Rightarrow> nat \<Rightarrow> 'a^'n^'n" where
  matpow_0:   "matpow A 0 = mat 1" |
  matpow_Suc: "matpow A (Suc n) = A ** (matpow A n)"

lemma matrix_mult_one_comm: "A ** mat 1 = mat 1 ** A"
  by (simp add: matrix_mul_lid matrix_mul_rid)

lemma matpow_one: "matpow A 1 = A"
  by(simp add: matrix_mul_rid)

lemma matpow_comm: "A ** matpow A n = matpow A n ** A"
  by(induct n) (simp_all add: matrix_mult_one_comm matrix_mul_assoc)

lemma matpow_suc: "matpow A n ** A = matpow A (Suc n)"
  by(simp add: matpow_comm)

end


(*
Authors:
  Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk
  Hanna Lachnitt, TU Wien, lachnitt@student.tuwien.ac.at
*)

section \<open>Binary Representation of Natural Numbers\<close>

theory Binary_Nat
imports
  HOL.Nat
  HOL.List
  Basics
begin

primrec bin_rep_aux:: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
  "bin_rep_aux 0 m = [m]"
| "bin_rep_aux (Suc n) m = m div 2^n # bin_rep_aux n (m mod 2^n)"

lemma length_of_bin_rep_aux:
  fixes n m:: nat
  assumes "m < 2^n"
  shows "length (bin_rep_aux n m) = n+1"
  using assms
proof(induction n arbitrary: m)
  case 0
  then show "length (bin_rep_aux 0 m) = 0 + 1" by simp
next
  case (Suc n)
  assume a0:"\<And>m. m < 2^n \<Longrightarrow> length (bin_rep_aux n m) = n + 1" and "m < 2^(Suc n)"
  then show "length (bin_rep_aux (Suc n) m) = Suc n + 1"
    using a0 by simp
qed

lemma bin_rep_aux_neq_nil:
  fixes n m:: nat
  shows "bin_rep_aux n m \<noteq> []"
  using bin_rep_aux.simps by (metis list.distinct(1) old.nat.exhaust)

lemma last_of_bin_rep_aux:
  fixes n m:: nat
  assumes "m < 2^n" and "m \<ge> 0"
  shows "last (bin_rep_aux n m) = 0"
  using assms
proof(induction n arbitrary: m)
  case 0
  assume "m < 2^0" and "m \<ge> 0"
  then show "last (bin_rep_aux 0 m) = 0" by simp
next
  case (Suc n)
  assume a0:"\<And>m. m < 2^n \<Longrightarrow> m \<ge> 0 \<Longrightarrow> last (bin_rep_aux n m) = 0" and "m < 2^(Suc n)"
and "m \<ge> 0"
  then show "last (bin_rep_aux (Suc n) m) = 0"
    using bin_rep_aux_neq_nil by simp
qed

lemma mod_mod_power_cancel:
  fixes m n p:: nat
  assumes "m \<le> n"
  shows "p mod 2^n mod 2^m = p mod 2^m"
  using assms by (simp add: dvd_power_le mod_mod_cancel)

lemma bin_rep_aux_index:
  fixes n m i:: nat
  assumes "n \<ge> 1" and "m < 2^n" and "m \<ge> 0" and "i \<le> n"
  shows "bin_rep_aux n m ! i = (m mod 2^(n-i)) div 2^(n-1-i)"
  using assms
proof(induction n arbitrary: m i rule: nat_induct_at_least)
  case base
  assume "m < 2^1" and "i \<le> 1"
  then show "bin_rep_aux 1 m ! i = m mod 2^(1-i) div 2^(1-1-i)"
    using bin_rep_aux.simps
    by (metis One_nat_def base.prems(2) diff_is_0_eq' diff_zero div_by_1 le_Suc_eq le_numeral_extra(3)
nth_Cons' power_0 unique_euclidean_semiring_numeral_class.mod_less)
next
  case (Suc n)
  assume a0:"\<And>m i. m < 2^n \<Longrightarrow> m \<ge> 0 \<Longrightarrow> i \<le> n \<Longrightarrow> bin_rep_aux n m ! i = m mod 2 ^ (n-i) div 2^(n-1-i)"
and a1:"m < 2^(Suc n)" and a2:"i \<le> Suc n" and a3:"m \<ge> 0"
  then show "bin_rep_aux (Suc n) m ! i = m mod 2^(Suc n - i) div 2^(Suc n - 1 - i)"
  proof-
    have "bin_rep_aux (Suc n) m = m div 2^n # bin_rep_aux n (m mod 2^n)" by simp
    then have f0:"bin_rep_aux (Suc n) m ! i = (m div 2^n # bin_rep_aux n (m mod 2^n)) ! i" by simp
    then have "bin_rep_aux (Suc n) m ! i = m div 2^n" if "i = 0" using that by simp
    then have f1:"bin_rep_aux (Suc n) m ! i = m mod 2^(Suc n - i) div 2^(Suc n - 1 - i)" if "i = 0"
    proof-
      have "m mod 2^(Suc n - i) = m"
        using that a1 by (simp add: Suc.prems(2))
      then have "m mod 2^(Suc n - i) div 2^(Suc n - 1 - i) = m div 2^n"
        using that by simp
      thus ?thesis by (simp add: that)
    qed
    then have "bin_rep_aux (Suc n) m ! i = bin_rep_aux n (m mod 2^n) ! (i-1)" if "i \<ge> 1"
      using that f0 by simp
    then have f2:"bin_rep_aux (Suc n) m ! i = ((m mod 2^n) mod 2^(n - (i - 1))) div 2^(n - 1 - (i - 1))" if "i \<ge> 1"
      using that a0 a1 a2 a3 Suc.prems(2) by simp
    then have f3:"bin_rep_aux (Suc n) m ! i = ((m mod 2^n) mod 2^(Suc n - i)) div 2^(Suc n - 1 - i)" if "i \<ge> 1"
      using that by simp
    then have "bin_rep_aux (Suc n) m ! i = m mod 2^(Suc n - i) div 2^(Suc n - 1 - i)" if "i \<ge> 1"
    proof-
      have "Suc n - i \<le> n" using that by simp
      then have "m mod 2^n mod 2^(Suc n - i) = m mod 2^(Suc n - i)"
        using mod_mod_power_cancel[of "Suc n - i" "n" "m"] by simp
      thus ?thesis
        using that f3 by simp
    qed
    thus ?thesis using f1 f2
      using linorder_not_less by blast
  qed
qed

lemma bin_rep_aux_coeff:
  fixes n m i:: nat
  assumes "m < 2^n" and "i \<le> n" and "m \<ge> 0"
  shows "bin_rep_aux n m ! i = 0 \<or> bin_rep_aux n m ! i = 1"
  using assms
proof(induction n arbitrary: m i)
  case 0
  assume "m < 2^0" and "i \<le> 0" and "m \<ge> 0"
  then show "bin_rep_aux 0 m ! i = 0 \<or> bin_rep_aux 0 m ! i = 1" by simp
next
  case (Suc n)
  assume a0:"\<And>m i. m < 2 ^ n \<Longrightarrow> i \<le> n \<Longrightarrow> m \<ge> 0 \<Longrightarrow> bin_rep_aux n m ! i = 0 \<or> bin_rep_aux n m ! i = 1"
and a1:"m < 2^Suc n" and a2:"i \<le> Suc n" and a3:"m \<ge> 0"
  then show "bin_rep_aux (Suc n) m ! i = 0 \<or> bin_rep_aux (Suc n) m ! i = 1"
  proof-
    have "bin_rep_aux (Suc n) m ! i = (m div 2^n # bin_rep_aux n (m mod 2^n)) ! i" by simp
    moreover have "\<dots> = bin_rep_aux n (m mod 2^n) ! (i - 1)" if "i \<ge> 1"
      using that by simp
    moreover have "m mod 2^n < 2^n" by simp
    ultimately have "bin_rep_aux (Suc n) m ! i = 0 \<or> bin_rep_aux (Suc n) m ! i = 1" if "i\<ge>1"
      using that a0[of "m mod 2^n" "i-1"] a2 by simp
    moreover have "m div 2^n = 0 \<or> m div 2^n = 1"
      using a1 a3 less_mult_imp_div_less by(simp add: less_2_cases)
    ultimately show ?thesis by (simp add: nth_Cons')
  qed
qed

definition bin_rep:: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
"bin_rep n m = butlast (bin_rep_aux n m)"

lemma length_of_bin_rep:
  fixes n m:: nat
  assumes "m < 2^n"
  shows "length (bin_rep n m) = n"
  using assms length_of_bin_rep_aux bin_rep_def by simp

lemma bin_rep_coeff:
  fixes n m i:: nat
  assumes "m < 2^n" and "i < n" and "m \<ge> 0"
  shows "bin_rep n m ! i = 0 \<or> bin_rep n m ! i = 1"
  using assms bin_rep_def bin_rep_aux_coeff length_of_bin_rep by(simp add: nth_butlast)

lemma bin_rep_index:
  fixes n m i:: nat
  assumes "n \<ge> 1" and "m < 2^n" and "i < n" and "m \<ge> 0"
  shows "bin_rep n m ! i = (m mod 2^(n-i)) div 2^(n-1-i)"
proof-
  have "bin_rep n m ! i = bin_rep_aux n m ! i"
    using bin_rep_def length_of_bin_rep nth_butlast assms(3)
    by (simp add: nth_butlast assms(2))
  thus ?thesis
    using assms bin_rep_aux_index by simp
qed

lemma bin_rep_eq:
  fixes n m:: nat
  assumes "n \<ge> 1" and "m \<ge> 0" and "m < 2^n" and "m \<ge> 0"
  shows "m = (\<Sum>i<n. bin_rep n m ! i * 2^(n-1-i))"
proof-
  {
    fix i:: nat
    assume "i < n"
    then have "bin_rep n m ! i * 2^(n-1-i) = (m mod 2^(n-i)) div 2^(n-1-i) * 2^(n-1-i)"
      using assms bin_rep_index by simp
    moreover have "\<dots> = m mod 2^(n-i) - m mod 2^(n-i) mod 2^(n-1-i)"
      by (simp add: minus_mod_eq_div_mult)
    moreover have "\<dots> = int(m mod 2^(n-i)) - m mod 2^(n-i) mod 2^(n-1-i)"
      using mod_less_eq_dividend of_nat_diff by blast
    moreover have "\<dots> = int(m mod 2^(n-i)) - m mod 2^(n-1-i)"
      using mod_mod_power_cancel[of "n-1-i" "n-i"] by (simp add: dvd_power_le mod_mod_cancel)
    ultimately have "bin_rep n m ! i * 2^(n-1-i) = int (m mod 2^(n-i)) - m mod 2^(n-1-i)"
      by presburger
  }
  then have f0:"(\<Sum>i<n. bin_rep n m ! i * 2^(n-1-i)) = (\<Sum>i<n. int (m mod 2^(n-i)) - m mod 2^(n-1-i))"
    by auto
  thus ?thesis
  proof-
     have "(\<Sum>i<n. int ((m::nat) mod 2^(n - i)) - (m mod 2^(n - 1 - i))) =
          (\<Sum>i<n. ( m mod 2^(n - i))) -  (\<Sum>i<n. int (m mod 2^(n - 1 - i)))"
      using sum_subtractf[of "(\<lambda>i. (m mod 2^(n-i)))::nat\<Rightarrow>nat" "(\<lambda>i. (m mod 2^(n-1-i)))::nat\<Rightarrow>nat" "{..<(n::nat)}"]
      by auto
    moreover have "\<dots> = m mod 2^n + (\<Sum>i\<in>{1..<n}. (m mod 2^(n-i))) - (\<Sum>i<n-1. int (m mod 2^(n-1-i)))- m mod 2^0"
      using sum.atLeast_Suc_atMost sum.lessThan_Suc assms(1)
      by (smt One_nat_def Suc_le_eq diff_self_eq_0 le_add_diff_inverse lessThan_atLeast0 minus_nat.diff_0
          plus_1_eq_Suc sum.atLeast_Suc_lessThan)
    moreover have "\<dots> = m mod 2^n + (\<Sum>i<n-1. m mod 2^(n-i-1)) - (\<Sum>i<n-1. int ( m mod 2^(n-1-i))) - m mod 2^0"
      apply (auto simp add: sum_of_index_diff[of "\<lambda>i. m mod 2 ^ (n - 1 - i)" "1" "n-1"])
      by (smt One_nat_def assms(1) le_add_diff_inverse lessThan_atLeast0 plus_1_eq_Suc sum.cong sum.shift_bounds_Suc_ivl)
    moreover have "\<dots> = m mod 2^n - m mod 2^0" by simp
    moreover have "\<dots> = m" using assms by auto
    ultimately show "m = (\<Sum>i<n. bin_rep n m ! i * 2^(n-1-i))"
      using assms f0 by linarith
  qed
qed

lemma bin_rep_index_0:
  fixes n m:: nat
  assumes "m < 2^n" and "k > n"
  shows "(bin_rep k m) ! 0 = 0"
proof-
  have "m < 2^(k-1)"
    using assms by(smt Suc_diff_1 Suc_leI gr0I le_trans less_or_eq_imp_le linorder_neqE_nat not_less
one_less_numeral_iff power_strict_increasing semiring_norm(76))
  then have f:"m div 2^(k-1) = 0"
    by auto
  have "k \<ge> 1"
    using assms(2) by simp
  moreover have "bin_rep_aux k m = (m div 2^(k-1)) # (bin_rep_aux (k-1) (m mod 2^(k-1)))"
    using bin_rep_aux.simps(2) by(metis Suc_diff_1 assms(2) diff_0_eq_0 neq0_conv zero_less_diff)
  moreover have "bin_rep k m = butlast ((m div 2^(k-1)) # (bin_rep_aux (k-1) (m mod 2^(k-1))))"
    using bin_rep_def by (simp add: calculation(2))
  moreover have "\<dots> = butlast (0 # (bin_rep_aux (k-1) (m mod 2^(k-1))))"
    using f by simp
  moreover have "\<dots> = 0 # butlast (bin_rep_aux (k-1) (m mod 2^(k-1)))"
    by(simp add: bin_rep_aux_neq_nil)
  ultimately show ?thesis
    by simp
qed

lemma bin_rep_index_0_geq:
  fixes n m:: nat
  assumes "m \<ge> 2^n" and "m < 2^(n+1)"
  shows "bin_rep (n+1) m ! 0 = 1"
proof-
  have "bin_rep (Suc n) m =  butlast (bin_rep_aux (Suc n) m)"
    using bin_rep_def by simp
  moreover have "\<dots> = butlast (1 # (bin_rep_aux n (m mod 2^n)))"
    using assms bin_rep_aux_def by simp
  moreover have "\<dots> = 1 # butlast (bin_rep_aux n (m mod 2^n))"
    by (simp add: bin_rep_aux_neq_nil)
  ultimately show ?thesis
    by (simp add: bin_rep_aux_neq_nil)
qed

end


(*<*)
theory Brent
imports
  Basis
begin
(*>*)
section\<open> Brent's algorithm \label{sec:brent} \<close>

text\<open>

\<^cite>\<open>"Brent:1980"\<close> improved on the Tortoise and Hare algorithm and
used it to factor large primes. In practice it makes significantly
fewer calls to the function \<open>f\<close> before detecting a loop.

We begin by defining the base-2 logarithm.

\<close>

fun lg :: "nat \<Rightarrow> nat" where
[simp del]: "lg x = (if x \<le> 1 then 0 else 1 + lg (x div 2))"

lemma lg_safe:
  "lg 0 = 0"
  "lg (Suc 0) = 0"
  "lg (Suc (Suc 0)) = 1"
  "0 < x \<Longrightarrow> lg (x + x) = 1 + lg x"
by (simp_all add: lg.simps)

lemma lg_inv:
  "0 < x \<Longrightarrow> lg (2 ^ x) = x"
proof(induct x)
  case (Suc x) then show ?case
    by (cases x, simp_all add: lg.simps Suc_lessI not_le)
qed simp

lemma lg_inv2:
  \<open>2 ^ lg x = x\<close> if \<open>2 ^ i = x\<close> for x
proof -
  have \<open>2 ^ lg (2 ^ i) = (2::nat) ^ i\<close>
    by (induction i) (simp_all add: lg_safe mult_2)
  with that show ?thesis
    by simp
qed

lemmas lg_simps = lg_safe lg_inv lg_inv2

subsection\<open> Finding \<open>lambda\<close> \<close>

text (in properties) \<open>

Imagine now that the Tortoise carries an unbounded number of carrots,
which he passes to the Hare when they meet, and the Hare has a
teleporter. The Hare eats a carrot each time she waits for the
function @{term "f"} to execute, and initially has just one. If she
runs out of carrots before meeting the Tortoise again, she teleports
him to her position, and he gives her twice as many carrots as the
last time they met (tracked by the variable \<open>carrots\<close>). By
counting how many carrots she has eaten from when she last teleported
the Tortoise (recorded in \<open>l\<close>) until she finally has surplus
carrots when she meets him again, the Hare directly discovers @{term
"lambda"}.

\<close>

record 'a state =
  m :: nat  \<comment> \<open>\<open>\<mu>\<close>\<close>
  l :: nat  \<comment> \<open>\<open>\<lambda>\<close>\<close>
  carrots :: nat
  hare :: "'a"
  tortoise :: "'a"

context properties
begin

definition (in fx0) find_lambda :: "'a state \<Rightarrow> 'a state" where
  "find_lambda \<equiv>
    (\<lambda>s. s\<lparr> carrots := 1, l := 1, tortoise := x0, hare := f x0 \<rparr>) ;;
    while (hare \<^bold>\<noteq> tortoise)
          ( ( \<^bold>if carrots \<^bold>= l \<^bold>then (\<lambda>s. s\<lparr> tortoise := hare s, carrots := 2 * carrots s, l := 0 \<rparr>)
                             \<^bold>else SKIP ) ;;
            (\<lambda>s. s\<lparr> hare := f (hare s), l := l s + 1 \<rparr>) )"

text\<open>

The termination argument goes intuitively as follows. The Hare eats as
many carrots as it takes to teleport the Tortoise into the
loop. Afterwards she continues the teleportation dance until the
Tortoise has given her enough carrots to make it all the way around
the loop and back to him.

We can calculate the Tortoise's position as a function of \<open>carrots\<close>.

\<close>

definition carrots_total :: "nat \<Rightarrow> nat" where
  "carrots_total c \<equiv> \<Sum>i<lg c. 2 ^ i"

lemma carrots_total_simps:
  "carrots_total (Suc 0) = 0"
  "carrots_total (Suc (Suc 0)) = 1"
  "2 ^ i = c \<Longrightarrow> carrots_total (c + c) = c + carrots_total c"
by (auto simp: carrots_total_def lg_simps)

definition find_lambda_measures :: "( (nat \<times> nat) \<times> (nat \<times> nat) ) set" where
  "find_lambda_measures \<equiv>
    measures [\<lambda>(l, c). mu - carrots_total c,
              \<lambda>(l, c). LEAST i. lambda \<le> c * 2^i,
              \<lambda>(l, c). c - l]"

lemma find_lambda_measures_wellfounded:
  "wf find_lambda_measures"
by (simp add: find_lambda_measures_def)

lemma find_lambda_measures_decreases1:
  assumes "c = 2 ^ i"
  assumes "mu \<le> carrots_total c \<longrightarrow> c \<le> lambda"
  assumes "seq (carrots_total c) \<noteq> seq (carrots_total c + c)"
  shows "( (c', 2 * c), (c, c) ) \<in> find_lambda_measures"
proof(cases "mu \<le> carrots_total c")
  case False with assms show ?thesis
    by (auto simp: find_lambda_measures_def carrots_total_simps mult_2 field_simps diff_less_mono2)
next
  case True
  { fix x assume x: "(0::nat) < x" have "\<exists>n. lambda \<le> x * 2 ^ n"
    proof(induct lambda)
      case (Suc i)
      then obtain n where "i \<le> x * 2 ^ n" by blast
      with x show ?case
        by (clarsimp intro!: exI[where x="Suc n"] simp: field_simps mult_2)
           (metis Nat.add_0_right Suc_leI linorder_neqE_nat mult_eq_0_iff add_left_cancel not_le numeral_2_eq_2 old.nat.distinct(2) power_not_zero trans_le_add2)
    qed simp } note ex = this
  have "(LEAST j. lambda \<le> 2 ^ (i + 1) * 2 ^ j) < (LEAST j. lambda \<le> 2 ^ i * 2 ^ j)"
  proof(rule LeastI2_wellorder_ex[OF ex, rotated], rule LeastI2_wellorder_ex[OF ex, rotated])
    fix x y
    assume "lambda \<le> 2 ^ i * 2 ^ y"
           "lambda \<le> 2 ^ (i + 1) * 2 ^ x"
           "\<forall>z. lambda \<le> 2 ^ (i + 1) * 2 ^ z \<longrightarrow> x \<le> z"
    with True assms properties_loop[where i="carrots_total c" and j=1]
    show "x < y" by (cases y, auto simp: less_Suc_eq_le)
  qed simp_all
  with True \<open>c = 2 ^ i\<close> show ?thesis
    by (clarsimp simp: find_lambda_measures_def mult_2 carrots_total_simps field_simps power_add)
qed

lemma find_lambda_measures_decreases2:
  assumes "ls < c"
  shows "( (Suc ls, c), (ls, c) ) \<in> find_lambda_measures"
using assms by (simp add: find_lambda_measures_def)

lemma find_lambda:
  "\<lbrace>\<langle>True\<rangle>\<rbrace> find_lambda \<lbrace>l \<^bold>= \<langle>lambda\<rangle>\<rbrace>"
apply (simp add: find_lambda_def)
apply (rule hoare_pre)
apply (rule whileI[where I="\<langle>0\<rangle> \<^bold>< l \<^bold>\<and> l \<^bold>\<le> carrots \<^bold>\<and> (\<langle>mu\<rangle> \<^bold>\<le> carrots_total \<circ> carrots \<^bold>\<longrightarrow> l \<^bold>\<le> \<langle>lambda\<rangle>) \<^bold>\<and> (\<^bold>\<exists>i. carrots \<^bold>= \<langle>2^i\<rangle>)
                           \<^bold>\<and> tortoise \<^bold>= seq \<circ> carrots_total \<circ> carrots \<^bold>\<and> hare \<^bold>= seq \<circ> (l \<^bold>+ (carrots_total \<circ> carrots))"
                      and r="inv_image find_lambda_measures (l \<^bold>\<bowtie> carrots)"]
            wp_intro)+
   using properties_lambda_gt_0
   apply (clarsimp simp: field_simps mult_2_right carrots_total_simps)
   apply (intro conjI impI)
      apply (metis mult_2 power_Suc)
     apply (case_tac "mu \<le> carrots_total (l s)")
      apply (cut_tac i="carrots_total (l s)" and j="l s" in properties_distinct_contrapos, simp_all add: field_simps)[1]
     apply (cut_tac i="carrots_total (l s)" and j="l s" in properties_loops_ge_mu, simp_all add: field_simps)[1]
    apply (cut_tac i="carrots_total (2 ^ x)" and j=1 in properties_loop, simp)
    apply (fastforce simp: le_eq_less_or_eq field_simps)
   apply (cut_tac i="carrots_total (2 ^ x)" and j="l s" in properties_loops_ge_mu, simp_all add: field_simps)[1]
   apply (cut_tac i="carrots_total (2 ^ x)" and j="l s" in properties_distinct_contrapos, simp_all add: field_simps)[1]
  apply (simp add: find_lambda_measures_wellfounded)
 apply (clarsimp simp: add.commute find_lambda_measures_decreases1 find_lambda_measures_decreases2)
apply (rule wp_intro)
using properties_lambda_gt_0
apply (simp add: carrots_total_simps exI[where x=0])
done

subsection\<open> Finding \<open>mu\<close> \<close>

text\<open>

With @{term "lambda"} in hand, we can find \<open>mu\<close> using the same
approach as for the Tortoise and Hare (\S\ref{sec:th-finding-mu}),
after we first move the Hare to @{term "lambda"}.

\<close>

definition (in fx0) find_mu :: "'a state \<Rightarrow> 'a state" where
  "find_mu \<equiv>
    (\<lambda>s. s\<lparr> m := 0, tortoise := x0, hare := seq (l s) \<rparr>) ;;
    while (hare \<^bold>\<noteq> tortoise)
          (\<lambda>s. s\<lparr> tortoise := f (tortoise s), hare := f (hare s), m := m s + 1 \<rparr>)"

lemma find_mu:
  "\<lbrace>l \<^bold>= \<langle>lambda\<rangle>\<rbrace> find_mu \<lbrace>l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>\<rbrace>"
apply (simp add: find_mu_def)
apply (rule hoare_pre)
apply (rule whileI[where I="l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>\<le> \<langle>mu\<rangle> \<^bold>\<and> tortoise \<^bold>= seq \<circ> m \<^bold>\<and> hare \<^bold>= seq \<circ> (m \<^bold>+ l)"
                      and r="measure (\<langle>mu\<rangle> \<^bold>- m)"]
            wp_intro)+
   using properties_lambda_gt_0 properties_loop[where i=mu and j=1]
   apply (fastforce simp: le_less dest: properties_loops_ge_mu)
  apply simp
 using properties_loop[where i=mu and j=1, simplified]
 apply (fastforce simp: le_eq_less_or_eq)
apply (rule wp_intro)
apply simp
done

subsection\<open> Top level \<close>

definition (in fx0) brent :: "'a state \<Rightarrow> 'a state" where
  "brent \<equiv> find_lambda ;; find_mu"

theorem brent:
  "\<lbrace>\<langle>True\<rangle>\<rbrace> brent \<lbrace>l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>\<rbrace>"
unfolding brent_def
by (rule find_lambda find_mu wp_intro)+

end

corollary brent_correct:
  assumes s': "s' = fx0.brent f x arbitrary"
  shows "fx0.properties f x (l s') (m s')"
using assms properties.brent[where f=f and ?x0.0=x]
by (fastforce intro: fx0.properties_existence[where f=f and ?x0.0=x]
               simp:  Basis.properties_def valid_def)

schematic_goal brent_code[code]:
  "fx0.brent f x = ?code"
unfolding fx0.brent_def fx0.find_lambda_def fx0.find_mu_def fcomp_assoc[symmetric] fcomp_comp
by (rule refl)

export_code fx0.brent in SML
(*<*)

end
(*>*)


(*
  Title: Lucas_Theorem.thy
  Author: Chelsea Edmonds, University of Cambridge
*)

theory Lucas_Theorem
  imports Main "HOL-Computational_Algebra.Computational_Algebra"
begin

notation fps_nth (infixl "$" 75)

section \<open>Extensions on Formal Power Series (FPS) Library\<close>

text \<open>This section presents a few extensions on the Formal Power Series (FPS) library, described in \cite{Chaieb2011} \<close>

subsection \<open>FPS Equivalence Relation \<close>

text \<open> This proof requires reasoning around the equivalence of coefficients mod some prime number.
This section defines an equivalence relation on FPS using the pattern described by Paulson
in \cite{paulsonDefiningFunctionsEquivalence2006}, as well as some basic lemmas for reasoning around
how the equivalence holds after common operations are applied \<close>

definition "fpsmodrel p \<equiv> { (f, g). \<forall> n. (f $ n) mod p = (g $ n) mod p }"

lemma fpsrel_iff [simp]: "(f, g) \<in> fpsmodrel p \<longleftrightarrow> (\<forall>n. (f $ n) mod p = (g $ n) mod p)"
  by (simp add: fpsmodrel_def)

lemma fps_equiv: "equiv UNIV (fpsmodrel p)"
proof (rule equivI)
  show "refl (fpsmodrel p)" by (simp add: refl_on_def fpsmodrel_def)
  show "sym (fpsmodrel p)" by (simp add: sym_def fpsmodrel_def)
  show "trans (fpsmodrel p)" by (intro transI) (simp add: fpsmodrel_def)
qed

text \<open> Equivalence relation over multiplication \<close>

lemma fps_mult_equiv_coeff:
  fixes f g :: "('a :: {euclidean_ring_cancel}) fps"
  assumes "(f, g) \<in> fpsmodrel p"
  shows "(f*h)$n mod p = (g*h)$n mod p"
proof -
  have "((f*h) $ n) mod p =(\<Sum>i=0..n. (f$i mod p * h$(n - i) mod p) mod p) mod p"
    using mod_sum_eq mod_mult_left_eq
    by (simp add: fps_mult_nth mod_sum_eq mod_mult_left_eq)
  also have "... = (\<Sum>i=0..n. (g$i mod p * h$(n - i) mod p) mod p) mod p"
    using assms by auto
  also have "... = ((g*h) $ n) mod p"
    by (simp add: mod_mult_left_eq mod_sum_eq fps_mult_nth)
  thus ?thesis by (simp add: calculation)
qed

lemma fps_mult_equiv:
  fixes f g :: "('a :: {euclidean_ring_cancel}) fps"
  assumes "(f, g) \<in> fpsmodrel p"
  shows "(f*h, g*h) \<in> fpsmodrel p"
  using fpsmodrel_def fps_mult_equiv_coeff assms by blast

text \<open> Equivalence relation over power operator \<close>
lemma fps_power_equiv:
  fixes f g :: "('a :: {euclidean_ring_cancel}) fps"
  fixes x :: nat
  assumes "(f, g) \<in> fpsmodrel p"
  shows "(f^x, g^x) \<in> fpsmodrel p"
  using assms
proof (induct x)
  case 0
  thus ?case by (simp add: fpsmodrel_def)
next
  case (Suc x)
  then have hyp: " \<forall>n. f^x $ n mod p = g ^x $ n mod p"
    using fpsrel_iff by blast
  thus ?case
  proof -
    have fact: "\<forall>n h. (g * h) $ n mod p = (f * h) $ n mod p"
      by (metis assms fps_mult_equiv_coeff)
    have "\<forall>n h. (g ^ x * h) $ n mod p = (f ^ x * h) $ n mod p"
      by (simp add: fps_mult_equiv_coeff hyp)
    then have "\<forall>n h. (h * g ^ x) $ n mod p = (h * f ^ x) $ n mod p"
      by (simp add: mult.commute)
    thus ?thesis
      using fact by force
  qed
qed

subsection \<open>Binomial Coefficients \<close>

text \<open>The @{term "fps_binomial"} definition in the formal power series uses the @{term "n gchoose k"} operator. It's
defined as being of type @{typ "'a :: field_char_0 fps"}, however the equivalence relation requires a type @{typ 'a}
that supports the modulo operator.
The proof of the binomial theorem based on FPS coefficients below uses the choose operator and does
not put bounds on the type of @{term "fps_X"}.\<close>

lemma binomial_coeffs_induct:
  fixes n k :: nat
  shows "(1 + fps_X)^n $ k = of_nat(n choose k)"
proof (induct n arbitrary: k)
  case 0
  thus ?case
    by (metis binomial_eq_0_iff binomial_n_0 fps_nth_of_nat not_gr_zero of_nat_0 of_nat_1 power_0)
next
  case h: (Suc n)
  fix k
  have start: "(1 + fps_X)^(n + 1) = (1 + fps_X) * (1 + fps_X)^n" by auto
  show ?case
    using One_nat_def Suc_eq_plus1 Suc_pred add.commute binomial_Suc_Suc binomial_n_0
        fps_mult_fps_X_plus_1_nth h.hyps neq0_conv start by (smt of_nat_add)
qed

subsection \<open>Freshman's Dream Lemma on FPS \<close>
text \<open> The Freshman's dream lemma modulo a prime number $p$ is a well known proof that $(1 + x^p) \equiv (1 + x)^p \mod p$\<close>

text \<open> First prove that $\binom{p^n}{k} \equiv 0 \mod p$ for $k \ge 1$ and $k < p^n$. The eventual
proof only ended up requiring this with $n = 1$\<close>

lemma pn_choose_k_modp_0:
  fixes n k::nat
  assumes "prime p"
          "k \<ge> 1 \<and> k \<le> p^n - 1"
          "n > 0"
  shows "(p^n choose k) mod p = 0"
proof -
  have inequality: "k \<le> p^n" using assms (2) by arith
  have choose_take_1: "((p^n - 1) choose ( k - 1))= fact (p^n - 1) div (fact (k - 1) * fact (p^n - k))"
    using binomial_altdef_nat diff_le_mono inequality assms(2) by auto
  have "k * (p^n choose k) = k * ((fact (p^n)) div (fact k * fact((p^n) - k)))"
    using assms binomial_fact'[OF inequality] by auto
  also have "... = k * fact (p^n) div (fact k * fact((p^n) - k))"
    using binomial_fact_lemma div_mult_self_is_m fact_gt_zero inequality mult.assoc mult.commute
          nat_0_less_mult_iff by smt
  also have "... = k * fact (p^n) div (k * fact (k - 1) * fact((p^n) - k))"
    by (metis assms(2) fact_nonzero fact_num_eq_if le0 le_antisym of_nat_id)
  also have "... = fact (p^n) div (fact (k - 1) * fact((p^n) - k))"
    using assms by auto
  also have "... = ((p^n) * fact (p^n - 1)) div (fact (k - 1) * fact((p^n) - k))"
    by (metis assms(2) fact_nonzero fact_num_eq_if inequality le0 le_antisym of_nat_id)
  also have "... = (p^n) * (fact (p^n - 1) div (fact (k - 1) * fact((p^n) - k)))"
    by (metis assms(2) calculation choose_take_1 neq0_conv not_one_le_zero times_binomial_minus1_eq)
  finally have equality: "k * (p^n choose k) = p^n * ((p^n - 1) choose (k - 1))"
    using assms(2) times_binomial_minus1_eq by auto
  then have dvd_result: "p^n dvd (k * (p^n choose k))" by simp
  have "\<not> (p^n dvd k)"
    using assms (2) binomial_n_0 diff_diff_cancel nat_dvd_not_less neq0_conv by auto
  then have "p dvd (p^n choose k)"
    using mult.commute prime_imp_prime_elem prime_power_dvd_multD assms dvd_result by metis
  thus "?thesis" by simp
qed

text \<open> Applying the above lemma to the coefficients of $(1 + X)^p$, it is easy to show that all
coefficients other than the $0$th and $p$th will be $0$ \<close>

lemma fps_middle_coeffs:
  assumes "prime p"
          "n \<noteq> 0 \<and> n \<noteq> p"
  shows "((1 + fps_X :: int fps) ^p) $ n mod p = 0 mod p"
proof -
  let ?f = "(1 + fps_X :: int fps)^p"
  have "\<forall> n. n > 0 \<and> n < p \<longrightarrow> (p choose n) mod p = 0" using pn_choose_k_modp_0
    by (metis (no_types, lifting) add_le_imp_le_diff assms(1) diff_diff_cancel diff_is_0_eq'
        discrete le_add_diff_inverse le_numeral_extra(4) power_one_right zero_le_one zero_less_one)
  then have middle_0: "\<forall> n. n > 0 \<and> n < p \<longrightarrow> (?f $ n) mod p = 0"
    using binomial_coeffs_induct by (metis of_nat_0 zmod_int)
  have "\<forall> n. n > p \<longrightarrow> ?f $ n mod p = 0"
    using binomial_eq_0_iff binomial_coeffs_induct mod_0 by (metis of_nat_eq_0_iff)
  thus ?thesis using middle_0 assms(2) nat_neq_iff by auto
qed

text \<open>It follows that $(1+ X)^p$ is equivalent to $(1 + X^p)$ under our equivalence relation,
as required to prove the freshmans dream lemma. \<close>

lemma fps_freshmans_dream:
  assumes "prime p"
  shows "(((1 + fps_X :: int fps ) ^p), (1 + (fps_X)^(p))) \<in> fpsmodrel p"
proof -
  let ?f = "(1 + fps_X :: int fps)^p"
  let ?g = "(1 + (fps_X :: int fps)^p)"
  have all_f_coeffs: "\<forall> n. n \<noteq> 0 \<and> n \<noteq> p \<longrightarrow> ?f $ n mod p = 0 mod p"
    using fps_middle_coeffs assms by blast
  have "?g $ 0 = 1" using assms by auto
  then have "?g $ 0 mod p = 1 mod p"
    using int_ops(2) zmod_int assms by presburger
  then have "?g $ p mod p = 1 mod p" using assms by auto
  then have "\<forall> n . ?f $ n mod p = ?g $ n mod p"
    using all_f_coeffs by (simp add: binomial_coeffs_induct)
  thus ?thesis using fpsrel_iff by blast
qed

section \<open>Lucas's Theorem Proof\<close>

text \<open>A formalisation of Lucas's theorem based on a generating function proof using the existing formal power series (FPS) Isabelle library\<close>

subsection \<open>Reasoning about Coefficients Helpers\<close>

text \<open>A generating function proof of Lucas's theorem relies on direct comparison between coefficients of FPS which requires a number
of helper lemmas to prove formally. In particular it compares the coefficients of
$(1 + X)^n \mod p$ to $(1 + X^p)^N * (1 + X) ^rn \mod p$, where $N = n / p$, and $rn = n \mod p$.
This section proves that the $k$th coefficient of $(1 + X^p)^N * (1 + X) ^rn = (N choose K) * (rn choose rk)$\<close>

text \<open>Applying the @{term "fps_compose"} operator enables reasoning about the coefficients of $(1 + X^p)^n$
using the existing binomial theorem proof with $X^p$ instead of $X$.\<close>

lemma fps_binomial_p_compose:
  assumes "p \<noteq> 0"
  shows "(1 + (fps_X:: ('a :: {idom} fps))^p)^n = ((1 + fps_X)^n) oo (fps_X^p)"
proof -
  have "(1::'a fps) + fps_X ^ p = 1 + fps_X oo fps_X ^ p"
    by (simp add: assms fps_compose_add_distrib)
  then show ?thesis
    by (simp add: assms fps_compose_power)
qed

text \<open> Next the proof determines the value of the $k$th coefficient of $(1 + X^p)^N$. \<close>

lemma fps_X_pow_binomial_coeffs:
  assumes "prime p"
  shows "(1 + (fps_X ::int fps)^p)^N $k = (if p dvd k then (N choose (k div p)) else 0)"
proof -
  let ?fx = "(fps_X :: int fps)"
  have "(1 + ?fx^p)^N $ k  = (((1 + ?fx)^N) oo (?fx^p)) $k"
    by (metis assms fps_binomial_p_compose not_prime_0)
  also have "... = (\<Sum>i=0..k.((1 + ?fx)^N)$i * ((?fx^p)^i$k))"
    by (simp add: fps_compose_nth)
  finally have coeffs: "(1 + ?fx^p)^N $ k = (\<Sum>i=0..k. (N choose i) * ((?fx^(p*i))$k))"
    using binomial_coeffs_induct sum.cong by (metis (no_types, lifting) power_mult)
  thus ?thesis
  proof (cases "p dvd k")
    case False \<comment> \<open>$p$ does not divide $k$ implies the $k$th term has a coefficient of 0\<close>
    have "\<forall> i. \<not>(p dvd k) \<longrightarrow> (?fx^(p*i)) $ k = 0"
      by auto
    thus ?thesis using coeffs by (simp add: False)
  next
    case True \<comment> \<open>$p$ divides $k$ implies the $k$th term has a non-zero coefficient\<close>
    have contained: "k div p \<in> {0.. k}" by simp
    have "\<forall> i. i \<noteq> k div p \<longrightarrow> (?fx^(p*i)) $ k = 0" using assms by auto
    then have notdivpis0: "\<forall> i \<in> ({0 .. k} - {k div p}). (?fx^(p*i)) $ k = 0" by simp
    have "(1 + ?fx^p)^N $ k = (N choose (k div p)) * (?fx^(p * (k div p))) $ k + (\<Sum>i\<in>({0..k} -{k div p}). (N choose i) * ((?fx^(p*i))$k))"
      using contained coeffs sum.remove by (metis (no_types, lifting) finite_atLeastAtMost)
    thus ?thesis using notdivpis0 True by simp
  qed
qed

text \<open> The final helper lemma proves the $k$th coefficient is equivalent to $\binom{?N}{?K}*\binom{?rn}{?rk}$ as required.\<close>
lemma fps_div_rep_coeffs:
  assumes "prime p"
  shows "((1 + (fps_X::int fps)^p)^(n div p) * (1 + fps_X)^(n mod p)) $ k =
          ((n div p) choose (k div p)) * ((n mod p) choose (k mod p))"
    (is "((1 + (fps_X::int fps)^p)^?N * (1 + fps_X)^?rn) $ k = (?N choose ?K) * (?rn choose ?rk)")
proof -
  \<comment> \<open>Initial facts with results around representation and 0 valued terms\<close>
  let ?fx = "fps_X :: int fps"
  have krep: "k - ?rk = ?K*p"
    by (simp add: minus_mod_eq_mult_div)
  have rk_in_range: "?rk \<in> {0..k}" by simp
  have "\<forall> i \<ge> p. (?rn choose i) = 0"
    using binomial_eq_0_iff
    by (metis assms(1) leD le_less_trans linorder_cases mod_le_divisor mod_less_divisor prime_gt_0_nat)
  then have ptok0: "\<forall> i \<in> {p..k}. ((?rn choose i) * (1 + ?fx^p)^?N $ (k - i)) = 0"
    by simp
  then have notrkis0: "\<forall>i \<in> {0.. k}. i \<noteq> ?rk \<longrightarrow> (?rn choose i) * (1 + ?fx^p)^?N $ (k - i) = 0"
  proof (cases "k < p")
    case True \<comment> \<open>When $k < p$, it presents a side case with regards to range of reasoning\<close>
    then have k_value: "k = ?rk" by simp
    then have "\<forall> i < k. \<not> (p dvd (k - i))"
       using True by (metis diff_diff_cancel diff_is_0_eq dvd_imp_mod_0 less_imp_diff_less less_irrefl_nat mod_less)
    then show ?thesis using fps_X_pow_binomial_coeffs assms(1) k_value by simp
  next
    case False
    then have "\<forall> i < p. i \<noteq> ?rk \<longrightarrow> \<not>(p dvd (k - i))"
      using mod_nat_eqI by auto
    then have "\<forall> i \<in> {0..<p}. i \<noteq> ?rk \<longrightarrow> (1 + ?fx^p)^?N $ (k - i) = 0"
      using assms fps_X_pow_binomial_coeffs by simp
    then show ?thesis using ptok0 by auto
  qed
  \<comment> \<open>Main body of the proof, using helper facts above\<close>
  have "((1 + fps_X^p)^?N * (1 + fps_X)^?rn) $ k = (((1 + fps_X)^?rn) * (1 + fps_X^p)^?N) $ k"
    by (metis (no_types, hide_lams) distrib_left distrib_right fps_mult_fps_X_commute fps_one_mult(1)
        fps_one_mult(2) power_commuting_commutes)
  also have "... = (\<Sum>i=0..k.(of_nat(?rn choose i)) * ((1 + (fps_X)^p)^?N $ (k - i)))"
    by (simp add: fps_mult_nth binomial_coeffs_induct)
  also have "... =  ((?rn choose ?rk) * (1 + ?fx^p)^?N $ (k - ?rk)) + (\<Sum>i\<in>({0..k} - {?rk}). (?rn choose i) * (1 + ?fx^p)^?N $ (k - i))"
    using rk_in_range sum.remove by (metis (no_types, lifting) finite_atLeastAtMost)
  finally have "((1 + ?fx^p)^?N * (1 + ?fx)^?rn) $ k = ((?rn choose ?rk) * (1 + ?fx^p)^?N $ (k - ?rk))"
    using notrkis0 by simp
  thus ?thesis using fps_X_pow_binomial_coeffs assms krep by auto
qed

(* Lucas theorem proof *)
subsection \<open>Lucas Theorem Proof\<close>

text \<open> The proof of Lucas's theorem combines a generating function approach, based off \cite{Fine} with induction.
For formalisation purposes, it was easier to first prove a well known corollary of the main theorem (also
often presented as an alternative statement for Lucas's theorem), which can itself be used to backwards
prove the the original statement by induction.
This approach was adapted from P. Cameron's lecture notes on combinatorics \cite{petercameronNotesCombinatorics2007} \<close>

subsubsection \<open> Proof of the Corollary \<close>
text \<open> This step makes use of the coefficient equivalence arguments proved in the previous sections \<close>
corollary lucas_corollary:
  fixes n k :: nat
  assumes "prime p"
  shows "(n choose k) mod p = (((n div p) choose (k div p)) * ((n mod p) choose (k mod p))) mod p"
    (is "(n choose k) mod p = ((?N choose ?K) * (?rn choose ?rk)) mod p")
proof -
  let ?fx = "fps_X :: int fps"
  have n_rep: "n = ?N * p  + ?rn"
    by simp
  have k_rep: "k =?K * p + ?rk" by simp
  have rhs_coeffs: "((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn)) $ k = (?N choose ?K) * (?rn choose ?rk)"
    using assms fps_div_rep_coeffs k_rep n_rep by blast \<comment> \<open>Application of coefficient reasoning\<close>
  have "((((1 + ?fx)^p)^(?N) * (1 + ?fx)^(?rn)),
          ((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn))) \<in> fpsmodrel p"
    using fps_freshmans_dream assms fps_mult_equiv fps_power_equiv by blast \<comment> \<open>Application of equivalence facts and freshmans dream lemma\<close>
  then have modrel2: "((1 + ?fx)^n, ((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn)))
                          \<in> fpsmodrel p"
    by (metis (mono_tags, hide_lams) mult_div_mod_eq power_add power_mult)
  thus ?thesis
    using fpsrel_iff binomial_coeffs_induct rhs_coeffs by (metis of_nat_eq_iff zmod_int)
qed

subsubsection \<open> Proof of the Theorem \<close>

text \<open>The theorem statement requires a formalised way of referring to the base $p$ representation of a number.
We use a definition that specifies the $i$th digit of the base $p$ representation. This definition is originally
from the Hilbert's 10th Problem Formalisation project \cite{bayerDPRMTheoremIsabelle2019} which this work contributes to.\<close>
definition nth_digit_general :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nth_digit_general num i base = (num div (base ^ i)) mod base"

text \<open>Applying induction on $d$, where $d$ is the highest power required in either $n$ or $k$'s base $p$
representation, @{thm lucas_corollary} can be used to prove the original theorem.\<close>

theorem lucas_theorem:
  fixes n k d::nat
assumes "n < p ^ (Suc d)"
assumes "k < p ^ (Suc d)"
assumes "prime p"
shows "(n choose k) mod p = (\<Prod>i\<le>d. ((nth_digit_general n i p) choose (nth_digit_general k i p))) mod p"
  using assms
proof (induct d arbitrary: n k)
  case 0
  thus ?case using nth_digit_general_def assms by simp
next
  case (Suc d)
  \<comment> \<open>Representation Variables\<close>
  let ?N = "n div p"
  let ?K = "k div p"
  let ?nr = "n mod p"
  let ?kr = "k mod p"
  \<comment> \<open>Required assumption facts\<close>
  have Mlessthan: "?N < p ^ (Suc d)"
    using less_mult_imp_div_less power_Suc2 assms(3) prime_ge_2_nat Suc.prems(1) by metis
  have Nlessthan: "?K < p ^ (Suc d)"
    using less_mult_imp_div_less power_Suc2 prime_ge_2_nat Suc.prems(2) assms(3) by metis
  have shift_bounds_fact: "(\<Prod>i=(Suc 0)..(Suc (d )). ((nth_digit_general n i p) choose (nth_digit_general k i p))) =
                            (\<Prod>i=0..(d).  (nth_digit_general n (Suc i) p) choose (nth_digit_general k (Suc i) p))"
    using prod.shift_bounds_cl_Suc_ivl by blast \<comment> \<open>Product manipulation helper fact\<close>
  have "(n choose k ) mod p = ((?N choose ?K) * (?nr choose ?kr)) mod p"
    using lucas_corollary assms(3) by blast \<comment> \<open>Application of corollary\<close>
  also have "...= ((\<Prod>i\<le>d. ((nth_digit_general ?N i p) choose (nth_digit_general ?K i p))) * (?nr choose ?kr)) mod p"
    using Mlessthan Nlessthan Suc.hyps mod_mult_cong assms(3) by blast \<comment> \<open>Using Inductive Hypothesis\<close>
  \<comment> \<open>Product manipulation steps\<close>
  also have "... = ((\<Prod>i=0..(d). (nth_digit_general n (Suc i) p) choose (nth_digit_general k (Suc i) p)) * (?nr choose ?kr)) mod p"
    using  atMost_atLeast0 nth_digit_general_def div_mult2_eq by auto
  also have "... = ((\<Prod>i=1..(d+1). (nth_digit_general n i p) choose (nth_digit_general k i p)) *
                            ((nth_digit_general n 0 p) choose (nth_digit_general k 0 p))) mod p"
    using nth_digit_general_def shift_bounds_fact by simp
  finally have "(n choose k ) mod p = ((\<Prod>i=0..(d+1). (nth_digit_general n i p) choose (nth_digit_general k i p))) mod p"
    using One_nat_def atMost_atLeast0 mult.commute prod.atLeast1_atMost_eq prod.atMost_shift
    by (smt Suc_eq_plus1 shift_bounds_fact)
  thus ?case
    using Suc_eq_plus1 atMost_atLeast0 by presburger
qed

end