theory Girth_Chromatic
imports
  Ugraphs
  Girth_Chromatic_Misc
  "HOL-Probability.Probability"
  "HOL-Decision_Procs.Approximation"
begin

section \<open>Probability Space on Sets of Edges\<close>

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: sum.reindex sum_distrib_left[symmetric] ac_simps
                  insert.hyps sum.union_disjoint Pow_insert)
qed simp

text \<open>Definition of the probability space on edges:\<close>
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
    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" \<comment> \<open>Sum of probabilities equals 1\<close>
    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] p_prob unfolding emeasure_eq_measure by (simp add: sum_nonneg)

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!: sum.cong)

text \<open>Probability of cylinder sets:\<close>
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 sum_distrib_left 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: sum.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. ennreal (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 ennreal_mult[symmetric])
qed

end

subsection \<open>Graph Probabilities outside of @{term Edge_Space} locale\<close>

text \<open>
 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.
\<close>

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 \<open>Short cycles\<close>

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 \<open>obtains a vertex in a short cycle:\<close>
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 \<open>?cv \<in> set p\<close> by (auto simp: short_cycles_def ucycles_def uwalks_def verts_Gu)
  ultimately show ?thesis using \<open>p \<in> short_cycles G k\<close> by auto
qed

text \<open>Induction rule for @{term kill_short}:\<close>
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 \<open>Large Girth (after @{term kill_short}):\<close>
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 \<open>Order of graph (after @{term kill_short}):\<close>
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 \<open>Independence number (after @{term kill_short}):\<close>
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 \<open>Wellformedness (after @{term kill_short}):\<close>
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 \<open>The Chromatic-Girth Theorem\<close>

text \<open>Probability of Independent Edges:\<close>
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
    \<comment> \<open>probability that a fixed set of k vertices is independent in a random graph\<close>

  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 S_verts_def n_subsets)
  finally show ?thesis using \<open>k \<ge> 2\<close> by (simp add: le_\<alpha>_iff)
qed

text \<open>Almost never many independent edges:\<close>
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))) \<longlonglongrightarrow> 0"
    (is "(\<lambda>n. ?prob_fun n) \<longlonglongrightarrow> 0")
proof -
  let "?prob_fun_raw n" = "probGn p n (\<lambda>es. nat(ceiling (1/2*n/k)) \<le> \<alpha> (edge_space.edge_ugraph n es))"

  define r where "r n = 1 / 2 * n / k" for n :: nat
  let ?nr = "\<lambda>n. nat(ceiling (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 nat_ceiling_le_eq 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 - Suc 0) = real (?nr n) - Suc 0" using A by auto

    have [simp]: "n>0" using A by linarith
    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 of_nat_power [symmetric] binomial_le_pow  del: 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 add: powr_powr r ac_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_nat_ceiling_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 le_of_int_ceiling[of "n/2*k"]
        by (simp add: r_def field_simps del: le_of_int_ceiling)
      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> nat(ceiling (1/2*n/k)) \<le> \<alpha> G"
    by (case_tac "\<alpha> G") (auto simp: nat_ceiling_le_eq)

  show ?thesis
  proof (unfold ceil_bound, rule real_tendsto_sandwich)
    show "(\<lambda>n. 0) \<longlonglongrightarrow> 0"
        "(\<lambda>n. (exp 1 / n) powr (1 / 2)) \<longlonglongrightarrow> 0"
        "\<forall>\<^sup>\<infinity> n. 0 \<le> ?prob_fun_raw n"
      using p_prob by (auto intro: measure_nonneg LIMSEQ_inv_powr elim: eventually_mono)
  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 (nat(ceiling (r n))) - 1) / 2) \<le> (exp 1 / n) powr (1 / 2)"

      have "exp 1 < (3 :: real)" by (approximation 6)
      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 A by (auto simp: powr_le_one_le)
      finally show "?prob_fun_raw n \<le> (exp 1 / n) powr (1 / 2)" .
    qed
  qed
qed

