theory Subdivision
imports
  Arc_Walk
  Digraph_Component
  Pair_Digraph
  Bidirected_Digraph
  Auxiliary
begin

section \<open>Subdivision on Digraphs\<close>

definition
  subdivision_step :: "('a, 'b) pre_digraph \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) pre_digraph \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> 'a \<times> 'a \<times> 'a \<Rightarrow> 'b \<times> 'b \<times> 'b \<Rightarrow> bool"
where
  "subdivision_step G rev_G H rev_H \<equiv> \<lambda>(u, v, w) (uv, uw, vw).
      bidirected_digraph G rev_G
    \<and> bidirected_digraph H rev_H
    \<and> perm_restrict rev_H (arcs G) = perm_restrict rev_G (arcs H)
    \<and> compatible G H

    \<and> verts H = verts G \<union> {w}
    \<and> w \<notin> verts G

    \<and> arcs H = {uw, rev_H uw, vw, rev_H vw} \<union> arcs G - {uv, rev_G uv}
    \<and> uv \<in> arcs G
    \<and> distinct [uw, rev_H uw, vw, rev_H vw]
    \<and> arc_to_ends G uv = (u,v)
    \<and> arc_to_ends H uw = (u,w)
    \<and> arc_to_ends H vw = (v,w)
  "

inductive subdivision :: "('a,'b) pre_digraph \<times> ('b \<Rightarrow> 'b) \<Rightarrow> ('a,'b) pre_digraph \<times> ('b \<Rightarrow> 'b) \<Rightarrow> bool"
  for biG where
    base: "bidirected_digraph (fst biG) (snd biG) \<Longrightarrow> subdivision biG biG"
  | divide: "\<lbrakk>subdivision biG biI; subdivision_step (fst biI) (snd biI) (fst biH) (snd biH) (u,v,w) (uv,uw,vw)\<rbrakk> \<Longrightarrow> subdivision biG biH"

lemma subdivision_induct[case_names base divide, induct pred: subdivision]:
  assumes "subdivision (G, rev_G) (H, rev_H)"
    and "bidirected_digraph G rev_G \<Longrightarrow> P G rev_G"
    and "\<And>I rev_I H rev_H u v w uv uw vw.
            subdivision (G, rev_G) (I, rev_I) \<Longrightarrow> P I rev_I \<Longrightarrow> subdivision_step I rev_I H rev_H (u, v, w) (uv, uw, vw) \<Longrightarrow> P H rev_H"
  shows "P H rev_H"
  using assms(1) by (induct biH\<equiv>"(H, rev_H)" arbitrary: H rev_H) (auto intro: assms(2,3))

lemma subdivision_base:
  "bidirected_digraph G rev_G \<Longrightarrow> subdivision (G, rev_G) (G, rev_G)"
  by (rule subdivision.base) simp

lemma subdivision_step_rev:
  assumes "subdivision_step G rev_G H rev_H (u, v, w) (uv, uw, vw)" "subdivision (H, rev_H) (I, rev_I)"
  shows "subdivision (G, rev_G) (I, rev_I)"
proof -
  have "bidirected_digraph (fst (G, rev_G)) (snd (G, rev_G))" using assms by (auto simp: subdivision_step_def)
  with assms(2,1) show ?thesis
    using assms(2,1) by induct (auto intro: subdivision.intros dest: subdivision_base)
qed

lemma subdivision_trans:
  assumes "subdivision (G, rev_G) (H, rev_H)" "subdivision (H, rev_H) (I, rev_I)"
  shows "subdivision (G, rev_G) (I, rev_I)"
  using assms by induction (auto intro: subdivision_step_rev)

locale subdiv_step =
  fixes G rev_G H rev_H u v w uv uw vw
  assumes subdiv_step: "subdivision_step G rev_G H rev_H (u, v, w) (uv, uw, vw)"

sublocale subdiv_step \<subseteq> G: bidirected_digraph G rev_G
  using subdiv_step unfolding subdivision_step_def by simp
sublocale subdiv_step \<subseteq> H: bidirected_digraph H rev_H
  using subdiv_step unfolding subdivision_step_def by simp

