theory Girth_Chromatic
imports
  Ugraphs
  Girth_Chromatic_Misc
  "~~/src/HOL/Probability/Probability"

  "~~/src/HOL/Number_Theory/Binomial"
  "~~/src/HOL/Decision_Procs/Approximation"
begin

section {* Probability Space on Sets of Edges *}

definition cylinder :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set set" where
  "cylinder S A B = {T \<in> Pow S. A \<subseteq> T \<and> B \<inter> T = {}}"

lemma full_sum:
  fixes p :: real
  assumes "finite S"
  shows "(\<Sum>A\<in>Pow S. p^card A * (1 - p)^card (S - A)) = 1"
using assms
proof induct
  case (insert s S)
  have "inj_on (insert s) (Pow S)"
      and "\<And>x. S - insert s x = S - x"
      and "Pow S \<inter> insert s ` Pow S = {}"
      and "\<And>x. x \<in> Pow S \<Longrightarrow> card (insert s S - x) = Suc (card (S - x))"
    using insert(1-2) by (auto simp: insert_Diff_if intro!: inj_onI)
  moreover have "\<And>x. x \<subseteq> S \<Longrightarrow> card (insert s x) = Suc (card x)"
    using insert(1-2) by (subst card.insert) (auto dest: finite_subset)
  ultimately show ?case
    by (simp add: setsum.reindex setsum_right_distrib[symmetric] ac_simps
                  insert.hyps setsum.union_disjoint Pow_insert)
qed simp

text {* Definition of the probability space on edges: *}
locale edge_space =
  fixes n :: nat and p :: real
  assumes p_prob: "0 \<le> p" "p \<le> 1"
begin

definition S_verts :: "nat set" where
  "S_verts \<equiv> {1..n}"

definition S_edges :: "uedge set" where
  "S_edges = all_edges S_verts"

definition edge_ugraph :: "uedge set \<Rightarrow> ugraph" where
  "edge_ugraph es \<equiv> (S_verts, es \<inter> S_edges)"

definition "P = point_measure (Pow S_edges) (\<lambda>s. p^card s * (1 - p)^card (S_edges - s))"

lemma finite_verts[intro!]: "finite S_verts"
  by (auto simp: S_verts_def)

lemma finite_edges[intro!]: "finite S_edges"
  by (auto simp: S_edges_def all_edges_def finite_verts)

lemma finite_graph[intro!]: "finite (uverts (edge_ugraph es))"
  unfolding edge_ugraph_def by auto

lemma uverts_edge_ugraph[simp]: "uverts (edge_ugraph es) = S_verts"
  by (simp add: edge_ugraph_def)

lemma uedges_edge_ugraph[simp]: "uedges (edge_ugraph es) = es \<inter> S_edges"
  unfolding edge_ugraph_def by simp

lemma space_eq: "space P = Pow S_edges" by (simp add: P_def space_point_measure)

lemma sets_eq: "sets P = Pow (Pow S_edges)" by (simp add: P_def sets_point_measure)

lemma emeasure_eq:
  "emeasure P A = (if A \<subseteq> Pow S_edges then (\<Sum>edges\<in>A. p^card edges * (1 - p)^card (S_edges - edges)) else 0)"
  using finite_edges p_prob
  by (simp add: P_def space_point_measure emeasure_point_measure_finite zero_le_mult_iff
                zero_le_power_iff sets_point_measure emeasure_notin_sets)

lemma integrable_P[intro, simp]: "integrable P (f::_ \<Rightarrow> real)"
  using finite_edges by (simp add: integrable_point_measure_finite P_def)

lemma borel_measurable_P[measurable]: "f \<in> borel_measurable P"
  unfolding P_def by simp

lemma prob_space_P: "prob_space P"
proof
  show "emeasure P (space P) = 1" -- {* Sum of probabilities equals 1 *}
    using finite_edges by (simp add: emeasure_eq full_sum one_ereal_def space_eq)
qed

end

sublocale edge_space \<subseteq> prob_space P
  by (rule prob_space_P)

context edge_space
begin

lemma prob_eq:
  "prob A = (if A \<subseteq> Pow S_edges then (\<Sum>edges\<in>A. p^card edges * (1 - p)^card (S_edges - edges)) else 0)"
  using emeasure_eq[of A] unfolding emeasure_eq_measure by simp

lemma integral_finite_singleton: "integral\<^sup>L P f = (\<Sum>x\<in>Pow S_edges. f x * measure P {x})"
  using p_prob prob_eq unfolding P_def
  by (subst lebesgue_integral_point_measure_finite) (auto intro!: setsum.cong)

text {* Probability of cylinder sets: *}
lemma cylinder_prob:
  assumes "A \<subseteq> S_edges" "B \<subseteq> S_edges" "A \<inter> B = {}"
  shows "prob (cylinder S_edges A B) = p ^ (card A) * (1 - p) ^ (card B)" (is "_ = ?pp A B")
proof -
  have "Pow S_edges \<inter> cylinder S_edges A B = cylinder S_edges A B"
       "\<And>x. x \<in> cylinder S_edges A B \<Longrightarrow> A \<union> x = x"
       "\<And>x. x \<in> cylinder S_edges A B \<Longrightarrow> finite x"
       "\<And>x. x \<in> cylinder S_edges A B \<Longrightarrow> B \<inter> (S_edges - B - x) = {}"
       "\<And>x. x \<in> cylinder S_edges A B \<Longrightarrow> B \<union> (S_edges - B - x) = S_edges - x"
       "finite A" "finite B"
    using assms by (auto simp add: cylinder_def intro: finite_subset)
  then have "(\<Sum>T\<in>cylinder S_edges A B. ?pp T (S_edges - T))
      = (\<Sum>T \<in> cylinder S_edges A B. p^(card A + card (T - A)) * (1 - p)^(card B + card ((S_edges - B) - T)))"
    using finite_edges by (simp add: card_Un_Int)
  also have "\<dots> = ?pp A B * (\<Sum>T\<in>cylinder S_edges A B. ?pp (T - A) (S_edges - B - T))"
    by (simp add: power_add setsum_right_distrib ac_simps)
  also have "\<dots> = ?pp A B"
  proof -
    have "\<And>T. T \<in> cylinder S_edges A B \<Longrightarrow> S_edges - B - T = (S_edges - A) - B - (T - A)"
         "Pow (S_edges - A - B) = (\<lambda>x. x - A) ` cylinder S_edges A B"
         "inj_on (\<lambda>x. x - A) (cylinder S_edges A B)"
         "finite (S_edges - A - B)"
      using assms by (auto simp: cylinder_def intro!: inj_onI)
    with full_sum[of "S_edges - A - B"] show ?thesis by (simp add: setsum.reindex)
  qed
  finally show ?thesis by (auto simp add: prob_eq cylinder_def)
qed

lemma Markov_inequality:
  fixes a :: real and X :: "uedge set \<Rightarrow> real"
  assumes "0 < c" "\<And>x. 0 \<le> f x"
  shows "prob {x \<in> space P. c \<le> f x} \<le> (\<integral>x. f x \<partial> P) / c"
proof -
  from assms have "(\<integral>\<^sup>+ x. ereal (f x) \<partial>P) = (\<integral>x. f x \<partial>P)"
    by (intro nn_integral_eq_integral) auto
  with assms show ?thesis
    using nn_integral_Markov_inequality[of f P "space P" "1 / c"]
    by (simp cong: nn_integral_cong add: emeasure_eq_measure one_ereal_def)
qed

end

subsection {* Graph Probabilities outside of @{term Edge_Space} locale*}

text {*
 These abbreviations allow a compact expression of probabilities about random
 graphs outside of the @{term Edge_Space} locale. We also transfer a few of the lemmas
 we need from the locale into the toplevel theory.
*}

abbreviation MGn :: "(nat \<Rightarrow> real) \<Rightarrow> nat \<Rightarrow> (uedge set) measure" where
  "MGn p n \<equiv> (edge_space.P n (p n))"
abbreviation probGn :: "(nat \<Rightarrow> real) \<Rightarrow> nat \<Rightarrow> (uedge set \<Rightarrow> bool) \<Rightarrow> real" where
  "probGn p n P \<equiv> measure (MGn p n) {es \<in> space (MGn p n). P es}"

lemma probGn_le:
  assumes p_prob: "0 < p n" "p n < 1"
  assumes sub: "\<And>n es. es \<in> space (MGn p n) \<Longrightarrow> P n es \<Longrightarrow> Q n es"
  shows "probGn p n (P n) \<le> probGn p n (Q n)"
proof -
  from p_prob interpret E: edge_space n "p n" by unfold_locales auto
  show ?thesis
    by (auto intro!: E.finite_measure_mono sub simp: E.space_eq E.sets_eq)
qed

section {* Short cycles *}

definition short_cycles :: "ugraph \<Rightarrow> nat \<Rightarrow> uwalk set" where
  "short_cycles G k \<equiv> {p \<in> ucycles G. uwalk_length p \<le> k}"

text {* obtains a vertex in a short cycle: *}
definition choose_v :: "ugraph \<Rightarrow> nat \<Rightarrow> uvert" where
  "choose_v G k \<equiv> SOME u. \<exists>p. p \<in> short_cycles G k \<and> u \<in> set p"

partial_function (tailrec) kill_short :: "ugraph \<Rightarrow> nat \<Rightarrow> ugraph" where
  "kill_short G k = (if short_cycles G k = {} then G else (kill_short (G -- (choose_v G k)) k))"

lemma ksc_simps[simp]:
  "short_cycles G k = {} \<Longrightarrow> kill_short G k = G"
  "short_cycles G k \<noteq> {}  \<Longrightarrow> kill_short G k = kill_short (G -- (choose_v G k)) k"
  by (auto simp: kill_short.simps)

lemma
  assumes "short_cycles G k \<noteq> {}"
  shows choose_v__in_uverts: "choose_v G k \<in> uverts G" (is ?t1)
    and choose_v__in_short: "\<exists>p. p \<in> short_cycles G k \<and> choose_v G k \<in> set p" (is ?t2)