text \<open>Mean number of k-cycles in a graph. (Or rather of paths describing a circle of length @{term k}):\<close>
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)
    = of_nat (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"
  define C where "C k = {c. ?k_cycle S_edges c k}" for k
    \<comment> \<open>@{term "C k"} is the set of all possible cycles of size @{term k} in @{term "edge_ugraph S_edges"}\<close>
  define XG  where "XG es = {c. ?k_cycle es c k}" for es
    \<comment> \<open>@{term "XG es"} is the set of cycles contained in a @{term "edge_ugraph es"}\<close>
  define XC where "XC c = {es \<in> space P. ?k_cycle es c k}" for c
    \<comment> \<open>"@{term "XC c"} is the set of graphs (edge sets) containing a cycle c"\<close>
  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
    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: sum.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 sum.swap) (simp add: sum.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!: sum.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> = of_nat (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: if_split_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 \<open>3 \<le> k\<close>
    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 \<open>k < n\<close>
      by (simp add: card_image[OF inj_last_Cons] card_lists_distinct_length_eq' fact_div_fact)
    then show ?thesis by simp
  qed
  finally show ?thesis by simp
qed

text \<open>Girth-Chromatic number theorem:\<close>
theorem girth_chromatic:
  fixes l :: nat
  shows "\<exists>G. uwellformed G \<and> l < girth G \<and> l < chromatic_number G"
proof -
  define k where "k = max 3 l"
  define \<epsilon> where "\<epsilon> = 1 / (2 * k)"
  define p where "p n = real n powr (\<epsilon> - 1)" for n :: nat

  let ?ug = edge_space.edge_ugraph

  define short_count where "short_count g = card (short_cycles g k)" for g
    \<comment> \<open>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\<close>

  from k_def have "3 \<le> k" "l \<le> k" by auto
  from \<open>3 \<le> k\<close> have \<epsilon>_props: "0 < \<epsilon>" "\<epsilon> < 1 / k" "\<epsilon> < 1" by (auto simp: \<epsilon>_def 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 \<open>\<epsilon> < 1\<close> have "n powr (\<epsilon> - 1) < 1" by (auto intro!: powr_less_one)
    then show "0 < p n \<and> p n < 1" using \<open>2 \<le> n\<close>
      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

    define mean_short_count where "mean_short_count = (\<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 Bochner_Integration.integral_sum) (auto intro: pG.integral_finite_singleton)
      also have "\<dots> = (\<Sum>i\<in>{3..k}. of_nat (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)"
        apply (rule sum_mono)
        by (meson A fact_div_fact_le_pow  Suc_leD atLeastAtMost_iff of_nat_le_iff order_trans real_mult_le_cancel_iff1 zero_less_power)
      also have "... \<le> (\<Sum> i\<in>{3..k}. n powr (\<epsilon> * k))"
        using \<open>1 \<le> n\<close> \<open>0 < \<epsilon>\<close> A
        by (intro sum_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
    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 \<open>1 \<le> n\<close>
      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 \<open>1 \<le> n\<close> by (simp add: field_simps)
      then show ?thesis by (simp add: powr_diff algebra_simps)
    qed
    finally show "?P n" .
  qed

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

  have ev_short_count_le: "\<forall>\<^sup>\<infinity> n. pf_short_count n < 1 / 2"
  proof -
    have "\<epsilon> * k - 1 < 0"
      using \<epsilon>_props \<open>3 \<le> k\<close> by (auto simp: field_simps)
    then have "(\<lambda>n. 2 * (k - 2) * n powr (\<epsilon> * k - 1)) \<longlonglongrightarrow> 0" (is "?bound \<longlonglongrightarrow> 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> \<longlonglongrightarrow> 0"
  proof -
    have "0 < k" using \<open>3 \<le> k\<close> 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))"
        using \<open>1 \<le> n\<close> by (auto simp: field_simps)
      also have "\<dots> \<longleftrightarrow> (6*k) * ln n * n powr - \<epsilon> \<le> 1"
        by (simp add: powr_diff [symmetric] )
      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 \<open>0 < n\<close> \<open>0 < \<epsilon>\<close> 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 \<open>0 < n\<close> \<open>0 < k\<close> 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)) \<longlonglongrightarrow> 0"
          using \<open>0 < \<epsilon>\<close> by (intro tendsto_mult_right_zero LIMSEQ_neg_powr) auto
        then show ?thesis
          using \<open>0 < \<epsilon>\<close> by - (drule tendstoD[where e=1], auto elim: eventually_mono)
      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 \<open>0 < k\<close> 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
    \<comment> \<open>now we obtained a high colored graph (few independent nodes) with almost no short cycles\<close>

  define G where "G = ?ug n es"
  define H where "H = 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 \<open>l \<le> k\<close> 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 \<open>l \<le> k\<close> by auto
  also have "\<dots> < (n/2) / \<alpha> G" using G_props \<open>3 \<le> k\<close>
    by (cases "\<alpha> G") (auto simp: field_simps)
  also have "\<dots> \<le> (n/2) / \<alpha> H" using \<alpha>_HG \<open>0 < \<alpha> H\<close>
    by (auto simp: ereal_of_enat_pushout intro!: ereal_divide_left_mono)
  also have "\<dots> \<le> card (uverts H) / \<alpha> H" using card_H \<open>0 < \<alpha> H\<close>
    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 del: ereal_of_enat_simps)

  from T1 T2 T3 show ?thesis by fast
qed

end


section \<open>\isaheader{Orderings By Comparison Operator}\<close>
theory Intf_Comp
imports
  "../../../Automatic_Refinement/Automatic_Refinement"
begin

subsection \<open>Basic Definitions\<close>

datatype comp_res = LESS | EQUAL | GREATER

consts i_comp_res :: interface
abbreviation "comp_res_rel \<equiv> Id :: (comp_res \<times> _) set"
lemmas [autoref_rel_intf] = REL_INTFI[of comp_res_rel i_comp_res]

definition "comp2le cmp a b \<equiv>
  case cmp a b of LESS \<Rightarrow> True | EQUAL \<Rightarrow> True | GREATER \<Rightarrow> False"

definition "comp2lt cmp a b \<equiv>
  case cmp a b of LESS \<Rightarrow> True | EQUAL \<Rightarrow> False | GREATER \<Rightarrow> False"

definition "comp2eq cmp a b \<equiv>
  case cmp a b of LESS \<Rightarrow> False | EQUAL \<Rightarrow> True | GREATER \<Rightarrow> False"

locale linorder_on =
  fixes D :: "'a set"
  fixes cmp :: "'a \<Rightarrow> 'a \<Rightarrow> comp_res"
  assumes lt_eq: "\<lbrakk>x\<in>D; y\<in>D\<rbrakk> \<Longrightarrow> cmp x y = LESS \<longleftrightarrow> (cmp y x = GREATER)"
  assumes refl[simp, intro!]: "x\<in>D \<Longrightarrow> cmp x x = EQUAL"
  assumes trans[trans]:
    "\<lbrakk> x\<in>D; y\<in>D; z\<in>D; cmp x y = LESS; cmp y z = LESS\<rbrakk> \<Longrightarrow> cmp x z = LESS"
    "\<lbrakk> x\<in>D; y\<in>D; z\<in>D; cmp x y = LESS; cmp y z = EQUAL\<rbrakk> \<Longrightarrow> cmp x z = LESS"
    "\<lbrakk> x\<in>D; y\<in>D; z\<in>D; cmp x y = EQUAL; cmp y z = LESS\<rbrakk> \<Longrightarrow> cmp x z = LESS"
    "\<lbrakk> x\<in>D; y\<in>D; z\<in>D; cmp x y = EQUAL; cmp y z = EQUAL\<rbrakk> \<Longrightarrow> cmp x z = EQUAL"
begin
  abbreviation "le \<equiv> comp2le cmp"
  abbreviation "lt \<equiv> comp2lt cmp"

  lemma eq_sym: "\<lbrakk>x\<in>D; y\<in>D\<rbrakk> \<Longrightarrow> cmp x y = EQUAL \<Longrightarrow> cmp y x = EQUAL"
    apply (cases "cmp y x")
    using lt_eq lt_eq[symmetric]
    by auto
end

abbreviation "linorder \<equiv> linorder_on UNIV"

lemma linorder_to_class:
  assumes "linorder cmp"
  assumes [simp]: "\<And>x y. cmp x y = EQUAL \<Longrightarrow> x=y"
  shows "class.linorder (comp2le cmp) (comp2lt cmp)"
proof -
  interpret linorder_on UNIV cmp by fact
  show ?thesis
    apply (unfold_locales)
    unfolding comp2le_def comp2lt_def
    apply (auto split: comp_res.split comp_res.split_asm)
    using lt_eq apply simp
    using lt_eq apply simp
    using lt_eq[symmetric] apply simp
    apply (drule (1) trans[rotated 3], simp_all) []
    apply (drule (1) trans[rotated 3], simp_all) []
    apply (drule (1) trans[rotated 3], simp_all) []
    apply (drule (1) trans[rotated 3], simp_all) []
    using lt_eq apply simp
    using lt_eq apply simp
    using lt_eq[symmetric] apply simp
    done
qed

definition "dflt_cmp le lt a b \<equiv>
  if lt a b then LESS
  else if le a b then EQUAL
  else GREATER"

lemma (in linorder) class_to_linorder:
  "linorder (dflt_cmp (\<le>) (<))"
  apply (unfold_locales)
  unfolding dflt_cmp_def
  by (auto split: if_split_asm)

lemma restrict_linorder: "\<lbrakk>linorder_on D cmp ; D'\<subseteq>D\<rbrakk> \<Longrightarrow> linorder_on D' cmp"
  apply (rule linorder_on.intro)
  apply (drule (1) rev_subsetD)+
  apply (erule (2) linorder_on.lt_eq)
  apply (drule (1) rev_subsetD)+
  apply (erule (1) linorder_on.refl)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  done

subsection \<open>Operations on Linear Orderings\<close>

text \<open>Map with injective function\<close>
definition cmp_img where "cmp_img f cmp a b \<equiv> cmp (f a) (f b)"

lemma img_linorder[intro?]:
  assumes LO: "linorder_on (f`D) cmp"
  shows "linorder_on D (cmp_img f cmp)"
  apply unfold_locales
  unfolding cmp_img_def
  apply (rule linorder_on.lt_eq[OF LO], auto) []
  apply (rule linorder_on.refl[OF LO], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  done

text \<open>Combine\<close>
definition "cmp_combine D1 cmp1 D2 cmp2 a b \<equiv>
  if a\<in>D1 \<and> b\<in>D1 then cmp1 a b
  else if a\<in>D1 \<and> b\<in>D2 then LESS
  else if a\<in>D2 \<and> b\<in>D1 then GREATER
  else cmp2 a b
"

(* TODO: Move *)
lemma UnE':
  assumes "x\<in>A\<union>B"
  obtains "x\<in>A" | "x\<notin>A" "x\<in>B"
  using assms by blast

lemma combine_linorder[intro?]:
  assumes "linorder_on D1 cmp1"
  assumes "linorder_on D2 cmp2"
  assumes "D = D1\<union>D2"
  shows "linorder_on D (cmp_combine D1 cmp1 D2 cmp2)"
  apply unfold_locales
  unfolding cmp_combine_def
  using assms apply -
  apply (simp only:)
  apply (elim UnE)
  apply (auto dest: linorder_on.lt_eq) [4]

  apply (simp only:)
  apply (elim UnE)
  apply (auto dest: linorder_on.refl) [2]

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)
  done

subsection \<open>Universal Linear Ordering\<close>
text \<open>With Zorn's Lemma, we get a universal linear (even wf) ordering\<close>

definition "univ_order_rel \<equiv> (SOME r. well_order_on UNIV r)"
definition "univ_cmp x y \<equiv>
  if x=y then EQUAL
  else if (x,y)\<in>univ_order_rel then LESS
  else GREATER"

lemma univ_wo: "well_order_on UNIV univ_order_rel"
  unfolding univ_order_rel_def
  using well_order_on[of UNIV]
  ..

lemma univ_linorder[intro?]: "linorder univ_cmp"
  apply unfold_locales
  unfolding univ_cmp_def
  apply (auto split: if_split_asm)
  using univ_wo
  apply -
  unfolding well_order_on_def linear_order_on_def partial_order_on_def
    preorder_on_def
  apply (auto simp add: antisym_def) []
  apply (unfold total_on_def, fast) []
  apply (unfold trans_def, fast) []
  apply (auto simp add: antisym_def) []
  done

text \<open>Extend any linear order to a universal order\<close>
definition "cmp_extend D cmp \<equiv>
  cmp_combine D cmp UNIV univ_cmp"

lemma extend_linorder[intro?]:
  "linorder_on D cmp \<Longrightarrow> linorder (cmp_extend D cmp)"
  unfolding cmp_extend_def
  apply rule
  apply assumption
  apply rule
  by simp

subsubsection \<open>Lexicographic Order on Lists\<close>

fun cmp_lex where
  "cmp_lex cmp [] [] = EQUAL"
| "cmp_lex cmp [] _ = LESS"
| "cmp_lex cmp _ [] = GREATER"
| "cmp_lex cmp (a#l) (b#m) = (
    case cmp a b of
      LESS \<Rightarrow> LESS
    | EQUAL \<Rightarrow> cmp_lex cmp l m
    | GREATER \<Rightarrow> GREATER)"

primrec cmp_lex' where
  "cmp_lex' cmp [] m = (case m of [] \<Rightarrow> EQUAL | _ \<Rightarrow> LESS)"
| "cmp_lex' cmp (a#l) m = (case m of [] \<Rightarrow> GREATER | (b#m) \<Rightarrow>
    (case cmp a b of
      LESS \<Rightarrow> LESS
    | EQUAL \<Rightarrow> cmp_lex' cmp l m
    | GREATER \<Rightarrow> GREATER
  ))"

lemma cmp_lex_alt: "cmp_lex cmp l m = cmp_lex' cmp l m"
  apply (induct l arbitrary: m)
  apply (auto split: comp_res.split list.split)
  done

lemma (in linorder_on) lex_linorder[intro?]:
  "linorder_on (lists D) (cmp_lex cmp)"
proof
  fix l m
  assume "l\<in>lists D" "m\<in>lists D"
  thus "(cmp_lex cmp l m = LESS) = (cmp_lex cmp m l = GREATER)"
    apply (induct cmp\<equiv>cmp l m rule: cmp_lex.induct)
    apply (auto split: comp_res.split simp: lt_eq)
    apply (auto simp: lt_eq[symmetric])
    done
next
  fix x
  assume "x\<in>lists D"
  thus "cmp_lex cmp x x = EQUAL"
    by (induct x) auto