context subdiv_step begin

  (*XXX*)
  abbreviation (input) "vu \<equiv> rev_G uv"
  abbreviation (input) "wu \<equiv> rev_H uw"
  abbreviation (input) "wv \<equiv> rev_H vw"

  lemma subdiv_compat: "compatible G H"
    using subdiv_step by (simp add: subdivision_step_def)

  lemma arc_to_ends_eq: "arc_to_ends H = arc_to_ends G"
    using subdiv_compat by (simp add: compatible_def arc_to_ends_def fun_eq_iff)

  lemma head_eq: "head H = head G"
    using subdiv_compat by (simp add: compatible_def fun_eq_iff)

  lemma tail_eq: "tail H = tail G"
    using subdiv_compat by (simp add: compatible_def fun_eq_iff)

  lemma verts_H: "verts H = verts G \<union> {w}"
    using subdiv_step by (simp add: subdivision_step_def)

  lemma verts_G: "verts G = verts H - {w}"
    using subdiv_step by (auto simp: subdivision_step_def)

  lemma arcs_H: "arcs H = {uw, wu, vw, wv} \<union> arcs G - {uv, vu}"
    using subdiv_step by (simp add: subdivision_step_def)

  lemma not_in_verts_G: "w \<notin> verts G"
    using subdiv_step by (simp add: subdivision_step_def)

  lemma in_arcs_G: "{uv, vu} \<subseteq> arcs G"
    using subdiv_step by (simp add: subdivision_step_def)

  lemma not_in_arcs_H: "{uv,vu} \<inter> arcs H = {}"
    using arcs_H by auto

  lemma subdiv_ate:
      "arc_to_ends G uv = (u,v)"
      "arc_to_ends H uv = (u,v)"
      "arc_to_ends H uw = (u,w)"
      "arc_to_ends H vw = (v,w)"
    using subdiv_step subdiv_compat by (auto simp: subdivision_step_def arc_to_ends_def compatible_def)

  lemma subdiv_ends[simp]:
    "tail G uv = u" "head G uv = v" "tail H uv = u" "head H uv = v"
    "tail H uw = u" "head H uw = w" "tail H vw = v" "head H vw = w"
    using subdiv_ate by (auto simp: arc_to_ends_def)

  lemma subdiv_ends_G_rev[simp]:
    "tail G (vu) = v" "head G (vu) = u" "tail H (vu) = v" "head H (vu) = u"
    using in_arcs_G by (auto simp: tail_eq head_eq)

  lemma subdiv_distinct_verts0: "u \<noteq> w" "v \<noteq> w"
      using in_arcs_G not_in_verts_G using subdiv_ate by (auto simp: arc_to_ends_def dest: G.wellformed)

  lemma in_arcs_H: "{uw, wu, vw, wv} \<subseteq> arcs H"
  proof -
    { assume "uv = uw"
      then have "arc_to_ends H uv = arc_to_ends H uw" by simp
      then have "v = w" by (simp add: arc_to_ends_def)
    } moreover
    { assume "uv = vw"
      then have "arc_to_ends H uv = arc_to_ends H vw" by simp
      then have "v = w" by (simp add: arc_to_ends_def)
    } moreover
    { assume "vu = uw"
      then have "arc_to_ends H (vu) = arc_to_ends H uw" by simp
      then have "u = w" by (simp add: arc_to_ends_def)
    } moreover
    { assume "vu = vw"
      then have "arc_to_ends H (vu) = arc_to_ends H vw" by simp
      then have "u = w" by (simp add: arc_to_ends_def)
    } ultimately
    have "{uw,vw} \<subseteq> arcs H" unfolding arcs_H using subdiv_distinct_verts0 by auto
    then show ?thesis by auto
  qed

  lemma subdiv_ends_H_rev[simp]:
    "tail H (wu) = w" "tail H (wv) = w"
    "head H (wu) = u" "head H (wv) = v"
    using in_arcs_H subdiv_ate by simp_all

  lemma in_verts_G: "{u,v} \<subseteq> verts G"
    using in_arcs_G by (auto dest: G.wellformed)

  lemma not_in_arcs_G: "{uw, wu, vw, wv} \<inter> arcs G = {}"
  proof -
    note X = G.wellformed[simplified tail_eq[symmetric] head_eq[symmetric]]
    show ?thesis using not_in_verts_G in_arcs_H by (auto dest: X )
  qed

  lemma subdiv_distinct_arcs: "distinct [uv, vu, uw, wu, vw, wv]"
  proof -
    have "distinct [uw, wu, vw, wv]"
      using subdiv_step by (simp add: subdivision_step_def)
    moreover
    have "distinct [uv, vu]" using in_arcs_G G.arev_dom by auto
    moreover
    have "{uv, vu} \<inter> {uw, wu, vw, wv} = {}"
      using arcs_H in_arcs_H by auto
    ultimately show ?thesis by auto
  qed

  lemma arcs_G: "arcs G = arcs H \<union> {uv, vu} - {uw, wu, vw, wv}"
    using in_arcs_G not_in_arcs_G unfolding arcs_H by auto

  lemma subdiv_ate_H_rev:
    "arc_to_ends H (wu) = (w,u)"
    "arc_to_ends H (wv) = (w,v)"
    using in_arcs_H subdiv_ate by simp_all

  lemma adj_with_w: "u \<rightarrow>\<^bsub>H\<^esub> w" "w \<rightarrow>\<^bsub>H\<^esub> u" "v \<rightarrow>\<^bsub>H\<^esub> w" "w \<rightarrow>\<^bsub>H\<^esub> v"
    using in_arcs_H subdiv_ate by (auto intro: H.dominatesI[rotated])

  lemma w_reach: "u \<rightarrow>\<^sup>*\<^bsub>H\<^esub> w" "w \<rightarrow>\<^sup>*\<^bsub>H\<^esub> u" "v \<rightarrow>\<^sup>*\<^bsub>H\<^esub> w" "w \<rightarrow>\<^sup>*\<^bsub>H\<^esub> v"
    using adj_with_w by auto

  lemma G_reach: "v \<rightarrow>\<^sup>*\<^bsub>G\<^esub> u" "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
    using subdiv_ate in_arcs_G by (simp add: G.dominatesI G.symmetric_reachable')+

  lemma out_arcs_w: "out_arcs H w = {wu, wv}"
    using subdiv_distinct_verts0 in_arcs_H
    by (auto simp: arcs_H) (auto simp: tail_eq verts_G dest: G.tail_in_verts)

  lemma out_degree_w: "out_degree H w = 2"
    using subdiv_distinct_arcs by (auto simp: out_degree_def out_arcs_w card_insert_if)

end

lemma subdivision_compatible:
  assumes "subdivision (G, rev_G) (H, rev_H)" shows "compatible G H"
  using assms by induct (auto simp: compatible_def subdivision_step_def)

lemma subdivision_bidir:
  assumes "subdivision (G, rev_G) (H, rev_H)"
  shows "bidirected_digraph H rev_H"
  using assms by induct (auto simp: subdivision_step_def)

lemma subdivision_choose_rev:
  assumes "subdivision (G, rev_G) (H, rev_H)" "bidirected_digraph H rev_H'"
  shows "\<exists>rev_G'. subdivision (G, rev_G') (H, rev_H')"
  using assms
proof (induction arbitrary: rev_H')
  case base
  then show ?case by (auto dest: subdivision_base)
next
  case (divide I rev_I H rev_H u v w uv uw vw)

  interpret subdiv_step I rev_I H rev_H u v w uv uw vw using divide by unfold_locales
  interpret H': bidirected_digraph H rev_H' by fact

  define rev_I' where "rev_I' x =
    (if x = uv then rev_I uv else if x = rev_I uv then uv else if x \<in> arcs I then rev_H' x else x)"
    for x

  have rev_H_injD: "\<And>x y z. rev_H' x = z \<Longrightarrow> rev_H' y = z \<Longrightarrow> x \<noteq> y \<Longrightarrow> False"
    by (metis H'.arev_eq_iff)

  have rev_H'_simps: "rev_H' uw = rev_H uw \<and> rev_H' vw = rev_H vw
    \<or> rev_H' uw = rev_H vw \<and> rev_H' vw = rev_H uw"
  proof -
    have "arc_to_ends H (rev_H' uw) = (w,u)" "arc_to_ends H (rev_H' vw) = (w,v)"
      using in_arcs_H by (auto simp: subdiv_ate)
    moreover
    have "\<And>x. x \<in> arcs H \<Longrightarrow> tail H x = w \<Longrightarrow> x \<in> {rev_H uw, rev_H vw}"
      using subdiv_distinct_verts0 not_in_verts_G by (auto simp: arcs_H) (simp add: tail_eq)
    ultimately
    have "rev_H' uw \<in> {rev_H uw, rev_H vw}" "rev_H' vw \<in> {rev_H uw, rev_H vw}"
      using in_arcs_H by auto
    then show ?thesis using in_arcs_H by (auto dest: rev_H_injD)
  qed

  have rev_H_uv: "rev_H' uv = uv" "rev_H' (rev_I uv) = rev_I uv"
    using not_in_arcs_H by (auto simp: H'.arev_eq)

  have bd_I': "bidirected_digraph I rev_I'"
  proof
    fix a
    have "\<And>a. a \<noteq> uv \<Longrightarrow> a \<noteq> rev_I uv \<Longrightarrow> a \<in> arcs I \<Longrightarrow> a \<in> arcs H"
      by (auto simp: arcs_H)
    then show "(a \<in> arcs I) = (rev_I' a \<noteq> a)"
      using in_arcs_G by (auto simp: rev_I'_def dest: G.arev_neq H'.arev_neq)
  next
    fix a
    have *: "\<And>a. rev_H' a = rev_I uv \<longleftrightarrow> a = rev_I uv"
      by (metis H'.arev_arev H'.arev_dom insert_disjoint(1) not_in_arcs_H)
    have **: "\<And>a. uv = rev_H' a \<longleftrightarrow> a = uv" using H'.arev_eq not_in_arcs_H by force
    have ***: "\<And>a. a \<in> arcs I \<Longrightarrow> rev_H' a \<in> arcs I"
      using rev_H'_simps  by (case_tac "a \<in> {uv,vu}") (fastforce simp: rev_H_uv, auto simp: arcs_G dest: rev_H_injD)
    show "rev_I' (rev_I' a) = a"
      by (auto simp: rev_I'_def H'.arev_eq rev_H_uv * ** ***)
  next
    fix a assume "a \<in> arcs I"
    then show "tail I (rev_I' a) = head I a"
      using in_arcs_G by (auto simp: rev_I'_def tail_eq[symmetric] head_eq[symmetric] arcs_H)
  qed
  moreover
  have "\<And>x. rev_H' x = uv \<longleftrightarrow> x = uv" "\<And>x. rev_H' x = rev_I uv \<longleftrightarrow> x = rev_I uv"
    using not_in_arcs_H by (auto dest: H'.arev_eq) (metis H'.arev_arev H'.arev_eq)
  then have "perm_restrict rev_H' (arcs I) = perm_restrict rev_I' (arcs H)"
    using not_in_arcs_H by (auto simp: rev_I'_def perm_restrict_def H'.arev_eq)
  ultimately
  have sds_I'H': "subdivision_step I rev_I' H rev_H' (u, v, w) (uv, uw, vw)"
    using divide(2,4) rev_H'_simps unfolding subdivision_step_def
    by (fastforce simp:  rev_I'_def)
  then have "subdivision (I, rev_I') (H, rev_H')" "\<exists>rev_G'. subdivision (G, rev_G') (I, rev_I')"
    using bd_I' divide by (auto intro: subdivision.intros dest: subdivision_base)
  then show ?case by (blast intro: subdivision_trans)
qed

lemma subdivision_verts_subset:
  assumes "subdivision (G,rev_G) (H,rev_H)" "x \<in> verts G"
  shows "x \<in> verts H"
  using assms by induct (auto simp: subdiv_step.verts_H subdiv_step_def)

subsection \<open>Subdivision on Pair Digraphs\<close>

text \<open>
  In this section, we introduce specialized rules for pair digraphs.
\<close>

abbreviation "subdivision_pair G H \<equiv> subdivision (with_proj G, swap_in (parcs G)) (with_proj H, swap_in (parcs H))"

lemma arc_to_ends_with_proj[simp]: "arc_to_ends (with_proj G) = id"
  by (auto simp: arc_to_ends_def)

context
begin

  text \<open>
    We use the @{verbatim inductive} command to define an inductive definition pair graphs.
    This is proven to be equivalent to @{const subdivision}.
    This allows us to transfer the rules proven by @{verbatim inductive} to @{const subdivision}.
    To spare the user confusion, we hide this new constant.
  \<close>

  private inductive pair_sd :: "'a pair_pre_digraph \<Rightarrow> 'a pair_pre_digraph \<Rightarrow> bool"
    for G where
      base: "pair_bidirected_digraph G \<Longrightarrow> pair_sd G G"
    | divide: "\<And>e w H. \<lbrakk>e \<in> parcs H; w \<notin> pverts H; pair_sd G H\<rbrakk>
        \<Longrightarrow> pair_sd G (subdivide H e w)"

  private lemma bidirected_digraphI_pair_sd:
    assumes "pair_sd G H" shows "pair_bidirected_digraph H"
    using assms
  proof induct
    case base
    then show ?case by auto
  next
    case (divide e w H)
    interpret H: pair_bidirected_digraph H by fact
    from divide show ?case by (intro H.pair_bidirected_digraph_subdivide)
  qed

  private lemma subdivision_with_projI:
    assumes "pair_sd G H"
    shows "subdivision_pair G H"
    using assms
  proof induct
    case base
    then show ?case by (blast intro: pair_bidirected_digraph.bidirected_digraph subdivision_base)
  next
    case (divide e w H)

    obtain u v where "e = (u,v)" by (cases e)

    interpret H: pair_bidirected_digraph H
      using divide(3) by (rule bidirected_digraphI_pair_sd)
    interpret I: pair_bidirected_digraph "subdivide H e w"
      using divide(1,2) by (rule H.pair_bidirected_digraph_subdivide)

    have uvw: "u \<noteq> v" "u \<noteq> w" "v \<noteq> w"
      using divide by (auto simp: \<open>e = _\<close> dest: H.adj_not_same H.wellformed)

    have "subdivision (with_proj G, swap_in (parcs G)) (H, swap_in (parcs H))"
      using divide by auto
    moreover
    have *: "perm_restrict (swap_in (parcs (subdivide H e w))) (parcs H) = perm_restrict (swap_in (parcs H)) (parcs (subdivide H e w))"
      by (auto simp: perm_restrict_def fun_eq_iff swap_in_def)
    have "subdivision_step (with_proj H) (swap_in (arcs H)) (with_proj (subdivide H e w)) (swap_in (arcs (subdivide H e w)))
        (u, v, w) (e, (u,w), (v,w))"
      unfolding subdivision_step_def
      unfolding prod.simps with_proj_simps
      using divide uvw
      by (intro conjI H.bidirected_digraph I.bidirected_digraph *)
         (auto simp add: swap_in_def \<open>e = _\<close> compatibleI_with_proj)
    ultimately
    show ?case by (auto intro: subdivision.divide)
  qed

  private lemma subdivision_with_projD:
    assumes "subdivision_pair G H"
    shows "pair_sd G H"
    using assms
  proof (induct "with_proj H" "swap_in (parcs H)" arbitrary: H rule: subdivision_induct)
    case base
    interpret bidirected_digraph "with_proj G" "swap_in (parcs G)" by fact
    from base have "G = H" by (simp add: with_proj_def)
    with base show ?case
      by (auto intro: pair_sd.base pair_bidirected_digraphI_bidirected_digraph)
  next
    case (divide I rev_I u v w uv uw vw)
    define I' where "I' = \<lparr> pverts = verts I, parcs = arcs I \<rparr>"
    have "compatible G I " using \<open>subdivision (with_proj G, _) (I, _)\<close>
      by (rule subdivision_compatible)
    then have "tail I = fst" "head I = snd" by (auto simp: compatible_def)
    then have I: "I = I'" by (auto simp: I'_def)
    moreover
    from I have "rev_I = swap_in (parcs I')"
      using \<open>subdivision_step _ _ _ _ _ _\<close>
      by (simp add: subdivision_step_def bidirected_digraph_rev_conv_pair)
    ultimately
    have pd_sd: "pair_sd G I'" by (auto intro: divide.hyps)

    interpret sd: subdiv_step I' "swap_in (parcs I')" H "swap_in (parcs H)" u v w uv uw vw
      using \<open>subdivision_step _ _ _ _ _ _\<close> unfolding \<open>I = _\<close> \<open>rev_I = _\<close> by unfold_locales

    have ends: "uv = (u,v)" "uw = (u,w)" "vw = (v,w)"
      using sd.subdiv_ate by simp_all
    then have si_ends: "swap_in (parcs H) (u,w) = (w,u)" "swap_in (parcs H) (v,w) = (w,v)"
        "swap_in (parcs I') (u,v) = (v,u)"
      using sd.subdiv_ends_H_rev sd.subdiv_ends_G_rev by (auto simp: swap_in_def)

    have "parcs H = parcs I' - {(u, v), (v, u)} \<union> {(u, w), (w, u), (w, v), (v, w)}"
      using sd.in_arcs_G sd.not_in_arcs_G sd.arcs_H by (auto simp: si_ends ends)
    then have "H = subdivide I' uv w" using sd.verts_H by (simp add: ends subdivide.simps)
    then show ?case
      using sd.in_arcs_G sd.not_in_verts_G by (auto intro: pd_sd pair_sd.divide)
  qed

  private lemma subdivision_pair_conv:
    "pair_sd G H = subdivision_pair G H "
    by (metis subdivision_with_projD subdivision_with_projI)

  lemmas subdivision_pair_induct = pair_sd.induct[
      unfolded subdivision_pair_conv, case_names base divide, induct pred: pair_sd]

  lemmas subdivision_pair_base = pair_sd.base[unfolded subdivision_pair_conv]
  lemmas subdivision_pair_divide = pair_sd.divide[unfolded subdivision_pair_conv]

  lemmas subdivision_pair_intros = pair_sd.intros[unfolded subdivision_pair_conv]
  lemmas subdivision_pair_cases = pair_sd.cases[unfolded subdivision_pair_conv]

  lemmas subdivision_pair_simps = pair_sd.simps[unfolded subdivision_pair_conv]

  lemmas bidirected_digraphI_subdivision = bidirected_digraphI_pair_sd[unfolded subdivision_pair_conv]

end

lemma (in pair_graph) pair_graph_subdivision:
  assumes "subdivision_pair G H"
  shows "pair_graph H"
  using assms
by (induct rule: subdivision_pair_induct) (blast intro: pair_graph.pair_graph_subdivide divide)+

end


theory Pord_Facts
  imports Pord Mergeable_Instances
begin

(* Pord_Facts
 * some useful lemmas
 *)

lemma is_sup_fst :
  assumes Hnemp : "x \<in> Xs"
  assumes H : "is_sup Xs supr"
  shows "is_sup ((\<lambda> w . (w, x')) ` Xs) (supr, x')"
proof(rule is_supI)
  fix x

  assume X: "x \<in> (\<lambda>w. (w, x')) ` Xs"

  then obtain x1 where X1 :
    "x = (x1, x')" "x1 \<in> Xs"
    by auto

  have "x1 <[ supr"
    using is_supD1[OF H X1(2)] by auto

  then show "x <[ (supr, x')"
    using X1
    by(auto simp add: prod_pleq leq_refl)
next

  fix y

  assume Y: "is_ub ((\<lambda>w. (w, x')) ` Xs) y"

  obtain y1 y2 where Y1_2 : "y = (y1, y2)"
    by(cases y; auto)

  have "is_ub Xs y1"
  proof(rule is_ubI)
    fix z

    assume Z: "z \<in> Xs"

    then have "(z, x') <[ y"
      using is_ubE[OF Y] by auto

    then show "z <[ y1"
      using Y1_2
      by(auto simp add: prod_pleq)
  qed

  then have "supr <[ y1"
    using is_supD2[OF H]
    by auto

  have "(x, x') <[ y"
    using is_ubE[OF Y] Hnemp
    by auto

  then have "x' <[ y2"
    using Y1_2
    by(auto simp add: prod_pleq)

  show "(supr, x') <[ y"
    using `supr <[ y1` `x' <[ y2` Y1_2
    by(auto simp add: prod_pleq)
qed

lemma is_sup_fst' :
  assumes Hnemp : "xy \<in> Xys"
  assumes H : "is_sup Xys (s1, s2)"
  shows "is_sup (fst ` Xys) s1"
proof(rule is_supI)

  fix x

  assume X: "x \<in> fst ` Xys"
  then obtain y where Xy : "(x, y) \<in> Xys"
    by(auto)

  then have "(x, y) <[ (s1, s2)"
    using is_supD1[OF H Xy]
    by auto

  then show "x <[ s1"
    by(auto simp add: prod_pleq)
next

  fix x'

  assume X' : "is_ub (fst ` Xys) x'"

  have Ub' : "is_ub Xys (x', s2)"
  proof(rule is_ubI)

    fix w

    assume W : "w \<in> Xys"

    obtain w1 w2 where W1_2 :
      "w = (w1, w2)"
      by(cases w; auto)

    then have "w1 \<in> fst ` Xys" using imageI[OF W, of fst]
      by auto

    then have "w1 <[ x'"
      using is_ubE[OF X'] by auto

    have "w2 \<in> snd ` Xys" using imageI[OF W, of snd] W1_2
      by auto

    then have "w2 <[ s2"
      using is_supD1[OF H W] W1_2
      by(auto simp add: prod_pleq)

    then show "w <[ (x', s2)"
      using `w1 <[ x'` W1_2
      by(auto simp add: prod_pleq)
  qed

  show "s1 <[ x'"
    using is_supD2[OF H Ub']
    by(auto simp add: prod_pleq)
qed

lemma is_sup_snd :
  assumes Hnemp : "x \<in> Xs"
  assumes H : "is_sup Xs supr"
  shows "is_sup ((\<lambda> w . (x', w)) ` Xs) (x', supr)"
proof(rule is_supI)
  fix x

  assume X: "x \<in> (\<lambda>w. (x', w)) ` Xs"

  then obtain x2 where X2 :
    "x = (x', x2)" "x2 \<in> Xs"
    by auto

  have "x2 <[ supr"
    using is_supD1[OF H X2(2)] by auto

  then show "x <[ (x', supr)"
    using X2
    by(auto simp add: prod_pleq leq_refl)
next

  fix y

  assume Y: "is_ub ((\<lambda>w. (x', w)) ` Xs) y"

  obtain y1 y2 where Y1_2 : "y = (y1, y2)"
    by(cases y; auto)

  have "is_ub Xs y2"
  proof(rule is_ubI)
    fix z

    assume Z: "z \<in> Xs"

    then have "(x', z) <[ y"
      using is_ubE[OF Y] by auto

    then show "z <[ y2"
      using Y1_2
      by(auto simp add: prod_pleq)
  qed

  then have "supr <[ y2"
    using is_supD2[OF H]
    by auto

  have "(x', x) <[ y"
    using is_ubE[OF Y] Hnemp
    by auto

  then have "x' <[ y1"
    using Y1_2
    by(auto simp add: prod_pleq)

  show "(x', supr) <[ y"
    using `supr <[ y2` `x' <[ y1` Y1_2
    by(auto simp add: prod_pleq)
qed

lemma is_sup_snd' :
  assumes Hnemp : "xy \<in> Xys"
  assumes H : "is_sup Xys (s1, s2)"
  shows "is_sup (snd ` Xys) s2"
proof(rule is_supI)

  fix y

  assume Y: "y \<in> snd ` Xys"
  then obtain x where Xy : "(x, y) \<in> Xys"
    by(auto)

  then have "(x, y) <[ (s1, s2)"
    using is_supD1[OF H Xy]
    by auto

  then show "y <[ s2"
    by(auto simp add: prod_pleq)
next

  fix y'

  assume Y' : "is_ub (snd ` Xys) y'"

  have Ub' : "is_ub Xys (s1, y')"
  proof(rule is_ubI)

    fix w

    assume W : "w \<in> Xys"

    obtain w1 w2 where W1_2 :
      "w = (w1, w2)"
      by(cases w; auto)

    then have "w2 \<in> snd ` Xys" using imageI[OF W, of snd]
      by auto

    then have "w2 <[ y'"
      using is_ubE[OF Y'] by auto

    have "w1 \<in> fst ` Xys" using imageI[OF W, of fst] W1_2
      by auto

    then have "w1 <[ s1"
      using is_supD1[OF H W] W1_2
      by(auto simp add: prod_pleq)

    then show "w <[ (s1, y')"
      using `w2 <[ y'` W1_2
      by(auto simp add: prod_pleq)
  qed

  show "s2 <[ y'"
    using is_supD2[OF H Ub']
    by(auto simp add: prod_pleq)
qed

lemma pairwise_sup_ok3 :
  fixes a b c s :: "'a :: Pordpsok"
  assumes A : "a \<in> ok_S"
  assumes B: "b \<in>  ok_S"
  assumes C: "c \<in> ok_S"
  assumes Ab_sup : "has_sup {a, b}"
  assumes Bc_sup : "has_sup {b, c}"
  assumes Ac_sup : "has_sup {a, c}"
  assumes Abc_sup : "is_sup {a, b, c} s"
  shows "s \<in> ok_S"
proof-
  obtain sup_ab where Sup_ab : "is_sup {a, b} sup_ab"
    using Ab_sup
    by(auto simp add: has_sup_def)

  have Sup_ab_in : "sup_ab \<in> ok_S"
    using pairwise_sup_ok[OF A B Sup_ab] by auto

  have Un : "({a, b} \<union> {c}) = {a, b, c}"
    by auto

  have Abc_sup' : "is_sup {sup_ab, c} s"
    using sup_union2[OF Sup_ab sup_singleton[of c ], of s] Abc_sup
    unfolding Un
    by auto

  show "s \<in> ok_S" using pairwise_sup_ok[OF Sup_ab_in C Abc_sup'] by auto
qed

end


section \<open>Combinators for Pseudo-random Objects\<close>

text \<open>This section introduces a combinator library for pseudo-random objects. Each object can be
described as a sample space, a function from an initial segment of the natural numbers that selects
a value (or data structure.) Semantically they are multisets with the natural interpretation as a
probability space (each element is selected with a probability proportional to its occurence count
in the multiset). Operationally the selection procedure describes an algorithm to sample from the
space.

After general definitions and lemmas basic sample spaces, such as chosing a natural uniformly in
an initial segment, a product construction the main pseudo-random objects: hash families and
expander graphs are introduced. In both cases the range is itself an arbitrary sample space, such
that it is for example possible to construct a pseudo-random object that samples seeds for hash
families using an expander walk.

The definitions @{term "\<Psi>"} in Section~\ref{sec:inner_algorithm} and @{term "\<Theta>"} in
Section~\ref{sec:outer_algorithm} are good examples.

A nice introduction into such constructions has been published by Goldreich~\cite{goldreich2011}.\<close>

subsection \<open>Definitions and General Lemmas\<close>

theory Pseudorandom_Combinators
  imports
    Finite_Fields.Card_Irreducible_Polynomials
    Universal_Hash_Families.Carter_Wegman_Hash_Family
    Frequency_Moments.Product_PMF_Ext
    Distributed_Distinct_Elements_Preliminary
    Expander_Graphs.Expander_Graphs_Strongly_Explicit
begin

unbundle intro_cong_syntax
hide_const "Quantum.T"
hide_const "Discrete_Topology.discrete"
hide_const "Polynomial.order"
no_notation Digraph.dominates ("_ \<rightarrow>\<index> _" [100,100] 40)

record 'a sample_space =
  size :: "nat"
  sample_space_select :: "nat \<Rightarrow> 'a"

definition sample_pmf
  where "sample_pmf S = map_pmf (sample_space_select S) (pmf_of_set {..<size S})"

definition "sample_space S \<equiv> size S > 0"

definition "select S k = (sample_space_select S (if k < size S then k else 0))"

definition "sample_set S = select S ` {..<size S}"

lemma sample_space_imp_ne:
  assumes "sample_space S"
  shows "{..<size S} \<noteq> {}"
  using assms unfolding sample_space_def by auto

lemma sample_pmf_alt:
  assumes "sample_space S"
  shows "sample_pmf S = map_pmf (select S) (pmf_of_set {..<size S})"
  using sample_space_imp_ne[OF assms] unfolding sample_pmf_def select_def
  by (intro map_pmf_cong refl) simp

lemma sample_space_alt:
  assumes "sample_space S"
  shows "sample_set S = set_pmf (sample_pmf S)"
  using sample_space_imp_ne[OF assms]
  unfolding sample_set_def sample_pmf_alt[OF assms]
  by simp

lemma sample_set_alt:
  assumes "sample_space S"
  shows "sample_set S = sample_space_select S ` {..<size S}"
  unfolding sample_set_def select_def
  by (intro image_cong) auto

lemma select_range:
  assumes "sample_space S"
  shows "select S i \<in> sample_set S"
  using assms unfolding sample_space_def select_def sample_set_def by auto

declare [[coercion sample_pmf]]

lemma integrable_sample_pmf[simp]:
  fixes f :: "'a \<Rightarrow> 'c::{banach, second_countable_topology}"
  assumes "sample_space S"
  shows "integrable (measure_pmf (sample_pmf S)) f"
proof -
  have "finite (set_pmf (pmf_of_set {..<size S}))"
    using assms sample_space_def
    by (subst set_pmf_of_set) auto
  hence "finite (set_pmf (sample_pmf S))"
    unfolding sample_pmf_def by simp
  thus ?thesis
    by (intro integrable_measure_pmf_finite)
qed

subsection \<open>Basic sample spaces\<close>

text \<open>Sample space for uniformly selecting a natural number less than a given bound:\<close>

definition nat_sample_space :: "nat \<Rightarrow> nat sample_space" ("[_]\<^sub>S")
  where "nat_sample_space n = \<lparr> size = n, select = id \<rparr>"

lemma nat_sample_pmf:
  "sample_pmf ([x]\<^sub>S) = pmf_of_set {..<x}"
  unfolding nat_sample_space_def sample_pmf_def by simp

lemma nat_sample_space[simp]:
  assumes "n > 0"
  shows "sample_space [n]\<^sub>S"
  using assms
  unfolding sample_space_def nat_sample_space_def by simp

text \<open>Sample space for the product of two sample spaces:\<close>

definition prod_sample_space ::
  "'a sample_space \<Rightarrow> 'b sample_space \<Rightarrow> ('a \<times> 'b) sample_space" (infixr "\<times>\<^sub>S" 65)
  where
    "prod_sample_space s t =
      \<lparr> size = size s * size t,
        select = (\<lambda>i. (select s (i mod (size s)), select t (i div (size s)))) \<rparr>"

lemma split_pmf_mod_div':
  assumes "a > (0::nat)"
  assumes "b > 0"
  shows "map_pmf (\<lambda>x. (x mod a, x div a)) (pmf_of_set {..<a * b}) = pmf_of_set ({..<a} \<times> {..<b})"
proof -
  have "x + a * y < a * b" if "x < a" "y < b" for x y
  proof -
    have a:"y+1 \<le> b" using that by simp
    have "x + a * y < a + a * y"
      using that by simp
    also have "... = a * (y+1)"
      by simp
    also have "... \<le> a * b"
      by (intro mult_left_mono a) auto
    finally show ?thesis by simp
  qed

  hence "bij_betw (\<lambda>x. (x mod a, x div a)) {..<a * b} ({..<a} \<times> {..<b})"
    using assms less_mult_imp_div_less
    by (intro bij_betwI[where g="(\<lambda>x. fst x + a * snd x)"])
     (auto simp add:mult.commute)

  moreover have "a * b > 0" using assms by simp
  hence "{..<a * b} \<noteq> {}" by blast
  ultimately show "?thesis"
    by (intro map_pmf_of_set_bij_betw) auto
qed

lemma pmf_of_set_prod_eq:
  assumes "A \<noteq> {}" "finite A"
  assumes "B \<noteq> {}" "finite B"
  shows  "pmf_of_set (A \<times> B) = pair_pmf (pmf_of_set A) (pmf_of_set B)"
proof -
  have "indicat_real (A \<times> B) (i, j) = indicat_real A i * indicat_real B j" for i j
    by (case_tac[!] "i \<in> A", case_tac[!] "j \<in> B") auto
  hence "pmf (pmf_of_set (A \<times> B)) (i,j) = pmf (pair_pmf (pmf_of_set A) (pmf_of_set B)) (i,j)"
    for i j using assms by (simp add:pmf_pair)
  thus ?thesis
    by (intro pmf_eqI) auto
qed

lemma split_pmf_mod_div:
  assumes "a > (0::nat)"
  assumes "b > 0"
  shows "map_pmf (\<lambda>x. (x mod a, x div a)) (pmf_of_set {..<a * b}) =
    pair_pmf (pmf_of_set {..<a}) (pmf_of_set {..<b})"
  using assms by (auto intro!: pmf_of_set_prod_eq simp add:split_pmf_mod_div')

lemma split_pmf_mod:
  assumes "a > (0::nat)"
  assumes "b > 0"
  shows "map_pmf (\<lambda>x. x mod a) (pmf_of_set {..<a * b}) = pmf_of_set {..<a}"
proof -
  have "map_pmf (\<lambda>x. x mod a) (pmf_of_set {..<a * b}) =
   map_pmf (fst \<circ> (\<lambda>x. (x mod a, x div a))) (pmf_of_set {..<a * b})"
    by (simp add:comp_def)
  also have "... = map_pmf fst (pair_pmf (pmf_of_set {..<a}) (pmf_of_set {..<b}))"
    by (simp add:map_pmf_compose split_pmf_mod_div[OF assms])
  also have "... = pmf_of_set {..<a}"
    by (simp add:map_fst_pair_pmf)
  finally show ?thesis by simp
qed

lemma prod_sample_pmf:
  assumes "sample_space S"
  assumes "sample_space T"
  shows "sample_pmf (S \<times>\<^sub>S T) = pair_pmf (sample_pmf S) (sample_pmf T)" (is "?L = ?R")
proof -
  have size: "size S * size T > 0"
    using assms sample_space_def by (metis nat_0_less_mult_iff)
  hence a:"{..<size S * size T} \<noteq> {}" "finite {..<size S * size T}"
    using lessThan_empty_iff by auto
  have b:"x div size S mod size T = x div size S" if "x < size S * size T" for x
    by (simp add: algebra_simps less_mult_imp_div_less that)

  have "?L = map_pmf (\<lambda>i. (select S (i mod size S), select T (i div size S)))
    (pmf_of_set {..<size S * size T})"
    unfolding sample_pmf_def prod_sample_space_def by simp
  also have "... = map_pmf ((\<lambda>(x,y). (select S x, select T y)) \<circ> (\<lambda>i. (i mod size S, i div size S)))
    (pmf_of_set {..<size S * size T})"
    by (simp add:comp_def)
  also have "... = map_pmf (\<lambda>(x,y). (select S x, select T y))
    (map_pmf (\<lambda>i. (i mod size S, i div size S)) (pmf_of_set {..<size S * size T}))"
    by (subst map_pmf_compose)  simp
  also have "... = map_pmf (\<lambda>(x,y). (select S x, select T y))
    (pair_pmf (pmf_of_set {..<size S}) (pmf_of_set {..<size T}))"
    using size by (subst split_pmf_mod_div) auto
  also have "... = ?R"
    unfolding sample_pmf_alt[OF assms(1)] sample_pmf_alt[OF assms(2)] map_pair by simp
  finally show ?thesis
    by simp
qed

lemma prod_sample_space[simp]:
  assumes "sample_space S" "sample_space T"
  shows "sample_space (S \<times>\<^sub>S T)"
  using assms
  unfolding sample_space_def prod_sample_space_def by simp

lemma prod_sample_set:
  assumes "sample_space S"
  assumes "sample_space T"
  shows "sample_set (S \<times>\<^sub>S T) = sample_set S \<times> sample_set T" (is "?L = ?R")
  using assms by (simp add:sample_space_alt prod_sample_pmf)

subsection \<open>Hash Families\<close>

lemma indep_vars_map_pmf:
  assumes "prob_space.indep_vars (measure_pmf p) (\<lambda>_. discrete) (\<lambda>i \<omega>. X' i (f \<omega>)) I"
  shows "prob_space.indep_vars (measure_pmf (map_pmf f p)) (\<lambda>_. discrete) X' I"
proof -
  have "prob_space.indep_vars (measure_pmf p) (\<lambda>_. discrete) (\<lambda>i. X' i \<circ> f) I"
    using assms by (simp add:comp_def)
  hence "prob_space.indep_vars (distr (measure_pmf p) discrete f) (\<lambda>_. discrete) X' I"
    by (intro prob_space.indep_vars_distr prob_space_measure_pmf) auto
  thus ?thesis
    using map_pmf_rep_eq by metis
qed

lemma k_wise_indep_vars_map_pmf:
  assumes "prob_space.k_wise_indep_vars (measure_pmf p) k (\<lambda>_. discrete) (\<lambda>i \<omega>. X' i (f \<omega>)) I"
  shows "prob_space.k_wise_indep_vars (measure_pmf (map_pmf f p)) k (\<lambda>_. discrete) X' I"
  using assms indep_vars_map_pmf
  unfolding prob_space.k_wise_indep_vars_def[OF prob_space_measure_pmf]
  by blast

lemma (in prob_space) k_wise_indep_subset:
  assumes "J \<subseteq> I"
  assumes "k_wise_indep_vars k M' X' I"
  shows "k_wise_indep_vars k M' X' J"
  using assms unfolding k_wise_indep_vars_def by simp

lemma (in prob_space) k_wise_indep_vars_reindex:
  assumes "inj_on f I"
  assumes "k_wise_indep_vars k M' X' (f ` I)"
  shows "k_wise_indep_vars k (M' \<circ> f) (\<lambda>k \<omega>. X' (f k) \<omega>) I"
proof -
  have "indep_vars (M' \<circ> f) (\<lambda>k. X' (f k)) J" if "finite J" "card J \<le> k" "J \<subseteq> I" for J
  proof -
    have "f ` J \<subseteq> f ` I" using that by auto
    moreover have "card (f ` J) \<le> k"
      using card_image_le[OF that(1)] that(2) order.trans by auto
    moreover have "finite (f ` J)" using that by auto
    ultimately have "indep_vars M' X' (f ` J)"
      using assms(2) unfolding k_wise_indep_vars_def by simp
    thus ?thesis
      using that assms(1) inj_on_subset
      by (intro indep_vars_reindex)
  qed
  thus ?thesis
    unfolding k_wise_indep_vars_def by simp
qed

definition GF :: "nat \<Rightarrow> int set list set ring"
  where "GF n = (SOME F. finite_field F \<and> order F = n)"

definition is_prime_power :: "nat \<Rightarrow> bool"
  where "is_prime_power n \<longleftrightarrow> (\<exists>p k. Factorial_Ring.prime p \<and> k > 0 \<and> n = p^k)"

lemma
  assumes "is_prime_power n"
  shows GF: "finite_field (GF n)" "order (GF n) = n"
proof -
  obtain p k where p_k: "Factorial_Ring.prime p" "k > 0" "n = p^k"
    using assms unfolding is_prime_power_def by blast
  have a:"\<exists>(F :: int set list set ring). finite_field F \<and> order F = n"
    using existence[OF p_k(2,1)] p_k(3) by simp
  show  "finite_field (GF n)" "order (GF n) = n"
    unfolding GF_def
    using someI_ex[OF a]
    by auto
qed

lemma is_prime_power: "Factorial_Ring.prime p \<Longrightarrow> k > 0 \<Longrightarrow> is_prime_power (p^k)"
  unfolding is_prime_power_def by auto

definition split_prime_power :: "nat \<Rightarrow> (nat \<times> nat)"
  where "split_prime_power n = (THE (p, k). p^k = n \<and> Factorial_Ring.prime p \<and> k > 0)"

lemma split_prime_power:
  assumes "Factorial_Ring.prime p"
  assumes "k > 0"
  shows "split_prime_power (p^k) = (p,k)"
proof -
  have "q = p \<and> l = k" if "q^l = p^k" "Factorial_Ring.prime q" "l > 0" for q l
  proof -
    have "q dvd p^k" using that by (metis dvd_power)
    hence "q dvd p" using prime_dvd_power that by auto
    moreover have "p dvd q^l" using that assms(2) by (metis dvd_power)
    hence "p dvd q" using prime_dvd_power that assms by blast
    ultimately have a:"p = q" by auto
    hence "l = k" using that prime_power_inj by auto
    thus ?thesis using a by simp
  qed
  thus ?thesis
    unfolding split_prime_power_def using assms
    by (intro the_equality) auto
qed

definition \<H> :: "nat \<Rightarrow> nat \<Rightarrow> 'a sample_space \<Rightarrow> (nat \<Rightarrow> 'a) sample_space"
  where "\<H> k d R = (
    let (p,n) = split_prime_power (size R);
        m = (LEAST j. d \<le> p^j \<and> j \<ge> n);
        f = from_nat_into (carrier (GF (p^m)));
        f' = to_nat_on (carrier (GF (p^m)));
        g = from_nat_into (bounded_degree_polynomials (GF (p^m)) k) in
    \<lparr> size = p^(m*k), select = (\<lambda>i x. select R ((f' (ring.hash (GF (p^m)) (f x) (g i))) mod p^n))\<rparr>)"

locale hash_sample_space =
  fixes k d p n :: nat
  fixes R :: "'a sample_space"
  assumes p_prime: "Factorial_Ring.prime p"
  assumes size_R: "size R = p ^ n"
  assumes k_gt_0: "k > 0"
  assumes n_gt_0: "n > 0"
begin

abbreviation S where "S \<equiv> \<H> k d R"

lemma p_n_def: "(p,n) = split_prime_power (size R)"
  unfolding size_R
  by (intro split_prime_power[symmetric] n_gt_0 p_prime)

definition m where "m = (LEAST j. d \<le> p^j \<and> j \<ge> n)"
definition f where "f = from_nat_into (carrier (GF (p^m)))"
definition f' where "f' = to_nat_on (carrier (GF (p^m)))"

lemma n_lt_m: "n \<le> m" and d_lt_p_m: "d \<le> p^m"
proof -
  define j :: nat where "j = max n d"
  have "d \<le> 2^d" by simp
  also have "... \<le> 2^j"
    unfolding j_def
    by (intro iffD2[OF power_increasing_iff]) auto
  also have "... \<le> p^j"
    using p_prime prime_ge_2_nat
    by (intro power_mono) auto
  finally have "d \<le> p^j" by simp
  moreover have "n \<le> j" unfolding j_def by simp
  ultimately have "d \<le> p^m \<and> m \<ge> n"
    unfolding m_def
    by (intro LeastI[where P="\<lambda>x. d \<le> p^ x \<and> x \<ge> n" and k="j"]) auto
  thus "n \<le> m" "d \<le> p^m"
    by auto
qed

lemma
  is_field: "finite_field (GF (p^m))" (is "?A") and
  field_order: "order (GF(p^m)) = p^m"  (is "?B")
proof -
  have "is_prime_power (p^m)"
    using n_gt_0 n_lt_m
    by (intro is_prime_power p_prime) auto

  thus "?A" "?B"
    using GF by auto
qed

interpretation cw: carter_wegman_hash_family "GF (p^m)" "k"
  using finite_field_def is_field finite_field_axioms_def
  by (intro carter_wegman_hash_familyI k_gt_0) auto

lemma field_size: "cw.field_size = p^m"
  using field_order unfolding Coset.order_def by simp

lemma f_bij: "bij_betw f {..<p^m} (carrier (GF (p^m)))"
  unfolding f_def using field_size  bij_betw_from_nat_into_finite[where S="carrier (GF (p^m))"]
  by simp

definition g where "g = from_nat_into cw.space"

lemma p_n_gt_0: "p^n > 0"
  by (metis p_prime gr0I not_prime_0 power_not_zero)

lemma p_m_gt_0: "p^m > 0"
  by (metis p_prime gr0I not_prime_0 power_not_zero)

lemma S_eq: "S = \<lparr> size = p^(m*k), sample_space_select = (\<lambda> i x. select R (f' (cw.hash (f x) (g i)) mod p^n )) \<rparr>"
  unfolding \<H>_def
  by (simp add:p_n_def[symmetric] m_def[symmetric] f_def[symmetric] g_def f'_def Let_def cw.space_def)

lemma \<H>_size: "size S > 0"
  unfolding S_eq using p_m_gt_0 k_gt_0 by simp

lemma sample_space: "sample_space S"
  using \<H>_size unfolding sample_space_def by simp

lemma sample_space_R: "sample_space R"
  using size_R p_n_gt_0 unfolding sample_space_def by auto

lemma range: "range (select S i) \<subseteq> sample_set R"
proof -
  define \<alpha> where "\<alpha> = select S i"
  have "\<alpha> x \<in> sample_set R" for x
  proof -
    have "\<alpha> \<in> sample_set S"
      unfolding \<alpha>_def by (intro select_range sample_space)
    then obtain j where \<alpha>_alt: "\<alpha> = (\<lambda>x. select R (f' (cw.hash (f x) (g j)) mod p^n))" "j < p^(m*k)"
      unfolding sample_set_alt[OF sample_space] unfolding S_eq by auto
    thus "\<alpha> x \<in> sample_set R"
      unfolding \<alpha>_alt
      by (intro select_range sample_space_R)
  qed
  thus ?thesis
    unfolding \<alpha>_def by auto
qed

lemma cw_space: "map_pmf g (pmf_of_set {..<p^(m*k)}) = pmf_of_set cw.space"
proof-
  have card_cw_space: "p ^ (m * k) = card (cw.space)"
    unfolding cw.space_def cw.bounded_degree_polynomials_card  field_size
    by (simp add:power_mult)
  have card_cw_space_gt_0: "card (cw.space) > 0"
    using card_gt_0_iff cw.finite_space cw.non_empty_bounded_degree_polynomials by blast

  show ?thesis
    unfolding g_def using card_cw_space card_cw_space_gt_0
      bij_betw_from_nat_into_finite[where S="cw.space"]
    by (intro map_pmf_of_set_bij_betw) auto
qed

lemma single:
  assumes "x < d"
  shows "map_pmf (\<lambda>\<omega>. \<omega> x) (sample_pmf S) = sample_pmf R" (is "?L = ?R")
proof -
  have f_x_carr: "f x \<in> carrier (GF (p^m))"
    using assms d_lt_p_m
    by (intro bij_betw_apply[OF f_bij]) auto

  have "pmf (map_pmf (cw.hash (f x)) (pmf_of_set cw.space)) i =
    pmf (pmf_of_set (carrier (GF (p ^ m)))) i" (is "?L1 = ?R1") for i
  proof -
    have "?L1 = cw.prob (cw.hash (f x) -` {i})"
      unfolding cw.M_def by (simp add:pmf_map)
    also have "... = real (card ({i} \<inter> carrier (GF (p ^ m)))) / real cw.field_size"
      using cw.prob_range[OF f_x_carr, where A="{i}" ] by (simp add:vimage_def)
    also have "... = ?R1"
      by (cases "i \<in> carrier (GF (p^m))", auto)
    finally  show ?thesis by simp
  qed

  hence b: "map_pmf (cw.hash (f x)) (pmf_of_set cw.space) = pmf_of_set (carrier (GF (p^m)))"
    by (intro pmf_eqI) simp

  have c: "map_pmf f' (pmf_of_set (carrier (GF (p^m)))) = pmf_of_set {..<p^m}"
    unfolding f'_def using to_nat_on_finite[where S="carrier (GF (p^m))"] field_size
    by (intro map_pmf_of_set_bij_betw) auto

  have "n \<le> m" "p > 0"
    using n_lt_m p_prime prime_gt_0_nat by auto
  hence d: "map_pmf (\<lambda>x. x mod p^n) (pmf_of_set {..<p^m}) = pmf_of_set {..<p^n}"
    using split_pmf_mod[where a = "p^n" and b="p^(m-n)"]
    by (simp add:power_add[symmetric])

  have "?L = map_pmf ((\<lambda>\<omega>. \<omega> x) \<circ> (sample_space_select S)) (pmf_of_set {..<size S})"
    unfolding sample_pmf_def by (simp add:map_pmf_compose)
  also have "... = map_pmf (\<lambda>\<omega>. sample_space_select S \<omega> x) (pmf_of_set {..<size S})"
    by (simp add:comp_def)
  also have "... = map_pmf (select R \<circ> (\<lambda>x. x mod p^n) \<circ> f' \<circ> (cw.hash (f x)) \<circ> g) (pmf_of_set {..<p^(m*k)})"
    unfolding S_eq by (simp add:comp_def)
  also have "... = map_pmf (select R) (pmf_of_set {..<p^n})"
    by (simp add:map_pmf_compose cw_space b c d)
  also have "... = ?R"
    unfolding sample_pmf_alt[OF sample_space_R] size_R by simp
  finally show ?thesis by simp
qed

lemma \<H>_indep:
  "prob_space.k_wise_indep_vars (sample_pmf S) k (\<lambda>_. discrete) (\<lambda>i \<omega>. \<omega> i) {..<d}"
proof -
  let ?p = "map_pmf g (pmf_of_set {..<p ^ (m * k)})"
  let ?h = "(\<lambda>i x. select R (f' (cw.hash (f x) i) mod p ^ n))"

  have a:"cw.k_wise_indep_vars k (\<lambda>_. discrete) cw.hash (f ` {..<d})"
    using d_lt_p_m
    by (intro cw.k_wise_indep_subset[OF _ cw.k_wise_indep] image_subsetI bij_betw_apply[OF f_bij])
    auto

  have "cw.k_wise_indep_vars k (\<lambda>_. discrete) (\<lambda>i \<omega>. select R (f' (cw.hash i \<omega>) mod p^n)) (f ` {..<d})"
    by (intro cw.k_wise_indep_vars_compose[OF a]) auto
  moreover
  have "inj_on f {..<p^m}"
    using f_bij bij_betw_def by auto
  hence "inj_on f {..<d}"
    using inj_on_subset d_lt_p_m by blast
  ultimately have "cw.k_wise_indep_vars k (\<lambda>_. discrete) (\<lambda>i \<omega>. select R (f' (cw.hash (f i) \<omega>) mod p ^ n)) {..<d}"
    using cw.k_wise_indep_vars_reindex[where f="f"] unfolding comp_def by auto

  hence "prob_space.k_wise_indep_vars (measure_pmf ((map_pmf ?h \<circ> map_pmf g) (pmf_of_set {..<p^(m*k)}))) k
     (\<lambda>_. discrete) (\<lambda>i \<omega>. \<omega> i) {..<d}"
    unfolding cw.M_def cw_space[symmetric] comp_def by (intro k_wise_indep_vars_map_pmf[where p="?p"]) auto

  hence "prob_space.k_wise_indep_vars (measure_pmf (map_pmf (\<lambda>i x. ?h (g i) x) (pmf_of_set {..<p^(m*k)}))) k
     (\<lambda>_. discrete) (\<lambda>i \<omega>. \<omega> i) {..<d}"
    unfolding map_pmf_compose[symmetric] by (simp add:comp_def)

  thus ?thesis
    unfolding sample_pmf_def S_eq by simp
qed

lemma size:
  fixes m :: nat
  assumes "d > 0"
  defines m_altdef: "m \<equiv> max n (nat \<lceil>log p d\<rceil>)"
  shows "size S = p^(m*k)"
proof -
  have "real d = p powr (log p d)"
    using assms prime_gt_1_nat[OF p_prime]
    by (intro powr_log_cancel[symmetric]) auto
  also have "... \<le> p powr (nat \<lceil>log p d\<rceil>)"
    using prime_gt_1_nat[OF p_prime] by (intro powr_mono) linarith+
  also have "... = p^ (nat \<lceil>log p d\<rceil>)"
    using prime_gt_1_nat[OF p_prime] by (subst powr_realpow) auto
  also have "... \<le> p^m"
    using prime_gt_1_nat[OF p_prime] unfolding m_altdef
    by (intro power_increasing Nat.of_nat_mono) auto
  finally have "d \<le> p ^ m"
    by simp

  moreover have "n \<le> m"
    unfolding m_altdef by simp
  moreover have "m \<le> y" if "d \<le> p ^ y" "n \<le> y" for y
  proof -
    have "log p d \<le> log p (p ^ y)"
      using assms prime_gt_1_nat[OF p_prime]
      by (intro iffD2[OF log_le_cancel_iff] that(1) Nat.of_nat_mono) auto
    also have "... = log p (p powr (real y))"
      using prime_gt_1_nat[OF p_prime] by (subst powr_realpow) auto
    also have "... = y"
      using prime_gt_1_nat[OF p_prime] by (intro log_powr_cancel) auto
    finally have "log p d \<le> y" by simp
    hence "nat \<lceil>log p d\<rceil> \<le> y"
      by simp
    thus "m \<le> y"
      using that(2) unfolding m_altdef by simp
  qed
  ultimately have m_eq: "m = (LEAST j. d \<le> p ^ j \<and> n \<le> j)"
    by (intro Least_equality[symmetric]) auto

  show ?thesis
    unfolding S_eq m_def m_eq by simp
qed

end

text \<open>Sample space with a geometric distribution\<close>

fun count_zeros :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "count_zeros 0 k = 0" |
  "count_zeros (Suc n) k = (if odd k then 0 else 1 + count_zeros n (k div 2))"

lemma count_zeros_iff: "j \<le> n \<Longrightarrow> count_zeros n k \<ge> j \<longleftrightarrow> 2^j dvd k"
proof (induction j arbitrary: n k)
  case 0
  then show ?case by simp
next
  case (Suc j)
  then obtain n' where n_def: "n = Suc n'" using Suc_le_D by presburger
  show ?case using Suc unfolding n_def by auto
qed

lemma count_zeros_max:
  "count_zeros n k \<le> n"
  by (induction n arbitrary: k) auto

definition \<G> :: "nat \<Rightarrow> nat sample_space" where
  "\<G> n = \<lparr> size = 2^n, sample_space_select = count_zeros n \<rparr>"

lemma \<G>_sample_space[simp]: "sample_space (\<G> n)"
  unfolding sample_space_def \<G>_def by simp

lemma \<G>_range: "sample_set (\<G> n) \<subseteq> {..n}"
  using count_zeros_max
  unfolding sample_set_alt[OF \<G>_sample_space] unfolding \<G>_def by auto

lemma \<G>_prob:
  "measure  (sample_pmf (\<G> n)) {\<omega>. \<omega> \<ge> j} = of_bool (j \<le> n) / 2^j" (is "?L = ?R")
proof (cases "j \<le> n")
  case True
  have a:"{..<(2^n)::nat} \<noteq> {}"
    by (simp add: lessThan_empty_iff)
  have b:"finite {..<(2^n)::nat}" by simp

  define f :: "nat \<Rightarrow> nat" where "f = (\<lambda>x. x * 2^j)"
  have d:"inj_on  f {..<2^(n-j)}" unfolding f_def by (intro inj_onI) simp

  have e:"2^j > (0::nat)" by simp

  have "y \<in> f ` {..< 2^(n-j)} \<longleftrightarrow> y \<in> {x. x < 2^n \<and> 2^j dvd x}" for y :: nat
  proof -
    have "y \<in> f ` {..< 2^(n-j)} \<longleftrightarrow> (\<exists>x. x < 2 ^ (n - j) \<and> y = 2 ^ j * x)"
      unfolding f_def by auto
    also have "... \<longleftrightarrow> (\<exists>x. 2^j * x < 2^j * 2 ^ (n-j) \<and> y = 2 ^ j * x)"
      using e by simp
    also have "... \<longleftrightarrow> (\<exists>x. 2^j * x < 2^n \<and> y = 2 ^ j * x)"
      using True by (subst power_add[symmetric]) simp
    also have "... \<longleftrightarrow> (\<exists>x. y < 2^n \<and> y = x * 2 ^ j)"
      by (metis Groups.mult_ac(2))
    also have "... \<longleftrightarrow> y \<in> {x. x < 2^n \<and> 2^j dvd x}" by auto
    finally show ?thesis by simp
  qed

  hence c:"f ` {..< 2^(n-j)} = {x. x < 2^n \<and> 2^j dvd x}" by auto

  have "?L = measure (pmf_of_set {..<2^n}) {\<omega>. count_zeros n \<omega> \<ge> j}"
    unfolding sample_pmf_def \<G>_def by simp
  also have "... = real (card {x::nat. x < 2^n \<and> 2^j dvd x}) / 2^n"
    by (simp add: measure_pmf_of_set[OF a b] count_zeros_iff[OF True])
     (simp add:lessThan_def Collect_conj_eq)
  also have "... = real (card (f ` {..<2^(n-j)})) / 2^n"
    by (simp add:c)
  also have "... = real (card ({..<(2^(n-j)::nat)})) / 2^n"
    by (simp add: card_image[OF d])
  also have "... = ?R"
    using True by (simp add:frac_eq_eq power_add[symmetric])
  finally show ?thesis by simp
next
  case False
  have "set_pmf (sample_pmf (\<G> n)) \<subseteq> {..n}"
    unfolding sample_space_alt[OF \<G>_sample_space, symmetric]
    using \<G>_range by simp
  hence "?L = measure (sample_pmf (\<G> n)) {}"
    using False by (intro measure_pmf_cong) auto
  also have "... = ?R"
    using False by simp
  finally show ?thesis
    by simp
qed

lemma \<G>_prob_single:
  "measure  (sample_pmf (\<G> n)) {j} \<le> 1 / 2^j" (is "?L \<le> ?R")
proof -
  have "?L = measure (sample_pmf (\<G> n)) ({j..}-{j+1..})"
    by (intro measure_pmf_cong) auto
  also have "... = measure (sample_pmf (\<G> n)) {j..} - measure (sample_pmf (\<G> n)) {j+1..}"
    by (intro measure_Diff) auto
  also have "... = measure (sample_pmf (\<G> n)) {\<omega>. \<omega> \<ge> j}-measure (sample_pmf (\<G> n)) {\<omega>. \<omega> \<ge> (j+1)}"
    by (intro arg_cong2[where f="(-)"] measure_pmf_cong) auto
  also have "... = of_bool (j \<le> n) * 1 / 2 ^ j - of_bool (j + 1 \<le> n) / 2 ^ (j + 1)"
    unfolding \<G>_prob by simp
  also have "... \<le> 1/2^j - 0"
    by (intro diff_mono) auto
  also have "... = ?R" by simp
  finally show ?thesis by simp
qed

subsection \<open>Expander Walks\<close>

definition \<E> :: "nat \<Rightarrow> real \<Rightarrow> 'a sample_space \<Rightarrow> (nat \<Rightarrow> 'a) sample_space"
  where "\<E> l \<Lambda> S = (let e = see_standard (size S) \<Lambda> in
    \<lparr> size = see_size e * see_degree e^(l-1),
      sample_space_select = (\<lambda>i j. select S (see_sample_walk e (l-1) i ! j)) \<rparr>) "

locale expander_sample_space =
  fixes l :: nat
  fixes \<Lambda> :: real
  fixes S :: "'a sample_space"
  assumes l_gt_0: "l > 0"
  assumes \<Lambda>_gt_0: "\<Lambda> > 0"
  assumes sample_space_S: "sample_space S"
begin

definition e where "e = see_standard (size S) \<Lambda>"

lemma size_S_gt_0: "size S > 0"
  using sample_space_S unfolding sample_space_def by simp

lemma \<E>_alt: "(\<E> l \<Lambda> S) =
  \<lparr> size = see_size e * see_degree e^(l-1),
    sample_space_select = (\<lambda>i j. select S (see_sample_walk e (l-1) i ! j)) \<rparr>"
  unfolding \<E>_def e_def[symmetric] by (simp add:Let_def)

lemmas see_standard = see_standard[OF size_S_gt_0 \<Lambda>_gt_0]

sublocale E: regular_graph "graph_of e"
  using see_standard(1) unfolding is_expander_def e_def by auto

lemma e_deg_gt_0: "see_degree e > 0"
  unfolding e_def see_standard by simp

lemma e_size_gt_0: "see_size e > 0"
  unfolding e_def see_standard using size_S_gt_0 by simp

lemma sample_space: "sample_space (\<E> l \<Lambda> S)"
  unfolding sample_space_def \<E>_alt using e_size_gt_0 e_deg_gt_0 by simp

lemma range: "select (\<E> l \<Lambda> S) i j \<in> sample_set S"
proof -
  define \<alpha> where "\<alpha> = select (\<E> l \<Lambda> S) i"
  have "\<alpha> \<in> sample_set (\<E> l \<Lambda> S)"
    unfolding \<alpha>_def by (intro select_range sample_space)
  then obtain k where "\<alpha> = sample_space_select  (\<E> l \<Lambda> S) k"
    using sample_set_alt[OF sample_space] by auto
  hence "\<alpha> j \<in> sample_set S"
    unfolding \<E>_alt using select_range[OF sample_space_S] by simp
  thus ?thesis
    unfolding \<alpha>_def by simp
qed

lemma sample_set: "sample_set (\<E> l \<Lambda> S) \<subseteq> (UNIV \<rightarrow> sample_set S)"
proof (rule subsetI)
  fix x assume "x \<in> sample_set (\<E> l \<Lambda> S)"

  then obtain i where "x = select (\<E> l \<Lambda> S) i"
    unfolding sample_set_def by auto
  thus "x \<in> UNIV \<rightarrow> sample_set S"
    using range by auto
qed

lemma walks:
  defines "R \<equiv> map_pmf (\<lambda>xs i. select S (xs ! i)) (pmf_of_multiset (walks (graph_of e) l))"
  shows "sample_pmf (\<E> l \<Lambda> S) = R"
proof -
  let ?S = "{..<see_size e * see_degree e ^ (l-1)}"
  let ?T = "(map_pmf (see_sample_walk e (l-1)) (pmf_of_set ?S))"

  have "0 \<in> ?S"
    using e_size_gt_0 e_deg_gt_0 l_gt_0 by auto
  hence "?S \<noteq> {}"
    by blast
  hence "?T = pmf_of_multiset {#see_sample_walk e (l-1) i. i \<in># mset_set ?S#}"
    by (subst map_pmf_of_set) simp_all
  also have "... = pmf_of_multiset (walks' (graph_of e) (l-1))"
    by (subst see_sample_walk) auto
  also have "... = pmf_of_multiset (walks (graph_of e) l)"
    unfolding walks_def using l_gt_0 by (cases l, simp_all)
  finally have 0:"?T = pmf_of_multiset (walks (graph_of e) l)"
    by simp

  have "sample_pmf (\<E> l \<Lambda> S) = map_pmf (\<lambda>xs j. select S (xs ! j)) ?T"
    unfolding map_pmf_comp sample_pmf_def \<E>_alt by simp
  also have "... = R"
    unfolding 0 R_def by simp
  finally show ?thesis by simp
qed

lemma uniform_property:
  assumes "i < l"
  shows "map_pmf (\<lambda>w. w i) (\<E> l \<Lambda> S) = sample_pmf S" (is "?L = ?R")
proof -
  have "?L = map_pmf (select S) (map_pmf (\<lambda>xs. (xs ! i)) (pmf_of_multiset (walks (graph_of e) l)))"
    unfolding walks by (simp add: map_pmf_comp)
  also have "... = map_pmf (select S) (pmf_of_set (verts (graph_of e)))"
    unfolding E.uniform_property[OF assms] by simp
  also have "... = ?R"
    unfolding sample_pmf_alt[OF sample_space_S] e_def graph_of_def using see_standard by simp
  finally show ?thesis
    by simp
qed

lemma size:
  "size (\<E> l \<Lambda> S) =  size S * (16 ^ ((l-1) * nat \<lceil>ln \<Lambda> / ln (19 / 20)\<rceil>))" (is "?L = ?R")
proof -
  have "?L = see_size e * see_degree e ^ (l - 1)"
    unfolding \<E>_alt by simp
  also have "... = size S *  (16 ^ nat \<lceil>ln \<Lambda> / ln (19 / 20)\<rceil>) ^ (l - 1)"
    using see_standard unfolding e_def by simp
  also have "... = size S * (16 ^ ((l-1) * nat \<lceil>ln \<Lambda> / ln (19 / 20)\<rceil>))"
    unfolding power_mult[symmetric] by (simp add:ac_simps)
  finally show ?thesis
    by simp
qed

end

end


theory Nominal_Bounded_Set
imports
  Nominal2.Nominal2
  "HOL-Cardinals.Bounded_Set"
begin

section \<open>Bounded Sets Equipped With a Permutation Action\<close>

text \<open>Additional lemmas about bounded sets.\<close>

interpretation bset_lifting: bset_lifting .

lemma Abs_bset_inverse' [simp]:
  assumes "|A| <o natLeq +c |UNIV :: 'k set|"
  shows "set_bset (Abs_bset A :: 'a set['k]) = A"
by (metis Abs_bset_inverse assms mem_Collect_eq)

text \<open>Bounded sets are equipped with a permutation action, provided their elements are.\<close>

instantiation bset :: (pt,type) pt
begin

  lift_definition permute_bset :: "perm \<Rightarrow> 'a set['b] \<Rightarrow> 'a set['b]" is
    permute
  proof -
    fix p and A :: "'a set"
    have "|p \<bullet> A| \<le>o |A|" by (simp add: permute_set_eq_image)
    also assume "|A| <o natLeq +c |UNIV :: 'b set|"
    finally show "|p \<bullet> A| <o natLeq +c |UNIV :: 'b set|" .
  qed

  instance
  by standard (transfer, simp)+

end

lemma Abs_bset_eqvt [simp]:
  assumes "|A| <o natLeq +c |UNIV :: 'k set|"
  shows "p \<bullet> (Abs_bset A :: 'a::pt set['k]) = Abs_bset (p \<bullet> A)"
by (simp add: permute_bset_def map_bset_def image_def permute_set_def) (metis (no_types, lifting) Abs_bset_inverse' assms)

lemma supp_Abs_bset [simp]:
  assumes "|A| <o natLeq +c |UNIV :: 'k set|"
  shows "supp (Abs_bset A :: 'a::pt set['k]) = supp A"
proof -
  from assms have "\<And>p. p \<bullet> (Abs_bset A :: 'a::pt set['k]) \<noteq> Abs_bset A \<longleftrightarrow> p \<bullet> A \<noteq> A"
    by simp (metis map_bset.rep_eq permute_set_eq_image set_bset_inverse set_bset_to_set_bset)
  then show ?thesis
    unfolding supp_def by simp
qed

lemma map_bset_permute: "p \<bullet> B = map_bset (permute p) B"
by transfer (auto simp add: image_def permute_set_def)

lemma set_bset_eqvt [eqvt]:
  "p \<bullet> set_bset B = set_bset (p \<bullet> B)"
by transfer simp

lemma map_bset_eqvt [eqvt]:
  "p \<bullet> map_bset f B = map_bset (p \<bullet> f) (p \<bullet> B)"
by transfer simp

lemma bempty_eqvt [eqvt]: "p \<bullet> bempty = bempty"
by transfer simp

lemma binsert_eqvt [eqvt]: "p \<bullet> (binsert x B) = binsert (p \<bullet> x) (p \<bullet> B)"
by transfer simp

lemma bsingleton_eqvt [eqvt]: "p \<bullet> bsingleton x = bsingleton (p \<bullet> x)"
by (simp add: map_bset_permute)

end


(*  Title:      HOL/MicroJava/DFA/Kildall.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section {* Kildall's Algorithm \label{sec:Kildall} *}

theory Kildall
imports SemilatAlg "~~/src/HOL/Library/While_Combinator"
begin

primrec propa :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> nat set \<Rightarrow> 's list * nat set" where
  "propa f []      ss w = (ss,w)"
| "propa f (q'#qs) ss w = (let (q,t) = q';
                               u = t +_f ss!q;
                               w' = (if u = ss!q then w else insert q w)
                           in propa f qs (ss[q := u]) w')"

definition iter :: "'s binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat set \<Rightarrow> 's list \<times> nat set" where
  "iter f step ss w == while (%(ss,w). w \<noteq> {})
       (%(ss,w). let p = SOME p. p \<in> w
                 in propa f (step p (ss!p)) ss (w-{p}))
       (ss,w)"

definition unstables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat set" where
"unstables r step ss == {p. p < size ss \<and> \<not>stable r step ss p}"

definition kildall :: "'s ord \<Rightarrow> 's binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 's list" where
"kildall r f step ss == fst(iter f step ss (unstables r step ss))"

primrec merges :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 's list" where
  "merges f []      ss = ss"
| "merges f (p'#ps) ss = (let (p,s) = p' in merges f ps (ss[p := s +_f ss!p]))"

lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]

lemma (in Semilat) nth_merges:
 "\<And>ss. \<lbrakk>p < length ss; ss \<in> list n A; \<forall>(p,t)\<in>set ps. p<n \<and> t\<in>A \<rbrakk> \<Longrightarrow>
  (merges f ps ss)!p = map snd [(p',t') \<leftarrow> ps. p'=p] ++_f ss!p"
  (is "\<And>ss. \<lbrakk>_; _; ?steptype ps\<rbrakk> \<Longrightarrow> ?P ss ps")
proof (induct ps)
  show "\<And>ss. ?P ss []" by simp

  fix ss p' ps'
  assume ss: "ss \<in> list n A"
  assume l:  "p < length ss"
  assume "?steptype (p'#ps')"
  then obtain a b where
    p': "p'=(a,b)" and ab: "a<n" "b\<in>A" and ps': "?steptype ps'"
    by (cases p') auto
  assume "\<And>ss. p< length ss \<Longrightarrow> ss \<in> list n A \<Longrightarrow> ?steptype ps' \<Longrightarrow> ?P ss ps'"
  from this [OF _ _ ps'] have IH: "\<And>ss. ss \<in> list n A \<Longrightarrow> p < length ss \<Longrightarrow> ?P ss ps'" .

  from ss ab
  have "ss[a := b +_f ss!a] \<in> list n A" by (simp add: closedD)
  moreover
  from calculation l
  have "p < length (ss[a := b +_f ss!a])" by simp
  ultimately
  have "?P (ss[a := b +_f ss!a]) ps'" by (rule IH)
  with p' l
  show "?P ss (p'#ps')" by simp
qed

(** merges **)

lemma length_merges [simp]: "size(merges f ps ss) = size ss"
  by (induct ps arbitrary: ss) auto

lemma (in Semilat) merges_preserves_type_lemma:
shows "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A)
          \<longrightarrow> merges f ps xs \<in> list n A"
apply (insert closedI)
apply (unfold closed_def)
apply (induct_tac ps)
 apply simp
apply clarsimp
done

lemma (in Semilat) merges_preserves_type [simp]:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A \<rbrakk>
  \<Longrightarrow> merges f ps xs \<in> list n A"
by (simp add: merges_preserves_type_lemma)

lemma (in Semilat) merges_incr_lemma:
 "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A) \<longrightarrow> xs <=[r] merges f ps xs"
apply (induct_tac ps)
 apply simp
apply simp
apply clarify
apply (rule order_trans)
  apply simp
 apply (erule list_update_incr)
  apply simp
 apply simp
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
done

lemma (in Semilat) merges_incr:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A \<rbrakk>
  \<Longrightarrow> xs <=[r] merges f ps xs"
  by (simp add: merges_incr_lemma)

lemma (in Semilat) merges_same_conv [rule_format]:
 "(\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x\<in>A) \<longrightarrow>
     (merges f ps xs = xs) = (\<forall>(p,x)\<in>set ps. x <=_r xs!p))"
  apply (induct_tac ps)
   apply simp
  apply clarsimp
  apply (rename_tac p x ps xs)
  apply (rule iffI)
   apply (rule context_conjI)
    apply (subgoal_tac "xs[p := x +_f xs!p] <=[r] xs")
     apply (drule_tac p = p in le_listD)
      apply simp
     apply simp
    apply (erule subst, rule merges_incr)
       apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
      apply clarify
      apply (rule conjI)
       apply simp
       apply (blast dest: boundedD)
      apply blast
   apply clarify
   apply (erule allE)
   apply (erule impE)
    apply assumption
   apply (drule bspec)
    apply assumption
   apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
   apply blast
  apply clarify
  apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
  done

lemma (in Semilat) list_update_le_listI [rule_format]:
  "set xs <= A \<longrightarrow> set ys <= A \<longrightarrow> xs <=[r] ys \<longrightarrow> p < size xs \<longrightarrow>
   x <=_r ys!p \<longrightarrow> x\<in>A \<longrightarrow> xs[p := x +_f xs!p] <=[r] ys"
  apply(insert semilat)
  apply (unfold Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done

lemma (in Semilat) merges_pres_le_ub:
  assumes "set ts <= A" and "set ss <= A"
    and "\<forall>(p,t)\<in>set ps. t <=_r ts!p \<and> t \<in> A \<and> p < size ts" and "ss <=[r] ts"
  shows "merges f ps ss <=[r] ts"
proof -
  { fix t ts ps
    have
    "\<And>qs. \<lbrakk>set ts <= A; \<forall>(p,t)\<in>set ps. t <=_r ts!p \<and> t \<in> A \<and> p< size ts \<rbrakk> \<Longrightarrow>
    set qs <= set ps  \<longrightarrow>
    (\<forall>ss. set ss <= A \<longrightarrow> ss <=[r] ts \<longrightarrow> merges f qs ss <=[r] ts)"
    apply (induct_tac qs)
     apply simp
    apply (simp (no_asm_simp))
    apply clarify
    apply (rotate_tac -2)
    apply simp
    apply (erule allE, erule impE, erule_tac [2] mp)
     apply (drule bspec, assumption)
     apply (simp add: closedD)
    apply (drule bspec, assumption)
    apply (simp add: list_update_le_listI)
    done
  } note this [dest]

  from assms show ?thesis by blast
qed

(** propa **)

lemma decomp_propa:
  "\<And>ss w. (\<forall>(q,t)\<in>set qs. q < size ss) \<Longrightarrow>
   propa f qs ss w =
   (merges f qs ss, {q. \<exists>t. (q,t)\<in>set qs \<and> t +_f ss!q \<noteq> ss!q} Un w)"
  apply (induct qs)
   apply simp
  apply (simp (no_asm))
  apply clarify
  apply simp
  apply (rule conjI)
   apply blast
  apply (simp add: nth_list_update)
  apply blast
  done

(** iter **)

lemma (in Semilat) stable_pres_lemma:
shows "\<lbrakk>pres_type step n A; bounded step n;
     ss \<in> list n A; p \<in> w; \<forall>q\<in>w. q < n;
     \<forall>q. q < n \<longrightarrow> q \<notin> w \<longrightarrow> stable r step ss q; q < n;
     \<forall>s'. (q,s') \<in> set (step p (ss ! p)) \<longrightarrow> s' +_f ss ! q = ss ! q;
     q \<notin> w \<or> q = p \<rbrakk>
  \<Longrightarrow> stable r step (merges f (step p (ss!p)) ss) q"
  apply (unfold stable_def)
  apply (subgoal_tac "\<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' : A")
   prefer 2
   apply clarify
   apply (erule pres_typeD)
    prefer 3 apply assumption
    apply (rule listE_nth_in)
     apply assumption
    apply simp
   apply simp
  apply simp
  apply clarify
  apply (subst nth_merges)
       apply simp
       apply (blast dest: boundedD)
      apply assumption
     apply clarify
     apply (rule conjI)
      apply (blast dest: boundedD)
     apply (erule pres_typeD)
       prefer 3 apply assumption
      apply simp
     apply simp
apply(subgoal_tac "q < length ss")
prefer 2 apply simp
  apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
apply assumption
  apply clarify
  apply (rule conjI)
   apply (blast dest: boundedD)
  apply (erule pres_typeD)
     prefer 3 apply assumption
    apply simp
   apply simp
  apply (drule_tac P = "\<lambda>x. (a, b) \<in> set (step q x)" in subst)
   apply assumption

 apply (simp add: plusplus_empty)
 apply (cases "q \<in> w")
  apply simp
  apply (rule ub1')
     apply (rule semilat)
    apply clarify
    apply (rule pres_typeD)
       apply assumption
      prefer 3 apply assumption
     apply (blast intro: listE_nth_in dest: boundedD)
    apply (blast intro: pres_typeD dest: boundedD)
   apply (blast intro: listE_nth_in dest: boundedD)
  apply assumption

 apply simp
 apply (erule allE, erule impE, assumption, erule impE, assumption)
 apply (rule order_trans)
   apply simp
  defer
 apply (rule pp_ub2)(*
    apply assumption*)
   apply simp
   apply clarify
   apply simp
   apply (rule pres_typeD)
      apply assumption
     prefer 3 apply assumption
    apply (blast intro: listE_nth_in dest: boundedD)
   apply (blast intro: pres_typeD dest: boundedD)
  apply (blast intro: listE_nth_in dest: boundedD)
 apply blast
 done

lemma (in Semilat) merges_bounded_lemma:
 "\<lbrakk> mono r step n A; bounded step n;
    \<forall>(p',s') \<in> set (step p (ss!p)). s' \<in> A; ss \<in> list n A; ts \<in> list n A; p < n;
    ss <=[r] ts; \<forall>p. p < n \<longrightarrow> stable r step ts p \<rbrakk>
  \<Longrightarrow> merges f (step p (ss!p)) ss <=[r] ts"
  apply (unfold stable_def)
  apply (rule merges_pres_le_ub)
     apply simp
    apply simp
   prefer 2 apply assumption

  apply clarsimp
  apply (drule boundedD, assumption+)
  apply (erule allE, erule impE, assumption)
  apply (drule bspec, assumption)
  apply simp

  apply (drule monoD [of _ _ _ _ p "ss!p"  "ts!p"])
     apply assumption
    apply simp
   apply (simp add: le_listD)

  apply (drule lesub_step_typeD, assumption)
  apply clarify
  apply (drule bspec, assumption)
  apply simp
  apply (blast intro: order_trans)
  done

lemma termination_lemma:
  assumes semilat: "semilat (A, r, f)"
  shows "\<lbrakk> ss \<in> list n A; \<forall>(q,t)\<in>set qs. q<n \<and> t\<in>A; p\<in>w \<rbrakk> \<Longrightarrow>
  ss <[r] merges f qs ss \<or>
  merges f qs ss = ss \<and> {q. \<exists>t. (q,t)\<in>set qs \<and> t +_f ss!q \<noteq> ss!q} Un (w-{p}) < w" (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P" apply(insert semilat)
    apply (unfold lesssub_def)
    apply (simp (no_asm_simp) add: merges_incr)
    apply (rule impI)
    apply (rule merges_same_conv [THEN iffD1, elim_format])
    apply assumption+
    defer
    apply (rule sym, assumption)
    defer apply simp
    apply (subgoal_tac "\<forall>q t. \<not>((q, t) \<in> set qs \<and> t +_f ss ! q \<noteq> ss ! q)")
    apply (blast elim: equalityE)
    apply clarsimp
    apply (drule bspec, assumption)
    apply (drule bspec, assumption)
    apply clarsimp
    done
qed

lemma iter_properties[rule_format]:
  assumes semilat: "semilat (A, r, f)"
  shows "\<lbrakk> acc r ; pres_type step n A; mono r step n A;
     bounded step n; \<forall>p\<in>w0. p < n; ss0 \<in> list n A;
     \<forall>p<n. p \<notin> w0 \<longrightarrow> stable r step ss0 p \<rbrakk> \<Longrightarrow>
   iter f step ss0 w0 = (ss',w')
   \<longrightarrow>
   ss' \<in> list n A \<and> stables r step ss' \<and> ss0 <=[r] ss' \<and>
   (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow> ss' <=[r] ts)"
  (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P" apply(insert semilat)
apply (unfold iter_def stables_def)
apply (rule_tac P = "%(ss,w).
 ss \<in> list n A \<and> (\<forall>p<n. p \<notin> w \<longrightarrow> stable r step ss p) \<and> ss0 <=[r] ss \<and>
 (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow> ss <=[r] ts) \<and>
 (\<forall>p\<in>w. p < n)" and
 r = "{(ss',ss) . ss <[r] ss'} <*lex*> finite_psubset"
       in while_rule)

-- "Invariant holds initially:"
apply (simp add:stables_def)

-- "Invariant is preserved:"
apply(simp add: stables_def split_paired_all)
apply(rename_tac ss w)
apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
 prefer 2 apply (fast intro: someI)
apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
 prefer 2
 apply clarify
 apply (rule conjI)
  apply(clarsimp, blast dest!: boundedD)
 apply (erule pres_typeD)
  prefer 3
  apply assumption
  apply (erule listE_nth_in)
  apply simp
 apply simp
apply (subst decomp_propa)
 apply fast
apply simp
apply (rule conjI)
 apply (rule merges_preserves_type)
 apply blast
 apply clarify
 apply (rule conjI)
  apply(clarsimp, fast dest!: boundedD)
 apply (erule pres_typeD)
  prefer 3
  apply assumption
  apply (erule listE_nth_in)
  apply blast
 apply blast
apply (rule conjI)
 apply clarify
 apply (blast intro!: stable_pres_lemma)
apply (rule conjI)
 apply (blast intro!: merges_incr intro: le_list_trans)
apply (rule conjI)
 apply clarsimp
 apply (blast intro!: merges_bounded_lemma)
apply (blast dest!: boundedD)

-- "Postcondition holds upon termination:"
apply(clarsimp simp add: stables_def split_paired_all)

-- "Well-foundedness of the termination relation:"
apply (rule wf_lex_prod)
 apply (insert orderI [THEN acc_le_listI])
 apply (simp add: acc_def lesssub_def wfP_wf_eq [symmetric])
apply (rule wf_finite_psubset)

-- "Loop decreases along termination relation:"
apply(simp add: stables_def split_paired_all)
apply(rename_tac ss w)
apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
 prefer 2 apply (fast intro: someI)
apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
 prefer 2
 apply clarify
 apply (rule conjI)
  apply(clarsimp, blast dest!: boundedD)
 apply (erule pres_typeD)
  prefer 3
  apply assumption
  apply (erule listE_nth_in)
  apply blast
 apply blast
apply (subst decomp_propa)
 apply blast
apply clarify
apply (simp del: listE_length
    add: lex_prod_def finite_psubset_def
         bounded_nat_set_is_finite)
apply (rule termination_lemma)
apply assumption+
defer
apply assumption
apply clarsimp
done

qed

lemma kildall_properties:
assumes semilat: "semilat (A, r, f)"
shows "\<lbrakk> acc r; pres_type step n A; mono r step n A;
     bounded step n; ss0 \<in> list n A \<rbrakk> \<Longrightarrow>
  kildall r f step ss0 \<in> list n A \<and>
  stables r step (kildall r f step ss0) \<and>
  ss0 <=[r] kildall r f step ss0 \<and>
  (\<forall>ts\<in>list n A. ss0 <=[r] ts \<and> stables r step ts \<longrightarrow>
                 kildall r f step ss0 <=[r] ts)"
  (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P"
apply (unfold kildall_def)
apply(case_tac "iter f step ss0 (unstables r step ss0)")
apply(simp)
apply (rule iter_properties)
apply (simp_all add: unstables_def stable_def)
apply (rule semilat)
done
qed

lemma is_bcv_kildall:
assumes semilat: "semilat (A, r, f)"
shows "\<lbrakk> acc r; top r T; pres_type step n A; bounded step n; mono r step n A \<rbrakk>
  \<Longrightarrow> is_bcv r T step n A (kildall r f step)"
  (is "PROP ?P")
proof -
  interpret Semilat A r f using assms by (rule Semilat.intro)
  show "PROP ?P"
apply(unfold is_bcv_def wt_step_def)
apply(insert semilat kildall_properties[of A])
apply(simp add:stables_def)
apply clarify
apply(subgoal_tac "kildall r f step ss \<in> list n A")
 prefer 2 apply (simp(no_asm_simp))
apply (rule iffI)
 apply (rule_tac x = "kildall r f step ss" in bexI)
  apply (rule conjI)
   apply (blast)
  apply (simp  (no_asm_simp))
 apply(assumption)
apply clarify
apply(subgoal_tac "kildall r f step ss!p <=_r ts!p")
 apply simp
apply (blast intro!: le_listD less_lengthI)
done
qed

end


(*
  File: Quicksort_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of quicksort\<close>

theory Quicksort_Impl
  imports Arrays_Impl "../Functional/Quicksort"
begin

text \<open>
  Imperative implementation of quicksort. Also verified in
  theory Imperative\_Quicksort in HOL/Imperative\_HOL/ex
  in the Isabelle library.
\<close>

partial_function (heap) part1 :: "'a::{heap,linorder} array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat Heap" where
  "part1 a l r p = (
     if r \<le> l then return r
     else do {
       v \<leftarrow> Array.nth a l;
       if v \<le> p then
         part1 a (l + 1) r p
       else do {
         swap a l r;
         part1 a l (r - 1) p }})"

lemma part1_to_fun [hoare_triple]:
  "r < length xs \<Longrightarrow> <p \<mapsto>\<^sub>a xs>
   part1 p l r a
   <\<lambda>rs. p \<mapsto>\<^sub>a snd (Quicksort.part1 xs l r a) * \<up>(rs = fst (Quicksort.part1 xs l r a))>"
@proof @fun_induct "Quicksort.part1 xs l r a" @unfold "Quicksort.part1 xs l r a" @qed

text \<open>Partition function\<close>
definition partition :: "'a::{heap,linorder} array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat Heap" where
  "partition a l r = do {
     p \<leftarrow> Array.nth a r;
     m \<leftarrow> part1 a l (r - 1) p;
     v \<leftarrow> Array.nth a m;
     m' \<leftarrow> return (if v \<le> p then m + 1 else m);
     swap a m' r;
     return m'
   }"

lemma partition_to_fun [hoare_triple]:
  "l < r \<Longrightarrow> r < length xs \<Longrightarrow> <a \<mapsto>\<^sub>a xs>
   partition a l r
   <\<lambda>rs. a \<mapsto>\<^sub>a snd (Quicksort.partition xs l r) * \<up>(rs = fst (Quicksort.partition xs l r))>"
@proof @unfold "Quicksort.partition xs l r" @qed

text \<open>Quicksort function\<close>
partial_function (heap) quicksort :: "'a::{heap,linorder} array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "quicksort a l r = do {
     len \<leftarrow> Array.len a;
     if l \<ge> r then return ()
     else if r < len then do {
       p \<leftarrow> partition a l r;
       quicksort a l (p - 1);
       quicksort a (p + 1) r
     }
     else return ()
   }"

lemma quicksort_to_fun [hoare_triple]:
  "r < length xs \<Longrightarrow> <a \<mapsto>\<^sub>a xs>
   quicksort a l r
   <\<lambda>_. a \<mapsto>\<^sub>a Quicksort.quicksort xs l r>"
@proof @fun_induct "Quicksort.quicksort xs l r" @unfold "Quicksort.quicksort xs l r" @qed

definition quicksort_all :: "('a::{heap,linorder}) array \<Rightarrow> unit Heap" where
  "quicksort_all a = do {
     n \<leftarrow> Array.len a;
     if n = 0 then return ()
     else quicksort a 0 (n - 1)
   }"

text \<open>Correctness of quicksort.\<close>

end


theory Week5
  imports Main
begin

thm allI
thm exI
lemma none_not_implies_every: "\<not>(\<exists> x. \<not> F x) \<longrightarrow> (\<forall> x. F x)"
proof (rule impI)
  assume "\<not>(\<exists> x. \<not> F x)"
  show "(\<forall> x. F x)"
  proof (rule allI)
    fix x
    show "F x"
    proof (rule ccontr)
      assume "\<not>(F x)"
      then have "\<exists> x. \<not> (F x)" by (rule exI)
      with `\<not>(\<exists> x. \<not> F x)` show False by (rule notE)
    qed
  qed
qed

thm allE
lemma not_all_implies_some_not:"\<not>(\<forall> y. F y) \<longrightarrow> (\<exists> x. \<not> F x)"
proof (rule impI)
  assume "\<not> (\<forall> y. F y)"
  show "(\<exists> x. \<not> F x)"
  proof (rule ccontr)
    assume "\<not>(\<exists> x. \<not> F x)"
    with none_not_implies_every have "(\<forall> y. F y)" by (rule mp)
    with `\<not> (\<forall> y. F y)` show False by (rule notE)
  qed
qed

(* Proof by cases *)
lemma "(\<exists> x. F x) \<longrightarrow> (\<forall> y. F y)" oops

lemma"\<exists> x.(\<exists> y. F y) \<longrightarrow> F x" oops

lemma "(\<forall> x. R x y) \<longrightarrow> (\<forall> x. R y x \<longrightarrow>x = z) \<longrightarrow> y = z"
proof(rule impI)
  assume "\<forall> x. R x y"
  then have "R y y" by (rule allE)
  show "(\<forall> x. R y x \<longrightarrow>x = z) \<longrightarrow> y = z"
  proof(rule impI)
    assume "\<forall> x. R y x \<longrightarrow> x = z"
    then have "R y y \<longrightarrow> y = z" by (rule allE)
    thus "y = z" using `R y y` by (rule mp)
  qed
qed

end


section \<open>The Consensus Data Type\<close>

theory Consensus
imports RDR
begin

text \<open>This theory provides a model for the RDR locale, thus showing
  that the assumption of the RDR locale are consistent.\<close>

typedecl proc
typedecl val

locale Consensus
\<comment> \<open>To avoid name clashes\<close>
begin

fun \<delta>::"val option \<Rightarrow> (proc \<times> val) \<Rightarrow> val option" (infix "\<bullet>" 65) where
  "\<delta> None r = Some (snd r)"
| "\<delta> (Some v) r = Some v"

fun \<gamma>::"val option \<Rightarrow> (proc \<times> val) \<Rightarrow> val" where
  "\<gamma> None r = snd r"
| "\<gamma> (Some v) r = v"

interpretation pre_RDR \<delta> \<gamma> None .
notation exec (infix "\<star>" 65)
notation less_eq (infix "\<preceq>" 50 )
notation None ("\<bottom>")

lemma single_use:
  fixes r rs
  shows  "\<bottom> \<star> ([r]@rs) = Some (snd r)"
proof (induct rs)
  case Nil
  thus ?case by simp
next
  case (Cons r rs)
  thus ?case by auto
qed

lemma bot: "\<exists> rs . s = \<bottom> \<star> rs"
proof (cases s)
  case None
  hence "s = \<bottom> \<star> []" by auto
  thus ?thesis by blast
next
  case (Some v)
  obtain r where "\<bottom> \<star> [r] = Some v" by force
  thus ?thesis using Some by metis
qed

lemma prec_eq_None_or_equal:
fixes s1 s2
assumes "s1 \<preceq> s2"
shows "s1 = None \<or> s1 = s2" using assms single_use
proof -
  { assume 1:"s1 \<noteq> None" and 2:"s1 \<noteq> s2"
    obtain r rs where 3:"s1 = \<bottom> \<star> ([r]@rs)" using bot using 1
      by (metis append_butlast_last_id pre_RDR.exec.simps(1))
    obtain rs' where 4:"s2 = s1 \<star> rs'" using assms
      by (auto simp add:less_eq_def)
    have "s2 = \<bottom> \<star> ([r]@(rs@rs'))" using 3 4
      by (metis exec_append)
    hence "s1 = s2" using 3
      by (metis single_use)
    with 2 have False by auto }
  thus ?thesis by blast
qed

interpretation RDR \<delta> \<gamma> \<bottom>
proof (unfold_locales)
  fix s r
  assume "contains s r"
  show "s \<bullet> r = s"
  proof -
    obtain rs where "s = \<bottom> \<star> rs" and "rs \<noteq> []"
      using \<open>contains s r\<close>
      by (auto simp add:contains_def, force)
    thus ?thesis
    by (metis \<delta>.simps(2) rev_exhaust single_use)
  qed
next
  fix s and r r' :: "proc \<times> val"
  assume 1:"fst r \<noteq> fst r'"
  thus "\<gamma> s r = \<gamma> ((s \<bullet> r) \<bullet> r') r"
    by (metis \<delta>.simps \<gamma>.simps not_Some_eq)
next
  fix s1 s2
  assume "s1 \<preceq> s2 \<and> s2 \<preceq> s1"
  thus "s1 = s2" by (metis prec_eq_None_or_equal)
next
  fix s1 s2
  show "\<exists> s . is_glb s s1 s2"
  by (simp add:is_glb_def is_lb_def)
    (metis bot pre_RDR.less_eq_def prec_eq_None_or_equal)
next
  fix s
  show "\<bottom> \<preceq> s"
  by (metis bot pre_RDR.less_eq_def)
next
  fix s1 s2 s3 rs
  assume "s1 \<preceq> s2" and "s2 \<preceq> s3" and "s3 = s1 \<star> rs"
  thus "\<exists> rs' rs'' . s2 = s1 \<star> rs' \<and> s3 = s2 \<star> rs''
    \<and> set rs' \<subseteq> set rs \<and> set rs'' \<subseteq> set rs"
  by (metis Consensus.prec_eq_None_or_equal
      in_set_insert insert_Nil list.distinct(1)
        pre_RDR.exec.simps(1) subsetI)
qed

end

end


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

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

datatype Expr = Var "int" | Lam "int" "Expr" | App "Expr" "Expr"

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

fun newmaximum :: "int => int list => int" where
  "newmaximum y (nil2) = y"
| "newmaximum y (cons2 z2 ys) =
     (if y <= z2 then newmaximum z2 ys else newmaximum y ys)"

fun new :: "int list => int" where
  "new y = (newmaximum 0 y) + 1"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter p (nil2) = nil2"
| "filter p (cons2 z xs) =
     (if p z then cons2 z (filter p xs) else filter p xs)"

fun free :: "Expr => int list" where
  "free (Var z) = cons2 z (nil2)"
| "free (Lam z2 b) = filter (% (x2 :: int) => (z2 ~= x2)) (free b)"
| "free (App a2 b2) = x (free a2) (free b2)"

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

(*fun did not finish the proof*)
function subst :: "int => Expr => Expr => Expr" where
  "subst y z (Var y2) = (if (y = y2) then z else Var y2)"
| "subst y z (Lam y3 a) =
     (let z22 :: int = new (x (free z) (free a))
     in (if (y = y3) then Lam y3 a else
           (if elem y3 (free z) then
              subst y z (Lam z22 (subst y3 (Var z22) a))
              else
              Lam y3 (subst y z a))))"
| "subst y z (App a2 b2) = App (subst y z a2) (subst y z b2)"
  by pat_completeness auto

theorem property0 :
  "((~ (elem y (free a))) ==>
      ((elem z (free a)) = (elem z (free (subst y e a)))))"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_24
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

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

theorem property0 :
  "((x (max a b) a) = (t2 b a))"
  oops

end