proof -
  from assms obtain p where "p \<in> ucycles G" "uwalk_length p \<le> k"
    unfolding short_cycles_def by auto
  moreover
  then obtain u where "u \<in> set p" unfolding ucycles_def
    by (cases p) (auto simp: uwalk_length_conv)
  ultimately have "\<exists>u p. p \<in> short_cycles G k \<and> u \<in> set p"
    by (auto simp: short_cycles_def)
  then show ?t2 by (auto simp: choose_v_def intro!: someI_ex)
  then show ?t1 by (auto simp: short_cycles_def ucycles_def uwalks_def)
qed

lemma kill_step_smaller:
  assumes "short_cycles G k \<noteq> {}"
  shows "short_cycles (G -- (choose_v G k)) k \<subset> short_cycles G k"
proof -
  let ?cv = "choose_v G k"
  from assms obtain p where "p \<in> short_cycles G k" "?cv \<in> set p"
    by atomize_elim (rule choose_v__in_short)

  have "short_cycles (G -- ?cv) k \<subseteq> short_cycles G k"
  proof
    fix p assume "p \<in> short_cycles (G -- ?cv) k"
    then show "p \<in> short_cycles G k"
      unfolding short_cycles_def ucycles_def uwalks_def
      using edges_Gu[of G ?cv] by (auto simp: verts_Gu)
  qed
  moreover have "p \<notin> short_cycles (G -- ?cv) k"
    using `?cv \<in> set p` by (auto simp: short_cycles_def ucycles_def uwalks_def verts_Gu)
  ultimately show ?thesis using `p \<in> short_cycles G k` by auto
qed

text {* Induction rule for @{term kill_short}: *}
lemma kill_short_induct[consumes 1, case_names empty kill_vert]:
  assumes fin: "finite (uverts G)"
  assumes a_empty: "\<And>G. short_cycles G k = {} \<Longrightarrow> P G k"
  assumes a_kill: "\<And>G. finite (short_cycles G k) \<Longrightarrow> short_cycles G k \<noteq> {}
    \<Longrightarrow> P (G -- (choose_v G k)) k \<Longrightarrow> P G k"
  shows "P G k"
proof -
  have "finite (short_cycles G k)"
    using finite_ucycles[OF fin] by (auto simp: short_cycles_def)
  then show ?thesis
    by (induct "short_cycles G k" arbitrary: G rule: finite_psubset_induct)
      (metis kill_step_smaller a_kill a_empty)
qed

text {* Large Girth (after @{term kill_short}): *}
lemma kill_short_large_girth:
  assumes "finite (uverts G)"
  shows "k < girth (kill_short G k)"
using assms
proof (induct G k rule: kill_short_induct)
  case (empty G)
  then have "\<And>p. p \<in> ucycles G \<Longrightarrow> k < enat (uwalk_length p)"
    by (auto simp: short_cycles_def)
  with empty show ?case by (auto simp: girth_def intro: enat_less_INF_I)
qed simp

text {* Order of graph (after @{term kill_short}): *}
lemma kill_short_order_of_graph:
  assumes "finite (uverts G)"
  shows "card (uverts G) - card (short_cycles G k) \<le> card (uverts (kill_short G k))"
using assms assms
proof (induct G k rule: kill_short_induct)
  case (kill_vert G)
  let ?oG = "G -- (choose_v G k)"

  have "finite (uverts ?oG)"
    using kill_vert by (auto simp: remove_vertex_def)
  moreover
  have "uverts (kill_short G k) = uverts (kill_short ?oG k)"
    using kill_vert by simp
  moreover
  have "card (uverts G) = Suc (card (uverts ?oG))"
    using choose_v__in_uverts kill_vert
    by (simp add: remove_vertex_def card_Suc_Diff1 del: card_Diff_insert)
  moreover
  have "card (short_cycles ?oG k) < card (short_cycles G k)"
    by (intro psubset_card_mono kill_vert.hyps kill_step_smaller)
  ultimately show ?case using kill_vert.hyps by presburger
qed simp

text {* Independence number (after @{term kill_short}): *}
lemma kill_short_\<alpha>:
  assumes "finite (uverts G)"
  shows "\<alpha> (kill_short G k) \<le> \<alpha> G"
using assms
proof (induct G k rule: kill_short_induct)
  case (kill_vert G)
  note kill_vert(3)
  also have "\<alpha> (G -- (choose_v G k)) \<le> \<alpha> G" by (rule \<alpha>_remove_le)
  finally show ?case using kill_vert by simp
qed simp

text {* Wellformedness (after @{term kill_short}): *}
lemma kill_short_uwellformed:
  assumes "finite (uverts G)" "uwellformed G"
  shows "uwellformed (kill_short G k)"
using assms
proof (induct G k rule: kill_short_induct)
  case (kill_vert G)
  from kill_vert.prems have "uwellformed (G -- (choose_v G k))"
    by (auto simp: uwellformed_def remove_vertex_def)
  with kill_vert.hyps show ?case by simp
qed simp

section {* The Chromatic-Girth Theorem *}

text {* Probability of Independent Edges: *}
lemma (in edge_space) random_prob_independent:
  assumes "n \<ge> k" "k \<ge> 2"
  shows "prob {es \<in> space P. k \<le> \<alpha> (edge_ugraph es)}
    \<le> (n choose k)*(1-p)^(k choose 2)"
proof -
  let "?k_sets" = "{vs. vs \<subseteq> S_verts \<and> card vs = k}"

  { fix vs assume A: "vs \<in> ?k_sets"
    then have B: "all_edges vs \<subseteq> S_edges"
      unfolding all_edges_def S_edges_def by blast

    have "{es \<in> space P. vs \<in> independent_sets (edge_ugraph es)}
        = cylinder S_edges {} (all_edges vs)" (is "?L = _")
      using A by (auto simp: independent_sets_def edge_ugraph_def space_eq cylinder_def)
    then have "prob ?L = (1-p)^(k choose 2)"
      using A B finite by (auto simp: cylinder_prob card_all_edges dest: finite_subset)
  }
  note prob_k_indep = this
    -- "probability that a fixed set of k vertices is independent in a random graph"

  have "{es \<in> space P. k \<in> card ` independent_sets (edge_ugraph es)}
    = (\<Union>vs \<in> ?k_sets. {es \<in> space P. vs \<in> independent_sets (edge_ugraph es)})" (is "?L = ?R")
    unfolding image_def space_eq independent_sets_def by auto
  then have "prob ?L \<le> (\<Sum>vs \<in> ?k_sets. prob {es \<in> space P. vs \<in> independent_sets (edge_ugraph es)})"
    by (auto intro!: finite_measure_subadditive_finite simp: space_eq sets_eq)
  also have "\<dots> = (n choose k)*((1 - p) ^ (k choose 2))"
    by (simp add: prob_k_indep real_eq_of_nat S_verts_def n_subsets)
  finally show ?thesis using `k \<ge> 2` by (simp add: le_\<alpha>_iff)
qed

text {* Almost never many independent edges: *}
lemma almost_never_le_\<alpha>:
  fixes k :: nat
    and p :: "nat \<Rightarrow> real"
  assumes p_prob: "\<forall>\<^sup>\<infinity> n. 0 < p n \<and> p n < 1"
  assumes [arith]: "k > 0"
  assumes N_prop: "\<forall>\<^sup>\<infinity> n. (6 * k * ln n)/n \<le> p n"
  shows "(\<lambda>n. probGn p n (\<lambda>es. 1/2*n/k \<le> \<alpha> (edge_space.edge_ugraph n es))) ----> 0"
    (is "(\<lambda>n. ?prob_fun n) ----> 0")