next
  fix x y z
  assume M: "x\<in>lists D" "y\<in>lists D" "z\<in>lists D"

  {
    assume "cmp_lex cmp x y = LESS" "cmp_lex cmp y z = LESS"
    thus "cmp_lex cmp x z = LESS"
      using M
      apply (induct cmp\<equiv>cmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z, auto) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      done
  }

  {
    assume "cmp_lex cmp x y = LESS" "cmp_lex cmp y z = EQUAL"
    thus "cmp_lex cmp x z = LESS"
      using M
      apply (induct cmp\<equiv>cmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z, auto) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      done
  }

  {
    assume "cmp_lex cmp x y = EQUAL" "cmp_lex cmp y z = LESS"
    thus "cmp_lex cmp x z = LESS"
      using M
      apply (induct cmp\<equiv>cmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      done
  }

  {
    assume "cmp_lex cmp x y = EQUAL" "cmp_lex cmp y z = EQUAL"
    thus "cmp_lex cmp x z = EQUAL"
      using M
      apply (induct cmp\<equiv>cmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (drule (4) trans, simp)+
      done
  }
qed

subsubsection \<open>Lexicographic Order on Pairs\<close>

fun cmp_prod where
  "cmp_prod cmp1 cmp2 (a1,a2) (b1,b2)
  = (
    case cmp1 a1 b1 of
      LESS \<Rightarrow> LESS
    | EQUAL \<Rightarrow> cmp2 a2 b2
    | GREATER \<Rightarrow> GREATER)"

lemma cmp_prod_alt: "cmp_prod = (\<lambda>cmp1 cmp2 (a1,a2) (b1,b2). (
    case cmp1 a1 b1 of
      LESS \<Rightarrow> LESS
    | EQUAL \<Rightarrow> cmp2 a2 b2
    | GREATER \<Rightarrow> GREATER))"
  by (auto intro!: ext)

  show ?thesis
    apply unfold_locales
    apply (auto split: comp_res.split comp_res.split_asm,
      simp_all add: A.lt_eq B.lt_eq,
      simp_all add: A.lt_eq[symmetric]
      ) []

    apply (auto split: comp_res.split comp_res.split_asm) []

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+
    done
qed

subsection \<open>Universal Ordering for Sets that is Effective for Finite Sets\<close>

subsubsection \<open>Sorted Lists of Sets\<close>
text \<open>Some more results about sorted lists of finite sets\<close>

lemma set_to_map_set_is_map_of:
  "distinct (map fst l) \<Longrightarrow> set_to_map (set l) = map_of l"
  apply (induct l)
  apply (auto simp: set_to_map_insert)
  done

context linorder begin

  lemma sorted_list_of_set_eq_nil2[simp]:
    assumes "finite A"
    shows "[] = sorted_list_of_set A \<longleftrightarrow> A={}"
    using assms
    by (auto dest: sym)

  lemma set_insort[simp]: "set (insort x l) = insert x (set l)"
    by (induct l) auto

  lemma sorted_list_of_set_inj_aux:
    fixes A B :: "'a set"
    assumes "finite A"
    assumes "finite B"
    assumes "sorted_list_of_set A = sorted_list_of_set B"
    shows "A=B"
    using assms
  proof -
    from \<open>finite B\<close> have "B = set (sorted_list_of_set B)" by simp
    also from assms have "\<dots> = set (sorted_list_of_set (A))"
      by simp
    also from \<open>finite A\<close>
    have "set (sorted_list_of_set (A)) = A"
      by simp
    finally show ?thesis by simp
  qed

  lemma sorted_list_of_set_inj: "inj_on sorted_list_of_set (Collect finite)"
    apply (rule inj_onI)
    using sorted_list_of_set_inj_aux
    by blast

  definition "sorted_list_of_map m \<equiv>
    map (\<lambda>k. (k, the (m k))) (sorted_list_of_set (dom m))"

  lemma the_sorted_list_of_map:
    assumes "distinct (map fst l)"
    assumes "sorted (map fst l)"
    shows "sorted_list_of_map (map_of l) = l"
  proof -
    have "dom (map_of l) = set (map fst l)" by (induct l) force+
    hence "sorted_list_of_set (dom (map_of l)) = map fst l"
      using sorted_list_of_set.idem_if_sorted_distinct[OF assms(2,1)] by simp
    hence "sorted_list_of_map (map_of l)
      = map (\<lambda>k. (k, the (map_of l k))) (map fst l)"
      unfolding sorted_list_of_map_def by simp
    also have "\<dots> = l" using \<open>distinct (map fst l)\<close>
    proof (induct l)
      case Nil thus ?case by simp
    next
      case (Cons a l)
      hence
        1: "distinct (map fst l)"
        and 2: "fst a\<notin>fst`set l"
        and 3: "map (\<lambda>k. (k, the (map_of l k))) (map fst l) = l"
        by simp_all

      from 2 have [simp]: "\<not>(\<exists>x\<in>set l. fst x = fst a)"
        by (auto simp: image_iff)

      show ?case
        apply simp
        apply (subst (3) 3[symmetric])
        apply simp
        done
    qed
    finally show ?thesis .
  qed

  lemma map_of_sorted_list_of_map[simp]:
    assumes FIN: "finite (dom m)"
    shows "map_of (sorted_list_of_map m) = m"
    unfolding sorted_list_of_map_def
  proof -
    have "set (sorted_list_of_set (dom m)) = dom m"
      and DIST: "distinct (sorted_list_of_set (dom m))"
      by (simp_all add: FIN)

    have [simp]: "(fst \<circ> (\<lambda>k. (k, the (m k)))) = id" by auto

    have [simp]: "(\<lambda>k. (k, the (m k))) ` dom m = map_to_set m"
      by (auto simp: map_to_set_def)

    show "map_of (map (\<lambda>k. (k, the (m k))) (sorted_list_of_set (dom m))) = m"
      apply (subst set_to_map_set_is_map_of[symmetric])
      apply (simp add: DIST)
      apply (subst set_map)
      apply (simp add: FIN map_to_set_inverse)
      done
  qed

  lemma sorted_list_of_map_inj_aux:
    fixes A B :: "'a\<rightharpoonup>'b"
    assumes [simp]: "finite (dom A)"
    assumes [simp]: "finite (dom B)"
    assumes E: "sorted_list_of_map A = sorted_list_of_map B"
    shows "A=B"
    using assms
  proof -
    have "A = map_of (sorted_list_of_map A)" by simp
    also note E
    also have "map_of (sorted_list_of_map B) = B" by simp
    finally show ?thesis .
  qed

  lemma sorted_list_of_map_inj:
    "inj_on sorted_list_of_map (Collect (finite o dom))"
    apply (rule inj_onI)
    using sorted_list_of_map_inj_aux
    by auto
end

definition "cmp_set cmp \<equiv>
  cmp_extend (Collect finite) (
    cmp_img
      (linorder.sorted_list_of_set (comp2le cmp))
      (cmp_lex cmp)
  )"

thm img_linorder

lemma set_ord_linear[intro?]:
  "linorder cmp \<Longrightarrow> linorder (cmp_set cmp)"
  unfolding cmp_set_def
  apply rule
  apply rule
  apply (rule restrict_linorder)
  apply (erule linorder_on.lex_linorder)
  apply simp
  done

definition "cmp_map cmpk cmpv \<equiv>
  cmp_extend (Collect (finite o dom)) (
    cmp_img
      (linorder.sorted_list_of_map (comp2le cmpk))
      (cmp_lex (cmp_prod cmpk cmpv))
  )
"

lemma map_to_set_inj[intro!]: "inj map_to_set"
  apply (rule inj_onI)
  unfolding map_to_set_def
  apply (rule ext)
  apply (case_tac "x xa")
  apply (case_tac [!] "y xa")
  apply force+
  done

corollary map_to_set_inj'[intro!]: "inj_on map_to_set S"
  by (metis map_to_set_inj subset_UNIV subset_inj_on)

lemma map_ord_linear[intro?]:
  assumes A: "linorder cmpk"
  assumes B: "linorder cmpv"
  shows "linorder (cmp_map cmpk cmpv)"
proof -
  interpret lk: linorder_on UNIV cmpk by fact
  interpret lv: linorder_on UNIV cmpv by fact

  show ?thesis
    unfolding cmp_map_def
    apply rule
    apply rule
    apply (rule restrict_linorder)
    apply (rule linorder_on.lex_linorder)
    apply (rule)
    apply fact
    apply fact
    apply simp
    done
qed

locale eq_linorder_on = linorder_on +
  assumes cmp_imp_equal: "\<lbrakk>x\<in>D; y\<in>D\<rbrakk> \<Longrightarrow> cmp x y = EQUAL \<Longrightarrow> x = y"
begin
  lemma cmp_eq[simp]: "\<lbrakk>x\<in>D; y\<in>D\<rbrakk> \<Longrightarrow> cmp x y = EQUAL \<longleftrightarrow> x = y"
    by (auto simp: cmp_imp_equal)
end

abbreviation "eq_linorder \<equiv> eq_linorder_on UNIV"

lemma dflt_cmp_2inv[simp]:
  "dflt_cmp (comp2le cmp) (comp2lt cmp) = cmp"
  unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
  apply (auto split: comp_res.splits intro!: ext)
  done

lemma (in linorder) dflt_cmp_inv2[simp]:
  shows
  "(comp2le (dflt_cmp (\<le>) (<)))= (\<le>)"
  "(comp2lt (dflt_cmp (\<le>) (<)))= (<)"
proof -
  show "(comp2lt (dflt_cmp (\<le>) (<)))= (<)"
    unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
    apply (auto split: comp_res.splits intro!: ext)
    done

  show "(comp2le (dflt_cmp (\<le>) (<))) = (\<le>)"
    unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
    apply (auto split: comp_res.splits intro!: ext)
    done

qed

lemma eq_linorder_class_conv:
  "eq_linorder cmp \<longleftrightarrow> class.linorder (comp2le cmp) (comp2lt cmp)"
proof
  assume "eq_linorder cmp"
  then interpret eq_linorder_on UNIV cmp .
  have "linorder cmp" by unfold_locales
  show "class.linorder (comp2le cmp) (comp2lt cmp)"
    apply (rule linorder_to_class)
    apply fact
    by simp
next
  assume "class.linorder (comp2le cmp) (comp2lt cmp)"
  then interpret linorder "comp2le cmp" "comp2lt cmp" .

  from class_to_linorder interpret linorder_on UNIV cmp
    by simp
  show "eq_linorder cmp"
  proof
    fix x y
    assume "cmp x y = EQUAL"
    hence "comp2le cmp x y" "\<not>comp2lt cmp x y"
      by (auto simp: comp2le_def comp2lt_def)
    thus "x=y" by simp
  qed
qed

lemma (in linorder) class_to_eq_linorder:
  "eq_linorder (dflt_cmp (\<le>) (<))"
proof -
  interpret linorder_on UNIV "dflt_cmp (\<le>) (<)"
    by (rule class_to_linorder)

  show ?thesis
    apply unfold_locales
    apply (auto simp: dflt_cmp_def split: if_split_asm)
    done
qed

lemma eq_linorder_comp2eq_eq:
  assumes "eq_linorder cmp"
  shows "comp2eq cmp = (=)"
proof -
  interpret eq_linorder_on UNIV cmp by fact
  show ?thesis
    apply (intro ext)
    unfolding comp2eq_def
    apply (auto split: comp_res.split dest: refl)
    done
qed

lemma restrict_eq_linorder:
  assumes "eq_linorder_on D cmp"
  assumes S: "D'\<subseteq>D"
  shows "eq_linorder_on D' cmp"
proof -
  interpret eq_linorder_on D cmp by fact

  show ?thesis
    apply (rule eq_linorder_on.intro)
    apply (rule restrict_linorder[where D=D])
    apply unfold_locales []
    apply fact
    apply unfold_locales
    using S
    apply -
    apply (drule (1) rev_subsetD)+
    apply auto
    done
qed

lemma combine_eq_linorder[intro?]:
  assumes A: "eq_linorder_on D1 cmp1"
  assumes B: "eq_linorder_on D2 cmp2"
  assumes EQ: "D=D1\<union>D2"
  shows "eq_linorder_on D (cmp_combine D1 cmp1 D2 cmp2)"
proof -
  interpret A: eq_linorder_on D1 cmp1 by fact
  interpret B: eq_linorder_on D2 cmp2 by fact
  interpret linorder_on "(D1 \<union> D2)" "(cmp_combine D1 cmp1 D2 cmp2)"
    apply rule
    apply unfold_locales
    by simp

  show ?thesis
    apply (simp only: EQ)
    apply unfold_locales
    unfolding cmp_combine_def
    by (auto split: if_split_asm)
qed

lemma img_eq_linorder[intro?]:
  assumes A: "eq_linorder_on (f`D) cmp"
  assumes INJ: "inj_on f D"
  shows "eq_linorder_on D (cmp_img f cmp)"
proof -
  interpret eq_linorder_on "f`D" cmp by fact
  interpret L: linorder_on "(D)" "(cmp_img f cmp)"
    apply rule
    apply unfold_locales
    done

  show ?thesis
    apply unfold_locales
    unfolding cmp_img_def
    using INJ
    apply (auto dest: inj_onD)
    done
qed

lemma univ_eq_linorder[intro?]:
  shows "eq_linorder univ_cmp"
  apply (rule eq_linorder_on.intro)
  apply rule
  apply unfold_locales
  unfolding univ_cmp_def
  apply (auto split: if_split_asm)
  done

lemma extend_eq_linorder[intro?]:
  assumes "eq_linorder_on D cmp"
  shows "eq_linorder (cmp_extend D cmp)"
proof -
  interpret eq_linorder_on D cmp by fact
  show ?thesis
    unfolding cmp_extend_def
    apply (rule)
    apply fact
    apply rule
    by simp
qed

lemma lex_eq_linorder[intro?]:
  assumes "eq_linorder_on D cmp"
  shows "eq_linorder_on (lists D) (cmp_lex cmp)"
proof -
  interpret eq_linorder_on D cmp by fact
  show ?thesis
    apply (rule eq_linorder_on.intro)
    apply rule
    apply unfold_locales
    subgoal for l m
      apply (induct cmp\<equiv>cmp l m rule: cmp_lex.induct)
      apply (auto split: comp_res.splits)
      done
    done
qed

lemma prod_eq_linorder[intro?]:
  assumes "eq_linorder_on D1 cmp1"
  assumes "eq_linorder_on D2 cmp2"
  shows "eq_linorder_on (D1\<times>D2) (cmp_prod cmp1 cmp2)"
proof -
  interpret A: eq_linorder_on D1 cmp1 by fact
  interpret B: eq_linorder_on D2 cmp2 by fact
  show ?thesis
    apply (rule eq_linorder_on.intro)
    apply rule
    apply unfold_locales
    apply (auto split: comp_res.splits)
    done
qed

lemma set_ord_eq_linorder[intro?]:
  "eq_linorder cmp \<Longrightarrow> eq_linorder (cmp_set cmp)"
  unfolding cmp_set_def
  apply rule
  apply rule
  apply (rule restrict_eq_linorder)
  apply rule
  apply assumption
  apply simp

  apply (rule linorder.sorted_list_of_set_inj)
  apply (subst (asm) eq_linorder_class_conv)
  .

lemma map_ord_eq_linorder[intro?]:
  "\<lbrakk>eq_linorder cmpk; eq_linorder cmpv\<rbrakk> \<Longrightarrow> eq_linorder (cmp_map cmpk cmpv)"
  unfolding cmp_map_def
  apply rule
  apply rule
  apply (rule restrict_eq_linorder)
  apply rule
  apply rule
  apply assumption
  apply assumption
  apply simp

  apply (rule linorder.sorted_list_of_map_inj)
  apply (subst (asm) eq_linorder_class_conv)
  .

definition cmp_unit :: "unit \<Rightarrow> unit \<Rightarrow> comp_res"
  where [simp]: "cmp_unit u v \<equiv> EQUAL"

lemma cmp_unit_eq_linorder:
  "eq_linorder cmp_unit"
  by unfold_locales simp_all

subsection \<open>Parametricity\<close>

lemma param_cmp_extend[param]:
  assumes "(cmp,cmp')\<in>R \<rightarrow> R \<rightarrow> Id"
  assumes "Range R \<subseteq> D"
  shows "(cmp,cmp_extend D cmp') \<in> R \<rightarrow> R \<rightarrow> Id"
  unfolding cmp_extend_def cmp_combine_def[abs_def]
  using assms
  apply clarsimp
  by (blast dest!: fun_relD)

lemma param_cmp_img[param]:
  "(cmp_img,cmp_img) \<in> (Ra\<rightarrow>Rb) \<rightarrow> (Rb\<rightarrow>Rb\<rightarrow>Rc) \<rightarrow> Ra \<rightarrow> Ra \<rightarrow> Rc"
  unfolding cmp_img_def[abs_def]
  by parametricity

lemma param_comp_res[param]:
  "(LESS,LESS)\<in>Id"
  "(EQUAL,EQUAL)\<in>Id"
  "(GREATER,GREATER)\<in>Id"
  "(case_comp_res,case_comp_res)\<in>Ra\<rightarrow>Ra\<rightarrow>Ra\<rightarrow>Id\<rightarrow>Ra"
  by (auto split: comp_res.split)

term cmp_lex
lemma param_cmp_lex[param]:
  "(cmp_lex,cmp_lex)\<in>(Ra\<rightarrow>Rb\<rightarrow>Id)\<rightarrow>\<langle>Ra\<rangle>list_rel\<rightarrow>\<langle>Rb\<rangle>list_rel\<rightarrow>Id"
  unfolding cmp_lex_alt[abs_def] cmp_lex'_def
  by (parametricity)

term cmp_prod
lemma param_cmp_prod[param]:
  "(cmp_prod,cmp_prod)\<in>
  (Ra\<rightarrow>Rb\<rightarrow>Id)\<rightarrow>(Rc\<rightarrow>Rd\<rightarrow>Id)\<rightarrow>\<langle>Ra,Rc\<rangle>prod_rel\<rightarrow>\<langle>Rb,Rd\<rangle>prod_rel\<rightarrow>Id"
  unfolding cmp_prod_alt
  by (parametricity)

lemma param_cmp_unit[param]:
  "(cmp_unit,cmp_unit)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  by auto

lemma param_comp2eq[param]: "(comp2eq,comp2eq)\<in>(R\<rightarrow>R\<rightarrow>Id)\<rightarrow>R\<rightarrow>R\<rightarrow>Id"
  unfolding comp2eq_def[abs_def]
  by (parametricity)

lemma cmp_combine_paramD:
  assumes "(cmp,cmp_combine D1 cmp1 D2 cmp2)\<in>R\<rightarrow>R\<rightarrow>Id"
  assumes "Range R \<subseteq> D1"
  shows "(cmp,cmp1)\<in>R\<rightarrow>R\<rightarrow>Id"
  using assms
  unfolding cmp_combine_def[abs_def]
  apply (intro fun_relI)
  apply (drule_tac x=a in fun_relD, assumption)
  apply (drule_tac x=aa in fun_relD, assumption)
  apply (drule RangeI, drule (1) rev_subsetD)
  apply (drule RangeI, drule (1) rev_subsetD)
  apply simp
  done

lemma cmp_extend_paramD:
  assumes "(cmp,cmp_extend D cmp')\<in>R\<rightarrow>R\<rightarrow>Id"
  assumes "Range R \<subseteq> D"
  shows "(cmp,cmp')\<in>R\<rightarrow>R\<rightarrow>Id"
  using assms
  unfolding cmp_extend_def
  apply (rule cmp_combine_paramD)
  done

subsection \<open>Tuning of Generated Implementation\<close>
lemma [autoref_post_simps]: "comp2eq (dflt_cmp (\<le>) ((<)::_::linorder\<Rightarrow>_)) = (=)"
  by (simp add: class_to_eq_linorder eq_linorder_comp2eq_eq)

end


theory Pratt_Certificate
imports
  Complex_Main
  Lehmer