proof -
  let "?prob_fun_raw n" = "probGn p n (\<lambda>es. natceiling (1/2*n/k) \<le> \<alpha> (edge_space.edge_ugraph n es))"

  def r \<equiv> "\<lambda>(n :: nat). (1 / 2 * n / k)"
  let "?nr n" = "natceiling (r n)"

  have r_pos: "\<And>n. 0 < n \<Longrightarrow> 0 < r n " by (auto simp: r_def field_simps)

  have nr_bounds: "\<forall>\<^sup>\<infinity> n. 2 \<le> ?nr n \<and> ?nr n \<le> n"
    by (intro eventually_sequentiallyI[of "4 * k"])
      (simp add: r_def natceiling_le le_natceiling_iff field_simps)

  from nr_bounds p_prob have ev_prob_fun_raw_le:
    "\<forall>\<^sup>\<infinity> n. probGn p n (\<lambda>es. ?nr n\<le> \<alpha> (edge_space.edge_ugraph n es))
      \<le> (n * exp (- p n * (real (?nr n) - 1) / 2)) powr ?nr n"
    (is "\<forall>\<^sup>\<infinity> n. ?prob_fun_raw_le n")
  proof (rule eventually_elim2)
    fix n :: nat assume A: "2 \<le> ?nr n \<and> ?nr n \<le> n" "0 < p n \<and>p n < 1"
    then interpret pG: edge_space n "p n" by unfold_locales auto

    have r: "real (?nr n - 1) = real (?nr n) - 1" using A by auto

    have "probGn p n (\<lambda>es. ?nr n \<le> \<alpha> (edge_space.edge_ugraph n es))
        \<le> (n choose ?nr n) * (1 - p n)^(?nr n choose 2)"
      using A by (auto intro: pG.random_prob_independent)
    also have "\<dots> \<le> n powr ?nr n * (1 - p n) powr (?nr n choose 2)"
      using A
      by (simp add: powr_realpow power_real_of_nat binomial_le_pow del: real_of_nat_power)
    also have "\<dots> = n powr ?nr n * (1 - p n) powr (?nr n * (?nr n - 1) / 2)"
      by (cases "even (?nr n - 1)")
        (auto simp add: n_choose_2_nat real_of_nat_div)
    also have "\<dots> = n powr ?nr n * ((1 - p n) powr ((?nr n - 1) / 2)) powr ?nr n"
      by (auto simp: powr_powr algebra_simps)
    also have "\<dots> \<le> (n * exp (- p n * (?nr n - 1) / 2)) powr ?nr n"
    proof -
      have "(1 - p n) powr ((?nr n - 1) / 2) \<le> exp (- p n) powr ((?nr n - 1) / 2)"
        using A by (auto simp: powr_mono2 diff_conv_add_uminus simp del: add_uminus_conv_diff)
      also have "\<dots> = exp (- p n * (?nr n - 1) / 2)" by (auto simp: powr_def)
      finally show ?thesis
        using A by (auto simp: powr_mono2 powr_mult)
    qed
    finally show "probGn p n (\<lambda>es. ?nr n \<le> \<alpha> (edge_space.edge_ugraph n es))
      \<le> (n * exp (- p n * (real (?nr n) - 1) / 2)) powr ?nr n"
      using A r by simp
  qed

  from p_prob N_prop
  have ev_expr_bound: "\<forall>\<^sup>\<infinity> n. n * exp (-p n * (real (?nr n) - 1) / 2) \<le> (exp 1 / n) powr (1 / 2)"
  proof (elim eventually_rev_mp, intro eventually_sequentiallyI conjI impI)
    fix n assume n_bound[arith]: "2 \<le> n"
      and p_bound: "0 < p n \<and> p n < 1" "(6 * k * ln n) / n \<le> p n"
    have r_bound: "r n \<le> ?nr n" by (rule real_natceiling_ge)

    have "n * exp (-p n * (real (?nr n)- 1) / 2) \<le> n * exp (- 3 / 2 * ln n + p n / 2)"
    proof -
      have "0 < ln n" using "n_bound" by auto
      then have "(3 / 2) * ln n \<le> ((6 * k * ln n) / n) * (?nr n / 2)"
        using r_bound by (simp add: r_def field_simps del: ln_gt_zero_iff)
      also have "\<dots> \<le> p n * (?nr n / 2)"
        using n_bound p_bound r_bound r_pos[of n] by (auto simp: field_simps)
      finally show ?thesis using r_bound by (auto simp: field_simps)
    qed
    also have "\<dots> \<le> n * n powr (- 3 / 2) * exp 1 powr (1 / 2)"
      using p_bound by (simp add: powr_def exp_add [symmetric])
    also have "\<dots> \<le> n powr (-1 / 2) * exp 1 powr (1 / 2)" by (simp add: powr_mult_base)
    also have "\<dots> = (exp 1 / n) powr (1/2)"
      by (simp add: powr_divide powr_minus_divide)
    finally show "n * exp (- p n * (real (?nr n) - 1) / 2) \<le> (exp 1 / n) powr (1 / 2)" .
  qed

  have ceil_bound: "\<And>G n. 1/2*n/k \<le> \<alpha> G \<longleftrightarrow> natceiling (1/2*n/k) \<le> \<alpha> G"
    by (case_tac "\<alpha> G") (auto simp: natceiling_le_eq)

  show ?thesis
  proof (unfold ceil_bound, rule real_tendsto_sandwich)
    show "(\<lambda>n. 0) ----> 0"
        "(\<lambda>n. (exp 1 / n) powr (1 / 2)) ----> 0"
        "\<forall>\<^sup>\<infinity> n. 0 \<le> ?prob_fun_raw n"
      using p_prob by (auto intro: measure_nonneg LIMSEQ_inv_powr elim: eventually_elim1)
  next
    from nr_bounds ev_expr_bound ev_prob_fun_raw_le
    show "\<forall>\<^sup>\<infinity> n. ?prob_fun_raw n \<le> (exp 1 / n) powr (1 / 2)"
    proof (elim eventually_rev_mp, intro eventually_sequentiallyI impI conjI)
      fix n assume A: "3 \<le> n"
        and nr_bounds: "2 \<le> ?nr n \<and> ?nr n \<le> n"
        and prob_fun_raw_le: "?prob_fun_raw_le n"
        and expr_bound: "n * exp (- p n * (real (natceiling (r n)) - 1) / 2) \<le> (exp 1 / n) powr (1 / 2)"

      have "exp 1 < (3 :: real)" by (approximation 5)
      then have "(exp 1 / n) powr (1 / 2) \<le> 1 powr (1 / 2)"
        using A by (intro powr_mono2) (auto simp: field_simps)
      then have ep_bound: "(exp 1 / n) powr (1 / 2) \<le> 1" by simp

      have "?prob_fun_raw n \<le> (n * exp (- p n * (real (?nr n) - 1) / 2)) powr (?nr n)"
        using prob_fun_raw_le by (simp add: r_def)
      also have "\<dots> \<le> ((exp 1 / n) powr (1 / 2)) powr ?nr n"
        using expr_bound A by (auto simp: powr_mono2)
      also have "\<dots> \<le> ((exp 1 / n) powr (1 / 2))"
        using nr_bounds ep_bound by (auto simp: powr_le_one_le)
      finally show "?prob_fun_raw n \<le> (exp 1 / n) powr (1 / 2)" .
    qed
  qed
qed

text {* Mean number of k-cycles in a graph. (Or rather of paths describing a circle of length @{term k}): *}
lemma (in edge_space) mean_k_cycles:
  assumes "3 \<le> k" "k < n"
  shows "(\<integral>es. card {c \<in> ucycles (edge_ugraph es). uwalk_length c = k} \<partial> P)
    = (fact n div fact (n - k)) * p ^ k"
proof -
  let ?k_cycle = "\<lambda>es c k. c \<in> ucycles (edge_ugraph es) \<and> uwalk_length c = k"
  def C \<equiv> "\<lambda>k. {c. ?k_cycle S_edges c k}"
    -- {* @{term "C k"} is the set of all possible cycles of size @{term k} in @{term "edge_ugraph S_edges"} *}
  def XG \<equiv> "\<lambda>es. {c. ?k_cycle es c k}"
    -- {* @{term "XG es"} is the set of cycles contained in a @{term "edge_ugraph es"} *}
  def XC \<equiv> "\<lambda>c. {es \<in> space P. ?k_cycle es c k}"
    -- {* "@{term "XC c"} is the set of graphs (edge sets) containing a cycle c" *}
  then have XC_in_sets: "\<And>c. XC c \<in> sets P"
      and XC_cyl: "\<And>c. c \<in> C k \<Longrightarrow> XC c = cylinder S_edges (set (uwalk_edges c)) {}"
    by (auto simp: ucycles_def space_eq uwalks_def C_def cylinder_def sets_eq)

  have "(\<integral>es. card {c \<in> ucycles (edge_ugraph es). uwalk_length c = k} \<partial> P)
      =  (\<Sum>x\<in>space P. card (XG x) * prob {x})"
    by (simp add: XG_def integral_finite_singleton space_eq)
  also have "\<dots> = (\<Sum>c\<in>C k. prob (cylinder S_edges (set (uwalk_edges c)) {}))"
  proof -
    have XG_Int_C: "\<And>s. s \<in> space P \<Longrightarrow> C k \<inter> XG s = XG s"
      unfolding XG_def C_def ucycles_def uwalks_def edge_ugraph_def by auto
    have fin_XC: "\<And>k. finite (XC k)" and fin_C: "finite (C k)"
      unfolding C_def XC_def by (auto simp: finite_edges space_eq intro!: finite_ucycles)

    have "(\<Sum>x\<in>space P. card (XG x) * prob {x}) = (\<Sum>x\<in>space P. (\<Sum>c \<in> XG x. prob {x}))"
      by (simp add: real_eq_of_nat)
    also have "\<dots> = (\<Sum>x\<in>space P. (\<Sum>c \<in> C k. if c \<in> XG x then prob {x} else 0))"
      using fin_C by (simp add: setsum.If_cases) (simp add: XG_Int_C)
    also have "\<dots> = (\<Sum>c \<in> C k. (\<Sum> x \<in> space P \<inter> XC c. prob {x}))"
      using finite_edges by (subst setsum.commute) (simp add: setsum.inter_restrict XG_def XC_def space_eq)
    also have "\<dots> = (\<Sum>c \<in> C k. prob (XC c))"
      using fin_XC XC_in_sets
      by (auto simp add: prob_eq sets_eq space_eq intro!: setsum.cong)
    finally show ?thesis by (simp add: XC_cyl)
  qed
  also have "\<dots> = (\<Sum>c\<in>C k. p ^ k)"
  proof -
    have "\<And>x. x \<in> C k \<Longrightarrow> card (set (uwalk_edges x)) = uwalk_length x"
      by (auto simp: uwalk_length_def C_def ucycles_distinct_edges intro: distinct_card)
    then show ?thesis by (auto simp: C_def ucycles_def uwalks_def cylinder_prob)
  qed
  also have "\<dots> = (fact n div fact (n - k)) * p ^ k"
  proof -
    have inj_last_Cons: "\<And>A. inj_on (\<lambda>es. last es # es) A" by (rule inj_onI) simp
    { fix xs A assume "3 \<le> length xs - Suc 0" "hd xs = last xs"
      then have "xs \<in> (\<lambda>xs. last xs # xs) ` A \<longleftrightarrow> tl xs \<in> A"
        by (cases xs) (auto simp: inj_image_mem_iff[OF inj_last_Cons] split: split_if_asm) }
    note image_mem_iff_inst = this

    { fix xs have "xs \<in> uwalks (edge_ugraph S_edges) \<Longrightarrow> set (tl xs) \<subseteq> S_verts"
        unfolding uwalks_def by (induct xs) auto }
    moreover
    { fix xs assume "set xs \<subseteq> S_verts" "2 \<le> length xs" "distinct xs"
      then have "(last xs # xs) \<in> uwalks (edge_ugraph S_edges)"
      proof (induct xs rule: uwalk_edges.induct)
        case (3 x y ys)
        have S_edges_memI: "\<And>x y. x \<in> S_verts \<Longrightarrow> y \<in> S_verts \<Longrightarrow> x \<noteq> y \<Longrightarrow> {x, y} \<in> S_edges"
          unfolding S_edges_def all_edges_def image_def by auto

        have "ys \<noteq> [] \<Longrightarrow> set ys \<subseteq> S_verts \<Longrightarrow> last ys \<in> S_verts"  by auto
        with 3 show ?case
          by (auto simp add: uwalks_def Suc_le_eq intro: S_edges_memI)
      qed simp_all}
    moreover note `3 \<le> k`
    ultimately
    have "C k = (\<lambda>xs. last xs # xs) ` {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> S_verts}"
      by (auto simp: C_def ucycles_def uwalk_length_conv image_mem_iff_inst)
    moreover have "card S_verts = n" by (simp add: S_verts_def)
    ultimately have "card (C k) = fact n div fact (n - k)"
      using `k < n`
      by (simp add: card_image[OF inj_last_Cons] card_lists_distinct_length_eq fact_div_fact)
    then show ?thesis by (simp add: real_eq_of_nat)
  qed
  finally show ?thesis by simp