begin

section {* Pratt's Primality Certificates *}
text_raw {* \label{sec:pratt} *}

text {*
  This work formalizes Pratt's proof system as described in his article
  ``Every Prime has a Succinct Certificate''\cite{pratt1975certificate}.
  The proof system makes use of two types of predicates:
  \begin{itemize}
    \item $\text{Prime}(p)$: $p$ is a prime number
    \item $(p, a, x)$: @{text "\<forall>q \<in> prime_factors(x). [a^((p - 1) div q) \<noteq> 1] (mod p)"}
  \end{itemize}
  We represent these predicates with the following datatype:
*}

datatype pratt = Prime nat | Triple nat nat nat

text {*
  Pratt describes an inference system consisting of the axiom $(p, a, 1)$
  and the following inference rules:
  \begin{itemize}
  \item R1: If we know that $(p, a, x)$ and @{text "[a^((p - 1) div q) \<noteq> 1] (mod p)"} hold for some
              prime number $q$ we can conclude $(p, a, qx)$ from that.
  \item R2: If we know that $(p, a, p - 1)$ and  @{text "[a^(p - 1) = 1] (mod p)"} hold, we can
              infer $\text{Prime}(p)$.
  \end{itemize}
  Both rules follow from Lehmer's theorem as we will show later on.

  A list of predicates (i.e., values of type @{type pratt}) is a \emph{certificate}, if it is
  built according to the inference system described above. I.e., a list @{term "x # xs :: pratt list"}
  is a certificate if @{term "xs :: pratt list"} is a certificate and @{term "x :: pratt"} is
  either an axiom or all preconditions of @{term "x :: pratt"} occur in @{term "xs :: pratt list"}.

  We call a certificate @{term "xs :: pratt list"} a \emph{certificate for @{term p}},
  if @{term "Prime p"} occurs in @{term "xs :: pratt list"}.

  The function @{text valid_cert} checks whether a list is a certificate.
*}

fun valid_cert :: "pratt list \<Rightarrow> bool" where
  "valid_cert [] = True"
| R2: "valid_cert (Prime p#xs) \<longleftrightarrow> 1 < p \<and> valid_cert xs
    \<and> (\<exists> a . [a^(p - 1) = 1] (mod p) \<and> Triple p a (p - 1) \<in> set xs)"
| R1: "valid_cert (Triple p a x # xs) \<longleftrightarrow> 0 < x  \<and> valid_cert xs \<and> (x=1 \<or>
    (\<exists>q y. x = q * y \<and> Prime q \<in> set xs \<and> Triple p a y \<in> set xs
      \<and> [a^((p - 1) div q) \<noteq> 1] (mod p)))"

text {*
  We define a function @{term size_cert} to measure the size of a certificate, assuming
  a binary encoding of numbers. We will use this to show that there is a certificate for a
  prime number $p$ such that the size of the certificate is polynomially bounded in the size
  of the binary representation of $p$.
*}
fun size_pratt :: "pratt \<Rightarrow> real" where
  "size_pratt (Prime p) = log 2 p" |
  "size_pratt (Triple p a x) = log 2 p + log 2 a + log 2 x"

fun size_cert :: "pratt list \<Rightarrow> real" where
  "size_cert [] = 0" |
  "size_cert (x # xs) = 1 + size_pratt x + size_cert xs"

section {* Soundness *}

text {*
  In Section \ref{sec:pratt} we introduced the predicates $\text{Prime}(p)$ and $(p, a, x)$.
  In this section we show that for a certificate every predicate occuring in this certificate
  holds. In particular, if $\text{Prime}(p)$ occurs in a certificate, $p$ is prime.
*}

lemma prime_factors_one[simp]: shows "prime_factors (Suc 0) = {}"
  by (auto simp add:prime_factors_altdef2_nat)

lemma prime_factors_prime: fixes p :: nat assumes "prime p" shows "prime_factors p = {p}"
proof
  have "0 < p" using assms by auto
  then show "{p} \<subseteq> prime_factors p" using assms by (auto simp add:prime_factors_altdef2_nat)
  { fix q assume "q \<in> prime_factors p"
    then have "q dvd p" "prime q" using `0<p` by (auto simp add:prime_factors_altdef2_nat)
    with assms have "q=p" by (auto simp: prime_nat_def)
    }
  then
  show "prime_factors p \<subseteq> {p}" by auto
qed

theorem pratt_sound:
  assumes 1: "valid_cert c"
  assumes 2: "t \<in> set c"
  shows "(t = Prime p \<longrightarrow> prime p) \<and>
         (t = Triple p a x \<longrightarrow> ((\<forall> q \<in> prime_factors x . [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0<x))"
using assms
proof (induction c arbitrary: p a x t)
  case Nil then show ?case by force
  next
  case (Cons y ys)
  { assume "y=Triple p a x" "x=1"
    then have "(\<forall> q \<in> prime_factors x . [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0<x" by simp
    }
  moreover
  { assume x_y: "y=Triple p a x" "x~=1"
    hence "x>0" using Cons.prems by auto
    obtain q z where "x=q*z" "Prime q \<in> set ys \<and> Triple p a z \<in> set ys"
               and cong:"[a^((p - 1) div q) \<noteq> 1] (mod p)" using Cons.prems x_y by auto
    then have factors_IH:"(\<forall> r \<in> prime_factors z . [a^((p - 1) div r) \<noteq> 1] (mod p))" "prime q" "z>0"
      using Cons.IH Cons.prems `x>0` `y=Triple p a x` by auto
    then have "prime_factors x = prime_factors z \<union> {q}"  using `x =q*z` `x>0`
      by (simp add:prime_factors_product_nat prime_factors_prime)
    then have "(\<forall> q \<in> prime_factors x . [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0 < x"
      using factors_IH cong by (simp add: `x>0`)
    }
  ultimately have y_Triple:"y=Triple p a x \<Longrightarrow> (\<forall> q \<in> prime_factors x .
                                                [a^((p - 1) div q) \<noteq> 1] (mod p)) \<and> 0<x" by linarith
  { assume y: "y=Prime p" "p>2" then
    obtain a where a:"[a^(p - 1) = 1] (mod p)" "Triple p a (p - 1) \<in> set ys"
      using Cons.prems by auto
    then have Bier:"(\<forall>q\<in>prime_factors (p - 1). [a^((p - 1) div q) \<noteq> 1] (mod p))"
      using Cons.IH Cons.prems(1) by (simp add:y(1))
    then have "prime p" using lehmers_theorem[OF _ _a(1)] `p>2` by fastforce
    }
  moreover
  { assume "y=Prime p" "p=2" hence "prime p" by simp }
  moreover
  { assume "y=Prime p" then have "p>1"  using Cons.prems  by simp }
  ultimately have y_Prime:"y = Prime p \<Longrightarrow> prime p" by linarith

  show ?case
  proof (cases "t \<in> set ys")
    case True
      show ?thesis using Cons.IH[OF _ True] Cons.prems(1) by (cases y) auto
    next
    case False
      thus ?thesis using Cons.prems(2) y_Prime y_Triple by force
  qed
qed

section {* Completeness *}

text {*
  In this section we show completeness of Pratt's proof system, i.e., we show that for
  every prime number $p$ there exists a certificate for $p$. We also give an upper
  bound for the size of a minimal certificate

  The prove we give is constructive. We assume that we have certificates for all prime
  factors of $p - 1$ and use these to build a certificate for $p$ from that. It is
  important to note that certificates can be concatenated.
*}

lemma valid_cert_appendI:
  assumes "valid_cert r"
  assumes "valid_cert s"
  shows "valid_cert (r @ s)"
  using assms
proof (induction r)
  case (Cons y ys) then show ?case by (cases y) auto
qed simp

lemma valid_cert_concatI: "(\<forall>x \<in> set xs . valid_cert x) \<Longrightarrow> valid_cert (concat xs)"
  by (induction xs) (auto simp add: valid_cert_appendI)

lemma size_pratt_le:
 fixes d::real
 assumes "\<forall> x \<in> set c. size_pratt x \<le> d"
 shows "size_cert c \<le> length c * (1 + d)" using assms
 by (induction c) (simp_all add: real_of_nat_def algebra_simps)

fun build_fpc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> pratt list" where
  "build_fpc p a r [] = [Triple p a r]" |
  "build_fpc p a r (y # ys) = Triple p a r # build_fpc p a (r div y) ys"

text {*
  The function @{term build_fpc} helps us to construct a certificate for $p$ from
  the certificates for the prime factors of $p - 1$. Called as
  @{term "build_fpc p a (p - 1) qs"} where $@{term "qs"} = q_1 \ldots q_n$
  is prime decomposition of $p - 1$ such that $q_1 \cdot \dotsb \cdot q_n = @{term "p - 1 :: nat"}$,
  it returns the following list of predicates:
  \[
  (p,a,p-1), (p,a,\frac{p - 1}{q_1}), (p,a,\frac{p - 1}{q_1 q_2}), \ldots, (p,a,\frac{p-1}{q_1 \ldots q_n}) = (p,a,1)
  \]

  I.e., if there is an appropriate $a$ and and a certificate @{term rs} for all
  prime factors of $p$, then we can construct a certificate for $p$ as
  @{term [display] "Prime p # build_fpc p a (p - 1) qs @ rs"}
*}

definition "listprod \<equiv> \<lambda>xs. foldr (op *) xs 1"

lemma listprod_Nil[simp]: "listprod [] = 1" by (simp add: listprod_def)
lemma listprod_Cons[simp]: "listprod (x # xs) = x * listprod xs" by (simp add: listprod_def)

text {*
  The following lemma shows that @{text "build_fpc"} extends a certificate that
  satisfies the preconditions described before to a correct certificate.
*}

lemma correct_fpc:
  assumes "valid_cert xs"
  assumes "listprod qs = r" "r \<noteq> 0"
  assumes "\<forall> q \<in> set qs . Prime q \<in> set xs"
  assumes "\<forall> q \<in> set qs . [a^((p - 1) div q) \<noteq> 1] (mod p)"
  shows "valid_cert (build_fpc p a r qs @ xs)"
  using assms
proof (induction qs arbitrary: r)
  case Nil thus ?case by auto
next
  case (Cons y ys)
  have "listprod ys = r div y" using Cons.prems by auto
  then have T_in: "Triple p a (listprod ys) \<in> set (build_fpc p a (r div y) ys @ xs)"
    by (cases ys) auto

  have "valid_cert (build_fpc p a (r div y) ys @ xs)"
    using Cons.prems by (intro Cons.IH) auto
  then have "valid_cert (Triple p a r # build_fpc p a (r div y) ys @ xs)"
    using `r \<noteq> 0` T_in Cons.prems by auto
  then show ?case by simp
qed

lemma length_fpc:
  "length (build_fpc p a r qs) = length qs + 1" by (induction qs arbitrary: r) auto

lemma div_gt_0:
  fixes m n :: nat assumes "m \<le> n" "0 < m" shows "0 < n div m"
proof -
  have "0 < m div m" using `0 < m` div_self by auto
  also have "m div m \<le> n div m" using `m \<le> n` by (rule div_le_mono)
  finally show ?thesis .
qed

lemma size_pratt_fpc:
  assumes "a \<le> p" "r \<le> p" "0 < a" "0 < r" "0 < p" "listprod qs = r"
  shows "\<forall>x \<in> set (build_fpc p a r qs) . size_pratt x \<le> 3 * log 2 p" using assms
proof (induction qs arbitrary: r)
  case Nil
  then have "log 2 a \<le> log 2 p" "log 2 r \<le> log 2 p" by auto
  then show ?case by simp
next
  case (Cons q qs)
  then have "log 2 a \<le> log 2 p" "log 2 r \<le> log 2 p" by auto
  then have  "log 2 a + log 2 r \<le> 2 * log 2 p" by arith
  moreover have "r div q > 0" using Cons.prems by (fastforce intro: div_gt_0)
  moreover hence "listprod qs = r div q" using Cons.prems(6) by auto
  moreover have "r div q \<le> p" using `r\<le>p` div_le_dividend[of r q] by linarith
  ultimately show ?case using Cons by simp
qed

lemma concat_set:
  assumes "\<forall> q \<in> qs . \<exists> c \<in> set cs . Prime q \<in> set c"
  shows "\<forall> q \<in> qs . Prime q \<in> set (concat cs)"
  using assms by (induction cs) auto

lemma p_in_prime_factorsE:
  fixes n :: nat
  assumes "p \<in> prime_factors n" "0 < n"
  obtains "2 \<le> p" "p \<le> n" "p dvd n" "prime p"
proof
  from assms show "prime p" by auto
  then show "2 \<le> p" by (auto dest: prime_gt_1_nat)

  from assms show "p dvd n" by (intro prime_factors_dvd_nat)
  then show "p \<le> n" using  `0 < n` by (rule dvd_imp_le)
qed

lemma prime_factors_list_prime:
  fixes n :: nat
  assumes "prime n"
  shows "\<exists> qs. prime_factors n = set qs \<and> listprod qs = n \<and> length qs = 1"
proof -
    have "prime_factors n = set [n]" using prime_factors_prime assms by force
    thus ?thesis by fastforce
qed

lemma prime_factors_list:
  fixes n :: nat assumes "3 < n" "\<not> prime n"
  shows "\<exists> qs. prime_factors n = set qs \<and> listprod qs = n \<and> length qs \<ge> 2"
  using assms
proof (induction n rule: less_induct)
  case (less n)
    obtain p where "p \<in> prime_factors n" using `n > 3` prime_factors_elem by force
    then have p':"2 \<le> p" "p \<le> n" "p dvd n" "prime p"
      using `3 < n` by (auto elim: p_in_prime_factorsE)
    { assume "n div p > 3" "\<not> prime (n div p)"
      then obtain qs
        where "prime_factors (n div p) = set qs" "listprod qs = (n div p)" "length qs \<ge> 2"
        using p' by atomize_elim (auto intro: less simp: div_gt_0)
      moreover
      have "prime_factors (p * (n div p)) = insert p (prime_factors (n div p))"
        using `3 < n` `2 \<le> p` `p \<le> n` `prime p`
      by (auto simp: prime_factors_product_nat div_gt_0 prime_factors_prime)
      ultimately
      have "prime_factors n = set (p # qs)" "listprod (p # qs) = n" "length (p#qs) \<ge> 2"
        using `p dvd n` by (simp_all add: dvd_mult_div_cancel)
      hence ?case by blast
    }
    moreover
    { assume "prime (n div p)"
      then obtain qs
        where "prime_factors (n div p) = set qs" "listprod qs = (n div p)" "length qs = 1"
        using prime_factors_list_prime by blast
      moreover
      have "prime_factors (p * (n div p)) = insert p (prime_factors (n div p))"
        using `3 < n` `2 \<le> p` `p \<le> n` `prime p`
      by (auto simp: prime_factors_product_nat div_gt_0 prime_factors_prime)
      ultimately
      have "prime_factors n = set (p # qs)" "listprod (p # qs) = n" "length (p#qs) \<ge> 2"
        using `p dvd n` by (simp_all add: dvd_mult_div_cancel)
      hence ?case by blast
    } note case_prime = this
    moreover
    { assume "n div p = 1"
      hence "n = p" using `n>3`  using One_leq_div[OF `p dvd n`] p'(2) by force
      hence ?case using `prime p` `\<not> prime n` by auto
    }
    moreover
    { assume "n div p = 2"
      hence ?case using case_prime by force
    }
    moreover
    { assume "n div p = 3"
      hence ?case using p' case_prime by force
    }
    ultimately show ?case using p' div_gt_0[of p n] case_prime by fastforce

qed

lemma listprod_ge:
  fixes xs::"nat list"
  assumes "\<forall> x \<in> set xs . x \<ge> 1"
  shows "listprod xs \<ge> 1" using assms by (induction xs) auto

lemma listsum_log:
  fixes b::real
  fixes xs::"nat list"
  assumes b: "b > 0" "b \<noteq> 1"
  assumes xs:"\<forall> x \<in> set xs . x \<ge> b"
  shows "(\<Sum>x\<leftarrow>xs. log b x) = log b (listprod xs)"
  using assms
proof (induction xs)
  case Nil
    thus ?case by simp
  next
  case (Cons y ys)
    have "real (listprod ys) > 0" using listprod_ge Cons.prems by fastforce
    thus ?case using Log.log_mult[OF Cons.prems(1-2)] Cons by force
qed

lemma concat_length_le:
  fixes g :: "nat \<Rightarrow> real"
  assumes "\<forall> x \<in> set xs . real (length (f x)) \<le> g x"
  shows "length (concat (map f xs)) \<le> (\<Sum>x\<leftarrow>xs. g x)" using assms
  by (induction xs) force+

(* XXX move *)
lemma powr_realpow_numeral: "0 < x \<Longrightarrow> x powr (numeral n :: real) = x^(numeral n)"
  unfolding real_of_nat_numeral[symmetric] by (rule powr_realpow)

lemma prime_gt_3_impl_p_minus_one_not_prime:
  fixes p::nat
  assumes "prime p" "p>3"
  shows "\<not> prime (p - 1)"
proof
  assume "prime (p - 1)"
  have "\<not> even p" using assms by (simp add: prime_odd_nat)
  hence "2 dvd (p - 1)" by presburger
  hence "2 \<in> prime_factors (p - 1)" using `p>3` by (auto simp: prime_factors_altdef2_nat)
  thus False using prime_factors_prime `p>3` `prime (p - 1)` by auto
qed

text {*
  We now prove that Pratt's proof system is complete and derive upper bounds for
  the length and the size of the entries of a minimal certificate.
*}

theorem pratt_complete':
  assumes "prime p"
  shows "\<exists>c. Prime p \<in> set c \<and> valid_cert c \<and> length c \<le> 6*log 2 p - 4 \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p)" using assms
proof (induction p rule: less_induct)
  case (less p)
  { assume [simp]: "p = 2"
    have "Prime p \<in> set [Prime 2, Triple 2 1 1]" by simp
    then have ?case by fastforce }
  moreover
  { assume [simp]: "p = 3"
    let ?cert = "[Prime 3, Triple 3 2 2, Triple 3 2 1, Prime 2, Triple 2 1 1]"

    have "length ?cert \<le> 6*log 2 p - 4
          \<longleftrightarrow> 2 powr 9 \<le> 2 powr (log 2 p * 6)" by auto
    also have "\<dots> \<longleftrightarrow> True"
      by (simp add: powr_powr[symmetric] powr_realpow_numeral)
    finally have ?case
      by (intro exI[where x="?cert"]) (simp add: cong_nat_def)
  }
  moreover
  { assume "p > 3"

    have "\<forall>q \<in> prime_factors (p - 1) . q < p" using `prime p`
      by (fastforce elim: p_in_prime_factorsE)
    hence factor_certs:"\<forall>q \<in> prime_factors (p - 1) . (\<exists>c . ((Prime q \<in> set c) \<and> (valid_cert c)
                                                      \<and> length c \<le> 6*log 2 q - 4) \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q))"
      by (auto intro: less.IH)
    obtain a where a:"[a^(p - 1) = 1] (mod p) \<and> (\<forall> q. q \<in> prime_factors (p - 1)
              \<longrightarrow> [a^((p - 1) div q) \<noteq> 1] (mod p))" and a_size: "a > 0" "a < p"
      using converse_lehmer[OF `prime p`] by blast

    have "\<not> prime (p - 1)" using `p>3` prime_gt_3_impl_p_minus_one_not_prime `prime p` by auto
    have "p \<noteq> 4" using `prime p` by auto
    hence "p - 1 > 3" using `p > 3` by auto

    then obtain qs where prod_qs_eq:"listprod qs = p - 1"
        and qs_eq:"set qs = prime_factors (p - 1)" and qs_length_eq: "length qs \<ge> 2"
      using prime_factors_list[OF _ `\<not> prime (p - 1)`] by auto
    obtain f where f:"\<forall>q \<in> prime_factors (p - 1) . \<exists> c. f q = c
                     \<and> ((Prime q \<in> set c) \<and> (valid_cert c) \<and> length c \<le> 6*log 2 q - 4)
                     \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q)"
      using factor_certs by metis
    let ?cs = "map f qs"
    have cs: "\<forall>q \<in> prime_factors (p - 1) . (\<exists>c \<in> set ?cs . (Prime q \<in> set c) \<and> (valid_cert c)
                                           \<and> length c \<le> 6*log 2 q - 4
                                           \<and> (\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q))"
      using f qs_eq by auto

    have cs_cert_size: "\<forall>c \<in> set ?cs . \<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p"
    proof
      fix c assume "c \<in> set (map f qs)"
      then obtain q where "c = f q" and "q \<in> set qs" by auto
      hence *:"\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 q" using f qs_eq by blast
      have "q < p" "q > 0" using `\<forall>q \<in> prime_factors (p - 1) . q < p` `q \<in> set qs` qs_eq by fast+
      show "\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p"
      proof
        fix x assume "x \<in> set c"
        hence "size_pratt x \<le> 3 * log 2 q" using * by fastforce
        also have "\<dots> \<le> 3 * log 2 p" using `q < p` `q > 0` `p > 3` by simp
        finally show "size_pratt x \<le> 3 * log 2 p" .
      qed
    qed

    have cs_valid_all: "\<forall>c \<in> set ?cs . valid_cert c"
      using f qs_eq by fastforce

    have "\<forall>x \<in> set (build_fpc p a (p - 1) qs). size_pratt x \<le> 3 * log 2 p"
      using cs_cert_size a_size `p > 3` prod_qs_eq by (intro size_pratt_fpc) auto
    hence "\<forall>x \<in> set (build_fpc p a (p - 1) qs @ concat ?cs) . size_pratt x \<le> 3 * log 2 p"
      using cs_cert_size by auto
    moreover
    have "Triple p a (p - 1) \<in> set (build_fpc p a (p - 1) qs @ concat ?cs)" by (cases qs) auto
    moreover
    have "valid_cert ((build_fpc p a (p - 1) qs)@ concat ?cs)"
    proof (rule correct_fpc)
      show "valid_cert (concat ?cs)"
        using cs_valid_all by (auto simp: valid_cert_concatI)
      show "listprod qs = p - 1" by (rule prod_qs_eq)
      show "p - 1 \<noteq> 0" using prime_gt_1_nat[OF `prime p`] by arith
      show "\<forall> q \<in> set qs . Prime q \<in> set (concat ?cs)"
        using concat_set[of "prime_factors (p - 1)"] cs qs_eq by blast
      show "\<forall> q \<in> set qs . [a^((p - 1) div q) \<noteq> 1] (mod p)" using qs_eq a by auto
    qed
    moreover
    { let ?k = "length qs"

      have qs_ge_2:"\<forall>q \<in> set qs . q \<ge> 2" using qs_eq
        by (simp add: prime_factors_prime_nat prime_ge_2_nat)

      have "\<forall>x\<in>set qs. real (length (f x)) \<le> 6 * log 2 (real x) - 4" using f qs_eq by blast
      hence "length (concat ?cs) \<le> (\<Sum>q\<leftarrow>qs. 6*log 2 q - 4)" using concat_length_le
        by fast
      hence "length (Prime p # ((build_fpc p a (p - 1) qs)@ concat ?cs))
            \<le> ((\<Sum>q\<leftarrow>(map real qs). 6*log 2 q - 4) + ?k + 2)"
            by (simp add: o_def length_fpc)
      also have "\<dots> = (6*(\<Sum>q\<leftarrow>(map real qs). log 2 q) + (-4 * real ?k) + ?k + 2)"
        by (simp add: o_def listsum_subtractf listsum_triv real_of_nat_def listsum_const_mult)
      also have "\<dots> \<le> 6*log 2 (p - 1) - 4" using `?k\<ge>2` prod_qs_eq listsum_log[of 2 qs] qs_ge_2
        by force
      also have "\<dots> \<le> 6*log 2 p - 4" using Log.log_le_cancel_iff[of 2 "p - 1" p] `p>3` by force
      ultimately have "length (Prime p # ((build_fpc p a (p - 1) qs)@ concat ?cs))
                       \<le> 6*log 2 p - 4" by linarith }
    ultimately obtain c where c:"Triple p a (p - 1) \<in> set c" "valid_cert c"
                               "length (Prime p #c) \<le> 6*log 2 p - 4"
                               "(\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p)" by blast
    hence "Prime p \<in> set (Prime p # c)" "valid_cert (Prime p # c)"
         "(\<forall> x \<in> set (Prime p # c). size_pratt x \<le> 3 * log 2 p)"
    using a `prime p` by auto
    hence ?case using c by blast
  }
  moreover have "p\<ge>2" using less by (simp add: prime_ge_2_nat)
  ultimately show ?case using less by fastforce