qed

text {* Girth-Chromatic number theorem: *}
theorem girth_chromatic:
  fixes l :: nat
  shows "\<exists>G. uwellformed G \<and> l < girth G \<and> l < chromatic_number G"
proof -
  def k \<equiv> "max 3 l"
  def \<epsilon> \<equiv> "1 / (2 * k)"
  def p \<equiv> "\<lambda>(n :: nat). real n powr (\<epsilon> - 1)"

  let ?ug = edge_space.edge_ugraph

  def short_count \<equiv> "\<lambda>g. card (short_cycles g k)"
    -- {* This random variable differs from the one used in the proof of theorem 11.2.2,
          as we count the number of paths describing a circle, not the circles themselves *}

  from k_def have "3 \<le> k" "l \<le> k" by auto
  from \<epsilon>_def `3 \<le> k` have \<epsilon>_props: "0 < \<epsilon>" "\<epsilon> < 1 / k" "\<epsilon> < 1" by (auto simp: field_simps)

  have ev_p: "\<forall>\<^sup>\<infinity> n. 0 < p n \<and> p n < 1"
  proof (rule eventually_sequentiallyI)
    fix n :: nat assume "2 \<le> n"
    with `\<epsilon> < 1` have "n powr (\<epsilon> - 1) < 1" by (auto intro!: powr_less_one)
    then show "0 < p n \<and> p n < 1" by (auto simp: p_def)
  qed
  then
  have prob_short_count_le: "\<forall>\<^sup>\<infinity> n. probGn p n (\<lambda>es. (real n/2) \<le> short_count (?ug n es))
      \<le> 2 * (k - 2) * n powr (\<epsilon> * k - 1)"  (is "\<forall>\<^sup>\<infinity> n. ?P n")
  proof (elim eventually_rev_mp, intro eventually_sequentiallyI impI)
    fix n :: nat assume A: "Suc k \<le> n" "0 < p n \<and> p n < 1"
    then interpret pG: edge_space n "p n" by unfold_locales auto
    have "1 \<le> n" using A by auto

    def mean_short_count \<equiv> "\<integral>es. short_count (?ug n es) \<partial> pG.P"

    have mean_short_count_le: "mean_short_count \<le> (k - 2) * n powr (\<epsilon> * k)"
    proof -
      have small_empty: "\<And>es k. k \<le> 2 \<Longrightarrow> short_cycles (edge_space.edge_ugraph n es) k = {}"
          by (auto simp add: short_cycles_def ucycles_def)
      have short_count_conv: "\<And>es. short_count (?ug n es) = (\<Sum>i=3..k. real (card {c \<in> ucycles (?ug n es). uwalk_length c = i}))"
      proof (unfold short_count_def, induct k)
        case 0 with small_empty show ?case by auto
      next
        case (Suc k)
        show ?case proof (cases "Suc k \<le> 2")
          case True with small_empty show ?thesis by auto
        next
          case False
          have "{c \<in> ucycles (?ug n es). uwalk_length c \<le> Suc k}
              = {c \<in> ucycles (?ug n es). uwalk_length c \<le> k} \<union> {c \<in> ucycles (?ug n es). uwalk_length c = Suc k}"
            by auto
          moreover
          have "finite (uverts (edge_space.edge_ugraph n es))" by auto
          ultimately
          have "card {c \<in> ucycles (?ug n es). uwalk_length c \<le> Suc k}
            = card {c \<in> ucycles (?ug n es). uwalk_length c \<le> k} + card {c \<in> ucycles (?ug n es). uwalk_length c = Suc k}"
            using finite_ucycles by (subst card_Un_disjoint[symmetric]) auto
          then show ?thesis
            using Suc False unfolding short_cycles_def by (auto simp: not_le)
        qed
      qed

      have "mean_short_count = (\<Sum>i=3..k. \<integral>es. card {c \<in> ucycles (?ug n es). uwalk_length c = i} \<partial> pG.P)"
        unfolding mean_short_count_def short_count_conv
        by (subst integral_setsum) (auto intro: pG.integral_finite_singleton)
      also have "\<dots> = (\<Sum>i\<in>{3..k}. (fact n div fact (n - i)) * p n ^ i)"
        using A by (simp add: pG.mean_k_cycles)
      also have "\<dots> \<le> (\<Sum> i\<in>{3..k}. n ^ i * p n ^ i)"
        using A fact_div_fact_le_pow
        by (auto intro: setsum_mono simp del: real_of_nat_power)
      also have "... \<le> (\<Sum> i\<in>{3..k}. n powr (\<epsilon> * k))"
        using `1 \<le> n` `0 < \<epsilon>` A
        by (intro setsum_mono) (auto simp: p_def field_simps powr_mult_base powr_powr
          powr_realpow[symmetric] powr_mult[symmetric] powr_add[symmetric])
      finally show ?thesis by (simp add: real_eq_of_nat)
    qed

    have "pG.prob {es \<in> space pG.P. n/2 \<le> short_count (?ug n es)} \<le> mean_short_count / (n/2)"
      unfolding mean_short_count_def using `1 \<le> n`
      by (intro pG.Markov_inequality) (auto simp: short_count_def)
    also have "\<dots> \<le> 2 * (k - 2) * n powr (\<epsilon> * k - 1)"
    proof -
      have "mean_short_count / (n / 2) \<le> 2 * (k - 2) * (1 / n powr 1) * n powr (\<epsilon> * k)"
        using mean_short_count_le `1 \<le> n` by (simp add: field_simps)
      then show ?thesis by (simp add: powr_divide2[symmetric] algebra_simps)
    qed
    finally show "?P n" .
  qed

  def pf_short_count \<equiv> "\<lambda>n. probGn p n (\<lambda>es. n/2 \<le> short_count (?ug n es))"
    and pf_\<alpha> \<equiv> "\<lambda>n. probGn p n (\<lambda>es. 1/2 * n/k \<le> \<alpha> (edge_space.edge_ugraph n es))"

  have ev_short_count_le: "\<forall>\<^sup>\<infinity> n. pf_short_count n < 1 / 2"
  proof -
    have "\<epsilon> * k - 1 < 0"
      using \<epsilon>_props `3 \<le> k` by (auto simp: field_simps)
    then have "(\<lambda>n. 2 * (k - 2) * n powr (\<epsilon> * k - 1)) ----> 0" (is "?bound ----> 0")
      by (intro tendsto_mult_right_zero LIMSEQ_neg_powr)
    then have "\<forall>\<^sup>\<infinity> n. dist (?bound n) 0  < 1 / 2"
      by (rule tendstoD) simp
    with prob_short_count_le show ?thesis
      by (rule eventually_elim2) (auto simp: dist_real_def pf_short_count_def)
  qed

  have lim_\<alpha>: "pf_\<alpha> ----> 0"
  proof -
    have "0 < k" using `3 \<le> k` by simp

    have "\<forall>\<^sup>\<infinity> n. (6*k) * ln n / n \<le> p n \<longleftrightarrow> (6*k) * ln n * n powr - \<epsilon> \<le> 1"
    proof (rule eventually_sequentiallyI)
     fix n :: nat assume "1 \<le> n"
      then have "(6 * k) * ln n / n \<le> p n \<longleftrightarrow> (6*k) * ln n * (n powr - 1) \<le> n powr (\<epsilon> - 1)"
        by  (subst powr_minus) (simp add: divide_inverse p_def)
      also have "\<dots> \<longleftrightarrow> (6*k) * ln n * ((n powr - 1) / (n powr (\<epsilon> - 1))) \<le> n powr (\<epsilon> - 1) / (n powr (\<epsilon> - 1))"
        by auto
      also have "\<dots> \<longleftrightarrow> (6*k) * ln n * n powr - \<epsilon> \<le> 1"
        by (simp add: powr_divide2)
      finally show "(6*k) * ln n / n \<le> p n \<longleftrightarrow> (6*k) * ln n * n powr - \<epsilon> \<le> 1" .
    qed
    then have "(\<forall>\<^sup>\<infinity> n. (6 * k) * ln n / real n \<le> p n)
        \<longleftrightarrow> (\<forall>\<^sup>\<infinity> n. (6*k) * ln n * n powr - \<epsilon> \<le> 1)"
      by (rule eventually_subst)
    also have "\<forall>\<^sup>\<infinity> n. (6*k) * ln n * n powr - \<epsilon> \<le> 1"
    proof -
      { fix n :: nat assume "0 < n"
        have "ln (real n) \<le> n powr (\<epsilon>/2) / (\<epsilon>/2)"
          using `0 < n` `0 < \<epsilon>` by (intro ln_powr_bound) auto
        also have "\<dots> \<le> 2/\<epsilon> * n powr (\<epsilon>/2)" by (auto simp: field_simps)
        finally have "(6*k) * ln n * (n powr - \<epsilon>)  \<le> (6*k) * (2/\<epsilon> * n powr (\<epsilon>/2)) * (n powr - \<epsilon>)"
          using `0 < n` `0 < k` by (intro mult_right_mono mult_left_mono) auto
        also have "\<dots> = 12*k/\<epsilon> * n powr (-\<epsilon>/2)"
          unfolding divide_inverse
          by (auto simp: field_simps powr_minus[symmetric] powr_add[symmetric])
        finally have "(6*k) * ln n * (n powr - \<epsilon>) \<le> 12*k/\<epsilon> * n powr (-\<epsilon>/2)" .
      }
      then have "\<forall>\<^sup>\<infinity> n. (6*k) * ln n * (n powr - \<epsilon>) \<le> 12*k/\<epsilon> * n powr (-\<epsilon>/2)"
        by (intro eventually_sequentiallyI[of 1]) auto
      also have "\<forall>\<^sup>\<infinity> n. 12*k/\<epsilon> * n powr (-\<epsilon>/2) \<le> 1"
      proof -
        have "(\<lambda>n. 12*k/\<epsilon> * n powr (-\<epsilon>/2)) ----> 0"
          using `0 < \<epsilon>` by (intro tendsto_mult_right_zero LIMSEQ_neg_powr) auto
        then show ?thesis
          using `0 < \<epsilon>` by (auto elim: eventually_elim1 simp: dist_real_def dest!: tendstoD[where e=1])
      qed
      finally (eventually_le_le) show ?thesis .
    qed
    finally have "\<forall>\<^sup>\<infinity> n. real (6 * k) * ln (real n) / real n \<le> p n" .
    with ev_p `0 < k` show ?thesis unfolding pf_\<alpha>_def by (rule almost_never_le_\<alpha>)
  qed

  from ev_short_count_le lim_\<alpha>[THEN tendstoD, of "1/2"] ev_p
  have "\<forall>\<^sup>\<infinity> n. 0 < p n \<and> p n < 1 \<and> pf_short_count n < 1/2 \<and> pf_\<alpha> n < 1/2"
    by simp (elim eventually_rev_mp, auto simp: eventually_sequentially dist_real_def)
  then obtain n where "0 < p n" "p n < 1" and [arith]: "0 < n"
      and probs: "pf_short_count n < 1/2" "pf_\<alpha> n < 1/2"
    by (auto simp: eventually_sequentially)
  then interpret ES: edge_space n "(p n)" by unfold_locales auto

  have rest_compl: "\<And>A P. A - {x\<in>A. P x} = {x\<in>A. \<not>P x}" by blast

  from probs have "ES.prob ({es \<in> space ES.P. n/2 \<le> short_count (?ug n es)}
      \<union> {es \<in> space ES.P. 1/2 * n/k \<le> \<alpha> (?ug n es)}) \<le> pf_short_count n + pf_\<alpha> n"
    unfolding pf_short_count_def pf_\<alpha>_def  by (subst ES.finite_measure_subadditive) auto
  also have "\<dots> < 1" using probs by auto
  finally have "0 < ES.prob (space ES.P - ({es \<in> space ES.P. n/2 \<le> short_count (?ug n es)}
      \<union> {es \<in> space ES.P. 1/2 * n/k \<le> \<alpha> (?ug n es)}))" (is "0 < ES.prob ?S")
    by (subst ES.prob_compl) auto
  also have "?S = {es \<in> space ES.P. short_count (?ug n es) < n/2 \<and> \<alpha> (?ug n es) < 1/2* n/k}" (is "\<dots> = ?C")
    by (auto simp: not_less rest_compl)
  finally have "?C \<noteq> {}" by (intro notI) (simp only:, auto)
  then obtain es where es_props: "es \<in> space ES.P"
      "short_count (?ug n es) < n/2" "\<alpha> (?ug n es) < 1/2 * n/k"
    by auto
    -- "now we obtained a high colored graph (few independent nodes) with almost no short cycles"

  def G \<equiv> "?ug n es"
  def H \<equiv> "kill_short G k"

  have G_props: "uverts G = {1..n}" "finite (uverts G)" "short_count G < n/2" "\<alpha> G < 1/2 * n/k"
    unfolding G_def using es_props by (auto simp: ES.S_verts_def)

  have "uwellformed G" by (auto simp: G_def uwellformed_def all_edges_def ES.S_edges_def)
  with G_props have T1: "uwellformed H" unfolding H_def by (intro kill_short_uwellformed)

  have "enat l \<le> enat k" using `l \<le> k` by simp
  also have "\<dots> < girth H" using G_props by (auto simp: kill_short_large_girth H_def)
  finally have T2: "l < girth H" .

  have card_H: "n/2 \<le> card (uverts H)"
    using G_props es_props kill_short_order_of_graph[of G k] by (simp add: short_count_def H_def)

  then have uverts_H: "uverts H \<noteq> {}" "0 < card (uverts H)" by auto
  then have "0 < \<alpha> H" using zero_less_\<alpha> uverts_H by auto

  have \<alpha>_HG: "\<alpha> H \<le> \<alpha> G"
    unfolding H_def G_def by (auto intro: kill_short_\<alpha>)

  have "enat l \<le> ereal k" using `l \<le> k` by auto
  also have "\<dots> < (n/2) / \<alpha> G" using G_props `3 \<le> k`
    by (cases "\<alpha> G") (auto simp: real_of_nat_def[symmetric] field_simps)
  also have "\<dots> \<le> (n/2) / \<alpha> H" using \<alpha>_HG `0 < \<alpha> H`
    by (auto simp: ereal_of_enat_pushout intro!: ereal_divide_left_mono)
  also have "\<dots> \<le> card (uverts H) / \<alpha> H" using card_H `0 < \<alpha> H`
    by (auto intro!: ereal_divide_right_mono)
  also have "\<dots> \<le> chromatic_number H" using uverts_H T1 by (intro chromatic_lb) auto
  finally have T3: "l < chromatic_number H"
    by (simp add: ereal_of_enat_less_iff del: ereal_of_enat_simps)

  from T1 T2 T3 show ?thesis by fast