qed

text {*
  We now recapitulate our results. A number $p$ is prime if and only if there
  is a certificate for $p$. Moreover, for a prime $p$ there always is a certificate
  whose size is polynomially bounded in the logarithm of $p$.
*}

corollary pratt:
  "prime p \<longleftrightarrow> (\<exists>c. Prime p \<in> set c \<and> valid_cert c)"
  using pratt_complete' pratt_sound(1) by blast

corollary pratt_size:
  assumes "prime p"
  shows "\<exists>c. Prime p \<in> set c \<and> valid_cert c \<and> size_cert c \<le> (6 * log 2 p - 4) * (1 + 3 * log 2 p)"
proof -
  obtain c where c: "Prime p \<in> set c" "valid_cert c"
      and len: "length c \<le> 6*log 2 p - 4" and "(\<forall> x \<in> set c. size_pratt x \<le> 3 * log 2 p)"
    using pratt_complete' assms by blast
  hence "size_cert c \<le> length c * (1 + 3 * log 2 p)" by (simp add: size_pratt_le)
  also have "\<dots> \<le> (6*log 2 p - 4) * (1 + 3 * log 2 p)" using len by simp
  finally show ?thesis using c by blast
qed

end


(* author: wzh *)

theory Chapter3 imports Main

begin

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int

type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V v) s = s v" |
"aval (Plus a1 a2) s = (aval a1 s) + (aval a2 s)"

value "aval (Plus (N 0) (V x)) (\<lambda> x.0)"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V v) = V v" |
"asimp_const (Plus a1 a2) =
(
case (asimp_const a1, asimp_const a2) of
(N n1, N n2) \<Rightarrow> N (n1 + n2) |
(b1, b2) \<Rightarrow> Plus b1 b2
)"

lemma "aval (asimp_const a) s = aval a s"
  apply(induction a)
    apply(auto split: aexp.split)
  done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i1) (N i2) = N (i1 + i2)" |
"plus (N i) a = (if i = 0 then a else Plus (N i) a)" |
"plus a (N i) = (if i = 0 then a else Plus a (N i))" |
"plus a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply(induction rule: plus.induct)
  apply(auto)
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc b) s = b"
| "bval (Not b) s = (\<not> (bval b s))"
| "bval (And b1 b2) s = ((bval b1 s) \<and> (bval b2 s))"
| "bval (Less a1 a2) s = (aval a1 s < aval a2 s)"

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False"
| "not (Bc False) = Bc True"
| "not b = Not b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b"
| "and b (Bc True) = b"
| "and (Bc False) b = (Bc False)"
| "and b (Bc False) = (Bc False)"
| "and b1 b2 = And b1 b2"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n1) (N n2) = Bc (n1 < n2)"
| "less a1 a2 = Less a1 a2"

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc b) = Bc b"
| "bsimp (Not b) = Not (bsimp b)"
| "bsimp (And b1 b2) = And (bsimp b1) (bsimp b2)"
| "bsimp (Less a1 a2) = less (asimp a1) (asimp a2)"

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI v) s stk = (v # stk)"
| "exec1 (LOAD name) s stk = (s name # stk)"
| "exec1 ADD s (x#y#stk) = ((x+y)#stk) "

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 e1 e2) = comp e1 @ comp e2 @ [ADD]"

lemma "exec (comp a) s stk = aval a s # stk"
  apply(induction a arbitrary: stk)
    apply(auto)
  done

end


theory HSV_chapter5 imports Main begin

section \<open>Representing circuits (cf. worksheet Section 5.1)\<close>

text \<open>Defining a data structure to represent fan-out-free circuits with numbered inputs\<close>

datatype "circuit" =
  NOT "circuit"
| AND "circuit" "circuit"
| OR "circuit" "circuit"
| TRUE
| FALSE
| INPUT "int"

text \<open>A few example circuits\<close>

definition "circuit1 == AND (INPUT 1) (INPUT 2)"
definition "circuit2 == OR (NOT circuit1) FALSE"
definition "circuit3 == NOT (NOT circuit2)"
definition "circuit4 == AND circuit3 (INPUT 3)"

section \<open>Simulating circuits (cf. worksheet Section 5.2)\<close>

text \<open>Simulates a circuit given a valuation for each input wire\<close>