qed

end


(*
  Author: Jeremy Dawson, NICTA
*)

section {* Integers as implict bit strings *}

theory Bit_Representation
imports Misc_Numeric
begin

subsection {* Constructors and destructors for binary integers *}

definition Bit :: "int \<Rightarrow> bool \<Rightarrow> int" (infixl "BIT" 90)
where
  "k BIT b = (if b then 1 else 0) + k + k"

lemma Bit_B0:
  "k BIT False = k + k"
   by (unfold Bit_def) simp

lemma Bit_B1:
  "k BIT True = k + k + 1"
   by (unfold Bit_def) simp

lemma Bit_B0_2t: "k BIT False = 2 * k"
  by (rule trans, rule Bit_B0) simp

lemma Bit_B1_2t: "k BIT True = 2 * k + 1"
  by (rule trans, rule Bit_B1) simp

definition bin_last :: "int \<Rightarrow> bool"
where
  "bin_last w \<longleftrightarrow> w mod 2 = 1"

lemma bin_last_odd:
  "bin_last = odd"
  by (rule ext) (simp add: bin_last_def even_iff_mod_2_eq_zero)

definition bin_rest :: "int \<Rightarrow> int"
where
  "bin_rest w = w div 2"

lemma bin_rl_simp [simp]:
  "bin_rest w BIT bin_last w = w"
  unfolding bin_rest_def bin_last_def Bit_def
  using mod_div_equality [of w 2]
  by (cases "w mod 2 = 0", simp_all)

lemma bin_rest_BIT [simp]: "bin_rest (x BIT b) = x"
  unfolding bin_rest_def Bit_def
  by (cases b, simp_all)

lemma bin_last_BIT [simp]: "bin_last (x BIT b) = b"
  unfolding bin_last_def Bit_def
  by (cases b) simp_all

lemma BIT_eq_iff [iff]: "u BIT b = v BIT c \<longleftrightarrow> u = v \<and> b = c"
  apply (auto simp add: Bit_def)
  apply arith
  apply arith
  done

lemma BIT_bin_simps [simp]:
  "numeral k BIT False = numeral (Num.Bit0 k)"
  "numeral k BIT True = numeral (Num.Bit1 k)"
  "(- numeral k) BIT False = - numeral (Num.Bit0 k)"
  "(- numeral k) BIT True = - numeral (Num.BitM k)"
  unfolding numeral.simps numeral_BitM
  unfolding Bit_def
  by (simp_all del: arith_simps add_numeral_special diff_numeral_special)

lemma BIT_special_simps [simp]:
  shows "0 BIT False = 0" and "0 BIT True = 1"
  and "1 BIT False = 2" and "1 BIT True = 3"
  and "(- 1) BIT False = - 2" and "(- 1) BIT True = - 1"
  unfolding Bit_def by simp_all

lemma Bit_eq_0_iff: "w BIT b = 0 \<longleftrightarrow> w = 0 \<and> \<not> b"
  apply (auto simp add: Bit_def)
  apply arith
  done

lemma Bit_eq_m1_iff: "w BIT b = -1 \<longleftrightarrow> w = -1 \<and> b"
  apply (auto simp add: Bit_def)
  apply arith
  done

lemma BitM_inc: "Num.BitM (Num.inc w) = Num.Bit1 w"
  by (induct w, simp_all)

lemma expand_BIT:
  "numeral (Num.Bit0 w) = numeral w BIT False"
  "numeral (Num.Bit1 w) = numeral w BIT True"
  "- numeral (Num.Bit0 w) = (- numeral w) BIT False"
  "- numeral (Num.Bit1 w) = (- numeral (w + Num.One)) BIT True"
  unfolding add_One by (simp_all add: BitM_inc)

lemma bin_last_numeral_simps [simp]:
  "\<not> bin_last 0"
  "bin_last 1"
  "bin_last (- 1)"
  "bin_last Numeral1"
  "\<not> bin_last (numeral (Num.Bit0 w))"
  "bin_last (numeral (Num.Bit1 w))"
  "\<not> bin_last (- numeral (Num.Bit0 w))"
  "bin_last (- numeral (Num.Bit1 w))"
  unfolding expand_BIT bin_last_BIT by (simp_all add: bin_last_def zmod_zminus1_eq_if)

lemma bin_rest_numeral_simps [simp]:
  "bin_rest 0 = 0"
  "bin_rest 1 = 0"
  "bin_rest (- 1) = - 1"
  "bin_rest Numeral1 = 0"
  "bin_rest (numeral (Num.Bit0 w)) = numeral w"
  "bin_rest (numeral (Num.Bit1 w)) = numeral w"
  "bin_rest (- numeral (Num.Bit0 w)) = - numeral w"
  "bin_rest (- numeral (Num.Bit1 w)) = - numeral (w + Num.One)"
  unfolding expand_BIT bin_rest_BIT by (simp_all add: bin_rest_def zdiv_zminus1_eq_if)

lemma less_Bits:
  "v BIT b < w BIT c \<longleftrightarrow> v < w \<or> v \<le> w \<and> \<not> b \<and> c"
  unfolding Bit_def by auto

lemma le_Bits:
  "v BIT b \<le> w BIT c \<longleftrightarrow> v < w \<or> v \<le> w \<and> (\<not> b \<or> c)"
  unfolding Bit_def by auto

lemma pred_BIT_simps [simp]:
  "x BIT False - 1 = (x - 1) BIT True"
  "x BIT True - 1 = x BIT False"
  by (simp_all add: Bit_B0_2t Bit_B1_2t)

lemma succ_BIT_simps [simp]:
  "x BIT False + 1 = x BIT True"
  "x BIT True + 1 = (x + 1) BIT False"
  by (simp_all add: Bit_B0_2t Bit_B1_2t)

lemma add_BIT_simps [simp]:
  "x BIT False + y BIT False = (x + y) BIT False"
  "x BIT False + y BIT True = (x + y) BIT True"
  "x BIT True + y BIT False = (x + y) BIT True"
  "x BIT True + y BIT True = (x + y + 1) BIT False"
  by (simp_all add: Bit_B0_2t Bit_B1_2t)

lemma mult_BIT_simps [simp]:
  "x BIT False * y = (x * y) BIT False"
  "x * y BIT False = (x * y) BIT False"
  "x BIT True * y = (x * y) BIT False + y"
  by (simp_all add: Bit_B0_2t Bit_B1_2t algebra_simps)

lemma B_mod_2':
  "X = 2 ==> (w BIT True) mod X = 1 & (w BIT False) mod X = 0"
  apply (simp (no_asm) only: Bit_B0 Bit_B1)
  apply simp
  done

lemma bin_ex_rl: "EX w b. w BIT b = bin"
  by (metis bin_rl_simp)

lemma bin_exhaust:
  assumes Q: "\<And>x b. bin = x BIT b \<Longrightarrow> Q"
  shows "Q"
  apply (insert bin_ex_rl [of bin])
  apply (erule exE)+
  apply (rule Q)
  apply force
  done

primrec bin_nth where
  Z: "bin_nth w 0 \<longleftrightarrow> bin_last w"
  | Suc: "bin_nth w (Suc n) \<longleftrightarrow> bin_nth (bin_rest w) n"

lemma bin_abs_lem:
  "bin = (w BIT b) ==> bin ~= -1 --> bin ~= 0 -->
    nat (abs w) < nat (abs bin)"
  apply clarsimp
  apply (unfold Bit_def)
  apply (cases b)
   apply (clarsimp, arith)
  apply (clarsimp, arith)
  done

lemma bin_induct:
  assumes PPls: "P 0"
    and PMin: "P (- 1)"
    and PBit: "!!bin bit. P bin ==> P (bin BIT bit)"
  shows "P bin"
  apply (rule_tac P=P and a=bin and f1="nat o abs"
                  in wf_measure [THEN wf_induct])
  apply (simp add: measure_def inv_image_def)
  apply (case_tac x rule: bin_exhaust)
  apply (frule bin_abs_lem)
  apply (auto simp add : PPls PMin PBit)
  done

lemma Bit_div2 [simp]: "(w BIT b) div 2 = w"
  unfolding bin_rest_def [symmetric] by (rule bin_rest_BIT)

lemma bin_nth_eq_iff:
  "bin_nth x = bin_nth y \<longleftrightarrow> x = y"
proof -
  have bin_nth_lem [rule_format]: "ALL y. bin_nth x = bin_nth y --> x = y"
    apply (induct x rule: bin_induct)
      apply safe
      apply (erule rev_mp)
      apply (induct_tac y rule: bin_induct)
        apply safe
        apply (drule_tac x=0 in fun_cong, force)
       apply (erule notE, rule ext,
            drule_tac x="Suc x" in fun_cong, force)
      apply (drule_tac x=0 in fun_cong, force)
     apply (erule rev_mp)
     apply (induct_tac y rule: bin_induct)
       apply safe
       apply (drule_tac x=0 in fun_cong, force)
      apply (erule notE, rule ext,
           drule_tac x="Suc x" in fun_cong, force)
      apply (metis Bit_eq_m1_iff Z bin_last_BIT)
    apply (case_tac y rule: bin_exhaust)
    apply clarify
    apply (erule allE)
    apply (erule impE)
     prefer 2
     apply (erule conjI)
     apply (drule_tac x=0 in fun_cong, force)
    apply (rule ext)
    apply (drule_tac x="Suc ?x" in fun_cong, force)
    done
  show ?thesis
  by (auto elim: bin_nth_lem)
qed

lemmas bin_eqI = ext [THEN bin_nth_eq_iff [THEN iffD1]]

lemma bin_eq_iff:
  "x = y \<longleftrightarrow> (\<forall>n. bin_nth x n = bin_nth y n)"
  using bin_nth_eq_iff by auto

lemma bin_nth_zero [simp]: "\<not> bin_nth 0 n"
  by (induct n) auto

lemma bin_nth_1 [simp]: "bin_nth 1 n \<longleftrightarrow> n = 0"
  by (cases n) simp_all

lemma bin_nth_minus1 [simp]: "bin_nth (- 1) n"
  by (induct n) auto

lemma bin_nth_0_BIT: "bin_nth (w BIT b) 0 \<longleftrightarrow> b"
  by auto

lemma bin_nth_Suc_BIT: "bin_nth (w BIT b) (Suc n) = bin_nth w n"
  by auto

lemma bin_nth_minus [simp]: "0 < n ==> bin_nth (w BIT b) n = bin_nth w (n - 1)"
  by (cases n) auto

lemma bin_nth_numeral:
  "bin_rest x = y \<Longrightarrow> bin_nth x (numeral n) = bin_nth y (pred_numeral n)"
  by (simp add: numeral_eq_Suc)

lemmas bin_nth_numeral_simps [simp] =
  bin_nth_numeral [OF bin_rest_numeral_simps(2)]
  bin_nth_numeral [OF bin_rest_numeral_simps(5)]
  bin_nth_numeral [OF bin_rest_numeral_simps(6)]
  bin_nth_numeral [OF bin_rest_numeral_simps(7)]
  bin_nth_numeral [OF bin_rest_numeral_simps(8)]

lemmas bin_nth_simps =
  bin_nth.Z bin_nth.Suc bin_nth_zero bin_nth_minus1
  bin_nth_numeral_simps

subsection {* Truncating binary integers *}

definition bin_sign :: "int \<Rightarrow> int"
where
  bin_sign_def: "bin_sign k = (if k \<ge> 0 then 0 else - 1)"

lemma bin_sign_simps [simp]:
  "bin_sign 0 = 0"
  "bin_sign 1 = 0"
  "bin_sign (- 1) = - 1"
  "bin_sign (numeral k) = 0"
  "bin_sign (- numeral k) = -1"
  "bin_sign (w BIT b) = bin_sign w"
  unfolding bin_sign_def Bit_def
  by simp_all

lemma bin_sign_rest [simp]:
  "bin_sign (bin_rest w) = bin_sign w"
  by (cases w rule: bin_exhaust) auto

primrec bintrunc :: "nat \<Rightarrow> int \<Rightarrow> int" where
  Z : "bintrunc 0 bin = 0"
| Suc : "bintrunc (Suc n) bin = bintrunc n (bin_rest bin) BIT (bin_last bin)"

primrec sbintrunc :: "nat => int => int" where
  Z : "sbintrunc 0 bin = (if bin_last bin then -1 else 0)"
| Suc : "sbintrunc (Suc n) bin = sbintrunc n (bin_rest bin) BIT (bin_last bin)"

lemma sign_bintr: "bin_sign (bintrunc n w) = 0"
  by (induct n arbitrary: w) auto

lemma bintrunc_mod2p: "bintrunc n w = (w mod 2 ^ n)"
  apply (induct n arbitrary: w, clarsimp)
  apply (simp add: bin_last_def bin_rest_def Bit_def zmod_zmult2_eq)
  done

lemma sbintrunc_mod2p: "sbintrunc n w = (w + 2 ^ n) mod 2 ^ (Suc n) - 2 ^ n"
  apply (induct n arbitrary: w)
   apply simp
   apply (subst mod_add_left_eq)
   apply (simp add: bin_last_def)
   apply arith
  apply (simp add: bin_last_def bin_rest_def Bit_def)
  apply (clarsimp simp: mod_mult_mult1 [symmetric]
         zmod_zdiv_equality [THEN diff_eq_eq [THEN iffD2 [THEN sym]]])
  apply (rule trans [symmetric, OF _ emep1])
  apply auto
  done

subsection "Simplifications for (s)bintrunc"

lemma bintrunc_n_0 [simp]: "bintrunc n 0 = 0"
  by (induct n) auto

lemma sbintrunc_n_0 [simp]: "sbintrunc n 0 = 0"
  by (induct n) auto

lemma sbintrunc_n_minus1 [simp]: "sbintrunc n (- 1) = -1"
  by (induct n) auto

lemma bintrunc_Suc_numeral:
  "bintrunc (Suc n) 1 = 1"
  "bintrunc (Suc n) (- 1) = bintrunc n (- 1) BIT True"
  "bintrunc (Suc n) (numeral (Num.Bit0 w)) = bintrunc n (numeral w) BIT False"
  "bintrunc (Suc n) (numeral (Num.Bit1 w)) = bintrunc n (numeral w) BIT True"
  "bintrunc (Suc n) (- numeral (Num.Bit0 w)) =
    bintrunc n (- numeral w) BIT False"
  "bintrunc (Suc n) (- numeral (Num.Bit1 w)) =
    bintrunc n (- numeral (w + Num.One)) BIT True"
  by simp_all

lemma sbintrunc_0_numeral [simp]:
  "sbintrunc 0 1 = -1"
  "sbintrunc 0 (numeral (Num.Bit0 w)) = 0"
  "sbintrunc 0 (numeral (Num.Bit1 w)) = -1"
  "sbintrunc 0 (- numeral (Num.Bit0 w)) = 0"
  "sbintrunc 0 (- numeral (Num.Bit1 w)) = -1"
  by simp_all