fun simulate where
  "simulate (AND c1 c2) \<rho> = ((simulate c1 \<rho>) \<and> (simulate c2 \<rho>))"
| "simulate (OR c1 c2) \<rho> = ((simulate c1 \<rho>) \<or> (simulate c2 \<rho>))"
| "simulate (NOT c) \<rho> = (\<not> (simulate c \<rho>))"
| "simulate TRUE \<rho> = True"
| "simulate FALSE \<rho> = False"
| "simulate (INPUT i) \<rho> = \<rho> i"

text \<open>A few example valuations\<close>

definition "\<rho>0 == \<lambda>_. True"
definition "\<rho>1 == \<rho>0(1 := True, 2 := False, 3 := True)"
definition "\<rho>2 == \<rho>0(1 := True, 2 := True, 3 := True)"

text \<open>Trying out the simulator\<close>

value "simulate circuit1 \<rho>1"
value "simulate circuit2 \<rho>1"
value "simulate circuit3 \<rho>1"
value "simulate circuit4 \<rho>1"
value "simulate circuit1 \<rho>2"
value "simulate circuit2 \<rho>2"
value "simulate circuit3 \<rho>2"
value "simulate circuit4 \<rho>2"

section \<open>Structural induction on circuits (cf. worksheet Section 5.3)\<close>

text \<open>A function that switches each pair of wires entering an OR or AND gate\<close>

fun mirror where
  "mirror (NOT c) = NOT (mirror c)"
| "mirror (AND c1 c2) = AND (mirror c2) (mirror c1)"
| "mirror (OR c1 c2) = OR (mirror c2) (mirror c1)"
| "mirror TRUE = TRUE"
| "mirror FALSE = FALSE"
| "mirror (INPUT i) = INPUT i"

value "circuit1"
value "mirror circuit1"
value "circuit2"
value "mirror circuit2"

text \<open>The following non-theorem is easily contradicted.\<close>

theorem "mirror c = c"
  oops

text \<open>Proving that mirroring doesn't affect simulation behaviour.\<close>

theorem mirror_is_sound: "simulate (mirror c) \<rho> = simulate c \<rho>"
  by (induct c, auto)

section \<open>A simple circuit optimiser (cf. worksheet Section 5.4)\<close>

text \<open>A function that optimises a circuit by removing pairs of consecutive NOT gates\<close>

fun opt_NOT where
  "opt_NOT (NOT (NOT c)) = opt_NOT c"
| "opt_NOT (NOT c) = NOT (opt_NOT c)"
| "opt_NOT (AND c1 c2) = AND (opt_NOT c1) (opt_NOT c2)"
| "opt_NOT (OR c1 c2) = OR (opt_NOT c1) (opt_NOT c2)"
| "opt_NOT TRUE = TRUE"
| "opt_NOT FALSE = FALSE"
| "opt_NOT (INPUT i) = INPUT i"

text \<open>Trying out the optimiser\<close>

value "circuit1"
value "opt_NOT circuit1"
value "circuit2"
value "opt_NOT circuit2"
value "circuit3"
value "opt_NOT circuit3"
value "circuit4"
value "opt_NOT circuit4"

section \<open>Rule induction (cf. worksheet Section 5.5)\<close>

text \<open>A Fibonacci function that demonstrates complex recursion schemes\<close>

fun f :: "nat \<Rightarrow> nat" where
  "f (Suc (Suc n)) = f n + f (Suc n)"
| "f (Suc 0) = 1"
| "f 0 = 1"

thm f.induct (* rule induction theorem for f *)

text \<open>We need to prove a stronger version of the theorem below
  first, in order to make the inductive step work. Just like how
  it often goes with loop invariants in Dafny!\<close>
lemma helper: "f n \<ge> n \<and> f n \<ge> 1"
  by (rule f.induct[of "\<lambda>n. f n \<ge> n \<and> f n \<ge> 1"], auto)

text \<open>The nth Fibonacci number is greater than or equal to n\<close>
theorem "f n \<ge> n"
  using helper by simp

section \<open>Verifying our optimiser (cf. worksheet Section 5.6)\<close>

text \<open>The following non-theorem is easily contradicted.\<close>

theorem "opt_NOT c = c"
  oops

text \<open>The following theorem says that the optimiser is sound.\<close>

theorem opt_NOT_is_sound: "simulate (opt_NOT c) \<rho> = simulate c \<rho>"
  by (induct rule:opt_NOT.induct, auto)

end


theory Directed_Multigraph
  imports
    Main
begin

type_synonym ('a, 'b) edge = "'a \<times> ('b \<times> 'b)"

type_synonym ('a, 'b) multigraph = "('a, 'b) edge set"

definition endpoints :: "('a, 'b) edge \<Rightarrow> 'b \<times> 'b" where
  "endpoints \<equiv> snd"

lemma mem_endpoints_iff:
  shows "vs \<in> endpoints ` G \<longleftrightarrow> (\<exists>\<epsilon>. (\<epsilon>, vs) \<in> G)"
  by (force simp add: endpoints_def)

definition head :: "('a, 'b) edge \<Rightarrow> 'b" where
  "head e \<equiv> snd (endpoints e)"

definition tail :: "('a, 'b) edge \<Rightarrow> 'b" where
  "tail e \<equiv> fst (endpoints e)"

lemma mem_ED:
  assumes "e \<in> G"
  shows "(tail e, head e) \<in> endpoints ` G"
  using assms
  by (simp add: head_def tail_def endpoints_def mem_endpoints_iff)

definition V :: "('a, 'b) multigraph \<Rightarrow> 'b set" where
  "V G \<equiv> head ` G \<union> tail ` G"

lemma head_mem_V:
  assumes "e \<in> G"
  shows "head e \<in> V G"
  using assms
  by (simp add: V_def)

lemma head_mem_V_2:
  assumes "(\<epsilon>, u, v) \<in> G"
  shows "v \<in> V G"
  using assms
  by (auto simp add: head_def endpoints_def dest: head_mem_V)

lemma head_mem_V_3:
  assumes "(u, v) \<in> endpoints ` G"
  shows "v \<in> V G"
  using assms
  by (auto simp add: mem_endpoints_iff dest: head_mem_V_2)

lemma tail_mem_V:
  assumes "e \<in> G"
  shows "tail e \<in> V G"
  using assms
  by (simp add: V_def)

lemma tail_mem_V_2:
  assumes "(\<epsilon>, u, v) \<in> G"
  shows "u \<in> V G"
  using assms
  by (auto simp add: tail_def endpoints_def dest: tail_mem_V)

lemma tail_mem_V_3:
  assumes "(u, v) \<in> endpoints ` G"
  shows "u \<in> V G"
  using assms
  by (auto simp add: mem_endpoints_iff dest: tail_mem_V_2)

lemma mem_VE:
  assumes "u \<in> V G"
  obtains v where
    "(u, v) \<in> endpoints ` G \<or> (v, u) \<in> endpoints ` G"
  using assms
  by (force simp add: V_def head_def tail_def endpoints_def)

locale multigraph =
  fixes G :: "('a, 'b) multigraph"

locale finite_multigraph = multigraph +
  assumes finite_edges: "finite G"

lemma (in finite_multigraph) finite_vertices:
  shows "finite (V G)"
  using finite_edges
  by (simp add: V_def)

(**)

definition to_edge :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> ('a, 'b) edge" where
  "to_edge v p \<equiv> (fst p, (v, snd p))"

definition incidence :: "('b \<Rightarrow> ('a \<times> 'b) list) \<Rightarrow> 'b \<Rightarrow> ('a, 'b) edge list" where
  "incidence I v \<equiv> map (to_edge v) (I v)"

(* TODO: Rename. *)
definition edges_from_fun :: "('b \<Rightarrow> ('a \<times> 'b) list) \<Rightarrow> ('a, 'b) multigraph" where
  "edges_from_fun I \<equiv> \<Union>v. set (incidence I v)"

lemma mem_edges_from_funE:
  assumes "e \<in> edges_from_fun I"
  obtains v where
    "e \<in> set (incidence I v)"
  using assms
  by (auto simp add: edges_from_fun_def)

lemma mem_edges_from_funI:
  assumes "e \<in> set (incidence I v)"
  shows "e \<in> edges_from_fun I"
  using assms
  by (auto simp add: edges_from_fun_def)

locale multigraph_2 =
  fixes I :: "'b \<Rightarrow> ('a \<times> 'b) list"
begin

lemma inj_to_edge:
  shows "inj (to_edge v)"
  by (auto simp add: to_edge_def intro: injI)

(* TODO: Move. *)
lemma inj_on_if_inj:
  assumes "inj f"
  shows "inj_on f A"
  using assms
  by (simp add: inj_on_def)

lemma tail_eq:
  assumes "e \<in> set (incidence I v)"
  shows "tail e = v"
  using assms
  by (auto simp add: incidence_def to_edge_def tail_def endpoints_def)

lemma mem_edges_from_funD:
  assumes "e \<in> edges_from_fun I"
  shows "e \<in> set (incidence I (tail e))"
  using assms
  by (auto simp add: tail_eq elim: mem_edges_from_funE)

sublocale multigraph "edges_from_fun I"
  .

end

locale finite_multigraph_2 = multigraph_2 +
  assumes finite_domain: "finite {v. I v \<noteq> []}"
begin

lemma edges_from_fun_eq:
  shows "edges_from_fun I = \<Union> ((set \<circ> incidence I) ` {v. I v \<noteq> []})"
  by (force simp add: edges_from_fun_def incidence_def)

sublocale finite_multigraph "edges_from_fun I"
proof (standard, goal_cases)
  case 1
  show ?case
    using finite_domain
    by (simp add: edges_from_fun_eq)
qed

end

end