lemma sbintrunc_Suc_numeral:
  "sbintrunc (Suc n) 1 = 1"
  "sbintrunc (Suc n) (numeral (Num.Bit0 w)) =
    sbintrunc n (numeral w) BIT False"
  "sbintrunc (Suc n) (numeral (Num.Bit1 w)) =
    sbintrunc n (numeral w) BIT True"
  "sbintrunc (Suc n) (- numeral (Num.Bit0 w)) =
    sbintrunc n (- numeral w) BIT False"
  "sbintrunc (Suc n) (- numeral (Num.Bit1 w)) =
    sbintrunc n (- numeral (w + Num.One)) BIT True"
  by simp_all

lemma bin_sign_lem: "(bin_sign (sbintrunc n bin) = -1) = bin_nth bin n"
  apply (induct n arbitrary: bin)
  apply (case_tac bin rule: bin_exhaust, case_tac b, auto)
  done

lemma nth_bintr: "bin_nth (bintrunc m w) n = (n < m & bin_nth w n)"
  apply (induct n arbitrary: w m)
   apply (case_tac m, auto)[1]
  apply (case_tac m, auto)[1]
  done

lemma nth_sbintr:
  "bin_nth (sbintrunc m w) n =
          (if n < m then bin_nth w n else bin_nth w m)"
  apply (induct n arbitrary: w m)
  apply (case_tac m)
  apply simp_all
  apply (case_tac m)
  apply simp_all
  done

lemma bin_nth_Bit:
  "bin_nth (w BIT b) n = (n = 0 & b | (EX m. n = Suc m & bin_nth w m))"
  by (cases n) auto

lemma bin_nth_Bit0:
  "bin_nth (numeral (Num.Bit0 w)) n \<longleftrightarrow>
    (\<exists>m. n = Suc m \<and> bin_nth (numeral w) m)"
  using bin_nth_Bit [where w="numeral w" and b="False"] by simp

lemma bin_nth_Bit1:
  "bin_nth (numeral (Num.Bit1 w)) n \<longleftrightarrow>
    n = 0 \<or> (\<exists>m. n = Suc m \<and> bin_nth (numeral w) m)"
  using bin_nth_Bit [where w="numeral w" and b="True"] by simp

lemma bintrunc_bintrunc_l:
  "n <= m ==> (bintrunc m (bintrunc n w) = bintrunc n w)"
  by (rule bin_eqI) (auto simp add : nth_bintr)

lemma sbintrunc_sbintrunc_l:
  "n <= m ==> (sbintrunc m (sbintrunc n w) = sbintrunc n w)"
  by (rule bin_eqI) (auto simp: nth_sbintr)

lemma bintrunc_bintrunc_ge:
  "n <= m ==> (bintrunc n (bintrunc m w) = bintrunc n w)"
  by (rule bin_eqI) (auto simp: nth_bintr)

lemma bintrunc_bintrunc_min [simp]:
  "bintrunc m (bintrunc n w) = bintrunc (min m n) w"
  apply (rule bin_eqI)
  apply (auto simp: nth_bintr)
  done

lemma sbintrunc_sbintrunc_min [simp]:
  "sbintrunc m (sbintrunc n w) = sbintrunc (min m n) w"
  apply (rule bin_eqI)
  apply (auto simp: nth_sbintr min.absorb1 min.absorb2)
  done

lemmas bintrunc_Pls =
  bintrunc.Suc [where bin="0", simplified bin_last_numeral_simps bin_rest_numeral_simps]

lemmas bintrunc_Min [simp] =
  bintrunc.Suc [where bin="-1", simplified bin_last_numeral_simps bin_rest_numeral_simps]

lemmas bintrunc_BIT  [simp] =
  bintrunc.Suc [where bin="w BIT b", simplified bin_last_BIT bin_rest_BIT] for w b

lemmas bintrunc_Sucs = bintrunc_Pls bintrunc_Min bintrunc_BIT
  bintrunc_Suc_numeral

lemmas sbintrunc_Suc_Pls =
  sbintrunc.Suc [where bin="0", simplified bin_last_numeral_simps bin_rest_numeral_simps]

lemmas sbintrunc_Suc_Min =
  sbintrunc.Suc [where bin="-1", simplified bin_last_numeral_simps bin_rest_numeral_simps]

lemmas sbintrunc_Suc_BIT [simp] =
  sbintrunc.Suc [where bin="w BIT b", simplified bin_last_BIT bin_rest_BIT] for w b

lemmas sbintrunc_Sucs = sbintrunc_Suc_Pls sbintrunc_Suc_Min sbintrunc_Suc_BIT
  sbintrunc_Suc_numeral

lemmas sbintrunc_Pls =
  sbintrunc.Z [where bin="0",
               simplified bin_last_numeral_simps bin_rest_numeral_simps]

lemmas sbintrunc_Min =
  sbintrunc.Z [where bin="-1",
               simplified bin_last_numeral_simps bin_rest_numeral_simps]

lemmas sbintrunc_0_BIT_B0 [simp] =
  sbintrunc.Z [where bin="w BIT False",
               simplified bin_last_numeral_simps bin_rest_numeral_simps] for w

lemmas sbintrunc_0_BIT_B1 [simp] =
  sbintrunc.Z [where bin="w BIT True",
               simplified bin_last_BIT bin_rest_numeral_simps] for w

lemmas sbintrunc_0_simps =
  sbintrunc_Pls sbintrunc_Min sbintrunc_0_BIT_B0 sbintrunc_0_BIT_B1

lemmas bintrunc_simps = bintrunc.Z bintrunc_Sucs
lemmas sbintrunc_simps = sbintrunc_0_simps sbintrunc_Sucs

lemma bintrunc_minus:
  "0 < n ==> bintrunc (Suc (n - 1)) w = bintrunc n w"
  by auto

lemma sbintrunc_minus:
  "0 < n ==> sbintrunc (Suc (n - 1)) w = sbintrunc n w"
  by auto

lemmas bintrunc_minus_simps =
  bintrunc_Sucs [THEN [2] bintrunc_minus [symmetric, THEN trans]]
lemmas sbintrunc_minus_simps =
  sbintrunc_Sucs [THEN [2] sbintrunc_minus [symmetric, THEN trans]]

lemmas thobini1 = arg_cong [where f = "%w. w BIT b"] for b

lemmas bintrunc_BIT_I = trans [OF bintrunc_BIT thobini1]
lemmas bintrunc_Min_I = trans [OF bintrunc_Min thobini1]

lemmas bmsts = bintrunc_minus_simps(1-3) [THEN thobini1 [THEN [2] trans]]
lemmas bintrunc_Pls_minus_I = bmsts(1)
lemmas bintrunc_Min_minus_I = bmsts(2)
lemmas bintrunc_BIT_minus_I = bmsts(3)

lemma bintrunc_Suc_lem:
  "bintrunc (Suc n) x = y ==> m = Suc n ==> bintrunc m x = y"
  by auto

lemmas bintrunc_Suc_Ialts =
  bintrunc_Min_I [THEN bintrunc_Suc_lem]
  bintrunc_BIT_I [THEN bintrunc_Suc_lem]

lemmas sbintrunc_BIT_I = trans [OF sbintrunc_Suc_BIT thobini1]

lemmas sbintrunc_Suc_Is =
  sbintrunc_Sucs(1-3) [THEN thobini1 [THEN [2] trans]]

lemmas sbintrunc_Suc_minus_Is =
  sbintrunc_minus_simps(1-3) [THEN thobini1 [THEN [2] trans]]

lemma sbintrunc_Suc_lem:
  "sbintrunc (Suc n) x = y ==> m = Suc n ==> sbintrunc m x = y"
  by auto

lemmas sbintrunc_Suc_Ialts =
  sbintrunc_Suc_Is [THEN sbintrunc_Suc_lem]

lemma sbintrunc_bintrunc_lt:
  "m > n ==> sbintrunc n (bintrunc m w) = sbintrunc n w"
  by (rule bin_eqI) (auto simp: nth_sbintr nth_bintr)

lemma bintrunc_sbintrunc_le:
  "m <= Suc n ==> bintrunc m (sbintrunc n w) = bintrunc m w"
  apply (rule bin_eqI)
  apply (auto simp: nth_sbintr nth_bintr)
   apply (subgoal_tac "x=n", safe, arith+)[1]
  apply (subgoal_tac "x=n", safe, arith+)[1]
  done

lemmas bintrunc_sbintrunc [simp] = order_refl [THEN bintrunc_sbintrunc_le]
lemmas sbintrunc_bintrunc [simp] = lessI [THEN sbintrunc_bintrunc_lt]
lemmas bintrunc_bintrunc [simp] = order_refl [THEN bintrunc_bintrunc_l]
lemmas sbintrunc_sbintrunc [simp] = order_refl [THEN sbintrunc_sbintrunc_l]

lemma bintrunc_sbintrunc' [simp]:
  "0 < n \<Longrightarrow> bintrunc n (sbintrunc (n - 1) w) = bintrunc n w"
  by (cases n) (auto simp del: bintrunc.Suc)

lemma sbintrunc_bintrunc' [simp]:
  "0 < n \<Longrightarrow> sbintrunc (n - 1) (bintrunc n w) = sbintrunc (n - 1) w"
  by (cases n) (auto simp del: bintrunc.Suc)

lemma bin_sbin_eq_iff:
  "bintrunc (Suc n) x = bintrunc (Suc n) y <->
   sbintrunc n x = sbintrunc n y"
  apply (rule iffI)
   apply (rule box_equals [OF _ sbintrunc_bintrunc sbintrunc_bintrunc])
   apply simp
  apply (rule box_equals [OF _ bintrunc_sbintrunc bintrunc_sbintrunc])
  apply simp
  done

lemma bin_sbin_eq_iff':
  "0 < n \<Longrightarrow> bintrunc n x = bintrunc n y <->
            sbintrunc (n - 1) x = sbintrunc (n - 1) y"
  by (cases n) (simp_all add: bin_sbin_eq_iff del: bintrunc.Suc)

lemmas bintrunc_sbintruncS0 [simp] = bintrunc_sbintrunc' [unfolded One_nat_def]
lemmas sbintrunc_bintruncS0 [simp] = sbintrunc_bintrunc' [unfolded One_nat_def]

lemmas bintrunc_bintrunc_l' = le_add1 [THEN bintrunc_bintrunc_l]
lemmas sbintrunc_sbintrunc_l' = le_add1 [THEN sbintrunc_sbintrunc_l]

(* although bintrunc_minus_simps, if added to default simpset,
  tends to get applied where it's not wanted in developing the theories,
  we get a version for when the word length is given literally *)

lemmas nat_non0_gr =
  trans [OF iszero_def [THEN Not_eq_iff [THEN iffD2]] refl]

lemma bintrunc_numeral:
  "bintrunc (numeral k) x =
    bintrunc (pred_numeral k) (bin_rest x) BIT bin_last x"
  by (simp add: numeral_eq_Suc)

lemma sbintrunc_numeral:
  "sbintrunc (numeral k) x =
    sbintrunc (pred_numeral k) (bin_rest x) BIT bin_last x"
  by (simp add: numeral_eq_Suc)

lemma bintrunc_numeral_simps [simp]:
  "bintrunc (numeral k) (numeral (Num.Bit0 w)) =
    bintrunc (pred_numeral k) (numeral w) BIT False"
  "bintrunc (numeral k) (numeral (Num.Bit1 w)) =
    bintrunc (pred_numeral k) (numeral w) BIT True"
  "bintrunc (numeral k) (- numeral (Num.Bit0 w)) =
    bintrunc (pred_numeral k) (- numeral w) BIT False"
  "bintrunc (numeral k) (- numeral (Num.Bit1 w)) =
    bintrunc (pred_numeral k) (- numeral (w + Num.One)) BIT True"
  "bintrunc (numeral k) 1 = 1"
  by (simp_all add: bintrunc_numeral)

lemma sbintrunc_numeral_simps [simp]:
  "sbintrunc (numeral k) (numeral (Num.Bit0 w)) =
    sbintrunc (pred_numeral k) (numeral w) BIT False"
  "sbintrunc (numeral k) (numeral (Num.Bit1 w)) =
    sbintrunc (pred_numeral k) (numeral w) BIT True"
  "sbintrunc (numeral k) (- numeral (Num.Bit0 w)) =
    sbintrunc (pred_numeral k) (- numeral w) BIT False"
  "sbintrunc (numeral k) (- numeral (Num.Bit1 w)) =
    sbintrunc (pred_numeral k) (- numeral (w + Num.One)) BIT True"
  "sbintrunc (numeral k) 1 = 1"
  by (simp_all add: sbintrunc_numeral)

lemma no_bintr_alt1: "bintrunc n = (\<lambda>w. w mod 2 ^ n :: int)"
  by (rule ext) (rule bintrunc_mod2p)

lemma range_bintrunc: "range (bintrunc n) = {i. 0 <= i & i < 2 ^ n}"
  apply (unfold no_bintr_alt1)
  apply (auto simp add: image_iff)
  apply (rule exI)
  apply (auto intro: int_mod_lem [THEN iffD1, symmetric])
  done

lemma no_sbintr_alt2:
  "sbintrunc n = (%w. (w + 2 ^ n) mod 2 ^ Suc n - 2 ^ n :: int)"
  by (rule ext) (simp add : sbintrunc_mod2p)

lemma range_sbintrunc:
  "range (sbintrunc n) = {i. - (2 ^ n) <= i & i < 2 ^ n}"
  apply (unfold no_sbintr_alt2)
  apply (auto simp add: image_iff eq_diff_eq)
  apply (rule exI)
  apply (auto intro: int_mod_lem [THEN iffD1, symmetric])
  done

lemma sb_inc_lem:
  "(a::int) + 2^k < 0 \<Longrightarrow> a + 2^k + 2^(Suc k) <= (a + 2^k) mod 2^(Suc k)"
  apply (erule int_mod_ge' [where n = "2 ^ (Suc k)" and b = "a + 2 ^ k", simplified zless2p])
  apply (rule TrueI)
  done

lemma sb_inc_lem':
  "(a::int) < - (2^k) \<Longrightarrow> a + 2^k + 2^(Suc k) <= (a + 2^k) mod 2^(Suc k)"
  by (rule sb_inc_lem) simp

lemma sbintrunc_inc:
  "x < - (2^n) ==> x + 2^(Suc n) <= sbintrunc n x"
  unfolding no_sbintr_alt2 by (drule sb_inc_lem') simp

lemma sb_dec_lem:
  "(0::int) \<le> - (2 ^ k) + a \<Longrightarrow> (a + 2 ^ k) mod (2 * 2 ^ k) \<le> - (2 ^ k) + a"
  using int_mod_le'[where n = "2 ^ (Suc k)" and b = "a + 2 ^ k"] by simp

lemma sb_dec_lem':
  "(2::int) ^ k \<le> a \<Longrightarrow> (a + 2 ^ k) mod (2 * 2 ^ k) \<le> - (2 ^ k) + a"
  by (rule sb_dec_lem) simp

lemma sbintrunc_dec:
  "x >= (2 ^ n) ==> x - 2 ^ (Suc n) >= sbintrunc n x"
  unfolding no_sbintr_alt2 by (drule sb_dec_lem') simp

lemmas zmod_uminus' = zminus_zmod [where m=c] for c
lemmas zpower_zmod' = power_mod [where b=c and n=k] for c k

lemmas brdmod1s' [symmetric] =
  mod_add_left_eq mod_add_right_eq
  mod_diff_left_eq mod_diff_right_eq
  mod_mult_left_eq mod_mult_right_eq

lemmas brdmods' [symmetric] =
  zpower_zmod' [symmetric]
  trans [OF mod_add_left_eq mod_add_right_eq]
  trans [OF mod_diff_left_eq mod_diff_right_eq]
  trans [OF mod_mult_right_eq mod_mult_left_eq]
  zmod_uminus' [symmetric]
  mod_add_left_eq [where b = "1::int"]
  mod_diff_left_eq [where b = "1::int"]

lemmas bintr_arith1s =
  brdmod1s' [where c="2^n::int", folded bintrunc_mod2p] for n
lemmas bintr_ariths =
  brdmods' [where c="2^n::int", folded bintrunc_mod2p] for n

lemmas m2pths = pos_mod_sign pos_mod_bound [OF zless2p]

lemma bintr_ge0: "0 \<le> bintrunc n w"
  by (simp add: bintrunc_mod2p)

lemma bintr_lt2p: "bintrunc n w < 2 ^ n"
  by (simp add: bintrunc_mod2p)

lemma bintr_Min: "bintrunc n (- 1) = 2 ^ n - 1"
  by (simp add: bintrunc_mod2p m1mod2k)

lemma sbintr_ge: "- (2 ^ n) \<le> sbintrunc n w"
  by (simp add: sbintrunc_mod2p)

lemma sbintr_lt: "sbintrunc n w < 2 ^ n"
  by (simp add: sbintrunc_mod2p)

lemma sign_Pls_ge_0:
  "(bin_sign bin = 0) = (bin >= (0 :: int))"
  unfolding bin_sign_def by simp

lemma sign_Min_lt_0:
  "(bin_sign bin = -1) = (bin < (0 :: int))"
  unfolding bin_sign_def by simp

lemma bin_rest_trunc:
  "(bin_rest (bintrunc n bin)) = bintrunc (n - 1) (bin_rest bin)"
  by (induct n arbitrary: bin) auto

lemma bin_rest_power_trunc:
  "(bin_rest ^^ k) (bintrunc n bin) =
    bintrunc (n - k) ((bin_rest ^^ k) bin)"
  by (induct k) (auto simp: bin_rest_trunc)

lemma bin_rest_trunc_i:
  "bintrunc n (bin_rest bin) = bin_rest (bintrunc (Suc n) bin)"
  by auto

lemma bin_rest_strunc:
  "bin_rest (sbintrunc (Suc n) bin) = sbintrunc n (bin_rest bin)"
  by (induct n arbitrary: bin) auto

lemma bintrunc_rest [simp]:
  "bintrunc n (bin_rest (bintrunc n bin)) = bin_rest (bintrunc n bin)"
  apply (induct n arbitrary: bin, simp)
  apply (case_tac bin rule: bin_exhaust)
  apply (auto simp: bintrunc_bintrunc_l)
  done

lemma sbintrunc_rest [simp]:
  "sbintrunc n (bin_rest (sbintrunc n bin)) = bin_rest (sbintrunc n bin)"
  apply (induct n arbitrary: bin, simp)
  apply (case_tac bin rule: bin_exhaust)
  apply (auto simp: bintrunc_bintrunc_l split: bool.splits)
  done

lemma bintrunc_rest':
  "bintrunc n o bin_rest o bintrunc n = bin_rest o bintrunc n"
  by (rule ext) auto

lemma sbintrunc_rest' :
  "sbintrunc n o bin_rest o sbintrunc n = bin_rest o sbintrunc n"
  by (rule ext) auto

lemma rco_lem:
  "f o g o f = g o f ==> f o (g o f) ^^ n = g ^^ n o f"
  apply (rule ext)
  apply (induct_tac n)
   apply (simp_all (no_asm))
  apply (drule fun_cong)
  apply (unfold o_def)
  apply (erule trans)
  apply simp
  done

lemmas rco_bintr = bintrunc_rest'
  [THEN rco_lem [THEN fun_cong], unfolded o_def]
lemmas rco_sbintr = sbintrunc_rest'
  [THEN rco_lem [THEN fun_cong], unfolded o_def]

subsection {* Splitting and concatenation *}

primrec bin_split :: "nat \<Rightarrow> int \<Rightarrow> int \<times> int" where
  Z: "bin_split 0 w = (w, 0)"
  | Suc: "bin_split (Suc n) w = (let (w1, w2) = bin_split n (bin_rest w)
        in (w1, w2 BIT bin_last w))"

primrec bin_cat :: "int \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int" where
  Z: "bin_cat w 0 v = w"
  | Suc: "bin_cat w (Suc n) v = bin_cat w n (bin_rest v) BIT bin_last v"

end