header{* Lemmas about undirected graphs *}

theory Ugraph_Lemmas
imports
  Prob_Lemmas
  "../Girth_Chromatic/Girth_Chromatic"
  Lattices_Big
begin

text{* The complete graph is a graph where all possible edges are present. It is wellformed by
definition. *}

definition complete :: "nat set \<Rightarrow> ugraph" where
"complete V = (V, all_edges V)"

lemma complete_wellformed: "uwellformed (complete V)"
unfolding complete_def uwellformed_def all_edges_def
by simp

text{* If the set of vertices is finite, the set of edges in the complete graph is finite. *}

lemma all_edges_finite: "finite V \<Longrightarrow> finite (all_edges V)"
unfolding all_edges_def
by simp

corollary complete_finite_edges: "finite V \<Longrightarrow> finite (uedges (complete V))"
unfolding complete_def using all_edges_finite
by simp

text{* The sets of possible edges of disjoint sets of vertices are disjoint. *}

lemma all_edges_disjoint: "S \<inter> T = {} \<Longrightarrow> all_edges S \<inter> all_edges T = {}"
unfolding all_edges_def
by force

text{* A graph is called `finite' if its set of edges and its set of vertices are finite. *}

definition "finite_graph G \<equiv> finite (uverts G) \<and> finite (uedges G)"

text{* The complete graph is finite. *}

corollary complete_finite: "finite V \<Longrightarrow> finite_graph (complete V)"
using complete_finite_edges unfolding finite_graph_def complete_def
by simp

text{* A graph is called `nonempty' if it contains at least one vertex and at least one edge. *}

definition "nonempty_graph G \<equiv> uverts G \<noteq> {} \<and> uedges G \<noteq> {}"

text{* A random graph is both wellformed and finite. *}

lemma (in edge_space) wellformed_and_finite:
  assumes "E \<in> Pow S_edges"
  shows "finite_graph (edge_ugraph E)" "uwellformed (edge_ugraph E)"
unfolding finite_graph_def
proof
  show "finite (uverts (edge_ugraph E))"
    unfolding edge_ugraph_def S_verts_def by simp
next
  show "finite (uedges (edge_ugraph E))"
    using assms unfolding edge_ugraph_def S_edges_def by (auto intro: all_edges_finite)
next
  show "uwellformed (edge_ugraph E)"
    using complete_wellformed unfolding edge_ugraph_def S_edges_def complete_def uwellformed_def by force
qed

text{* The probability for a random graph to have $e$ edges is $p ^ e$. *}

lemma (in edge_space) cylinder_empty_prob:
  "A \<subseteq> S_edges \<Longrightarrow> prob (cylinder S_edges A {}) = p ^ (card A)"
using cylinder_prob by auto

subsection{* Subgraphs *}

definition subgraph :: "ugraph \<Rightarrow> ugraph \<Rightarrow> bool" where
"subgraph G' G \<equiv> uverts G' \<subseteq> uverts G \<and> uedges G' \<subseteq> uedges G"

lemma subgraph_refl: "subgraph G G"
unfolding subgraph_def
by simp

lemma subgraph_trans: "subgraph G'' G' \<Longrightarrow> subgraph G' G \<Longrightarrow> subgraph G'' G"
unfolding subgraph_def
by auto

lemma subgraph_antisym: "subgraph G G' \<Longrightarrow> subgraph G' G \<Longrightarrow> G = G'"
unfolding subgraph_def
by (auto simp add: Product_Type.prod_eqI)

lemma subgraph_complete:
  assumes "uwellformed G"
  shows "subgraph G (complete (uverts G))"
proof -
  {
    fix e
    assume "e \<in> uedges G"
    with assms have "card e = 2" and u: "\<And>u. u \<in> e \<Longrightarrow> u \<in> uverts G"
      unfolding uwellformed_def by auto
    moreover then obtain u v where "e = {u, v}" "u \<noteq> v"
      by (metis card_2_elements)
    ultimately have "e = mk_uedge (u, v)" "u \<in> uverts G" "v \<in> uverts G"
      by auto
    hence "e \<in> all_edges (uverts G)"
      unfolding all_edges_def using `u \<noteq> v` by fastforce
  }
  thus ?thesis
    unfolding complete_def subgraph_def by auto
qed

corollary wellformed_all_edges: "uwellformed G \<Longrightarrow> uedges G \<subseteq> all_edges (uverts G)"
using subgraph_complete subgraph_def complete_def by simp

lemma subgraph_finite: "\<lbrakk> finite_graph G; subgraph G' G \<rbrakk> \<Longrightarrow> finite_graph G'"
unfolding finite_graph_def subgraph_def
by (metis rev_finite_subset)

corollary wellformed_finite:
  assumes "finite (uverts G)" and "uwellformed G"
  shows "finite_graph G"
proof (rule subgraph_finite[where G = "complete (uverts G)"])
  show "subgraph G (complete (uverts G))"
    using assms by (simp add: subgraph_complete)
next
  have "finite (uedges (complete (uverts G)))"
    using complete_finite_edges[OF assms(1)] .
  thus "finite_graph (complete (uverts G))"
    unfolding finite_graph_def complete_def using assms(1) by auto
qed

definition subgraphs :: "ugraph \<Rightarrow> ugraph set" where
"subgraphs G = {G'. subgraph G' G}"

definition nonempty_subgraphs :: "ugraph \<Rightarrow> ugraph set" where
"nonempty_subgraphs G = {G'. uwellformed G' \<and> subgraph G' G \<and> nonempty_graph G'}"

lemma subgraphs_finite:
  assumes "finite_graph G"
  shows "finite (subgraphs G)"
proof -
  have "subgraphs G = {(V', E'). V' \<subseteq> uverts G \<and> E' \<subseteq> uedges G}"
    unfolding subgraphs_def subgraph_def by force
  moreover have "finite (uverts G)" "finite (uedges G)"
    using assms unfolding finite_graph_def by auto
  ultimately show ?thesis
    by simp
qed

corollary nonempty_subgraphs_finite: "finite_graph G \<Longrightarrow> finite (nonempty_subgraphs G)"
using subgraphs_finite
unfolding nonempty_subgraphs_def subgraphs_def
by auto

subsection{* Induced subgraphs *}

definition induced_subgraph :: "uvert set \<Rightarrow> ugraph \<Rightarrow> ugraph" where
"induced_subgraph V G = (V, uedges G \<inter> all_edges V)"

lemma induced_is_subgraph:
  "V \<subseteq> uverts G \<Longrightarrow> subgraph (induced_subgraph V G) G"
  "V \<subseteq> uverts G \<Longrightarrow> subgraph (induced_subgraph V G) (complete V)"
unfolding subgraph_def induced_subgraph_def complete_def
by simp+

lemma induced_wellformed: "uwellformed G \<Longrightarrow> V \<subseteq> uverts G \<Longrightarrow> uwellformed (induced_subgraph V G)"
unfolding uwellformed_def induced_subgraph_def all_edges_def
by force

lemma subgraph_union_induced:
  assumes "uverts H\<^sub>1 \<subseteq> S" and "uverts H\<^sub>2 \<subseteq> T"
  assumes "uwellformed H\<^sub>1" and "uwellformed H\<^sub>2"
  shows "subgraph H\<^sub>1 (induced_subgraph S G) \<and> subgraph H\<^sub>2 (induced_subgraph T G) \<longleftrightarrow>
         subgraph (uverts H\<^sub>1 \<union> uverts H\<^sub>2, uedges H\<^sub>1 \<union> uedges H\<^sub>2) (induced_subgraph (S \<union> T) G)"
unfolding induced_subgraph_def subgraph_def
apply auto
using all_edges_mono apply blast
using all_edges_mono apply blast
using assms(1,2) wellformed_all_edges[OF assms(3)] wellformed_all_edges[OF assms(4)] all_edges_mono[OF assms(1)] all_edges_mono[OF assms(2)]
apply auto
done

lemma (in edge_space) induced_subgraph_prob:
  assumes "uverts H \<subseteq> V" and "uwellformed H" and "V \<subseteq> S_verts"
  shows "prob {es \<in> space P. subgraph H (induced_subgraph V (edge_ugraph es))} = p ^ card (uedges H)" (is "prob ?A = _")
proof -
  have "prob ?A = prob (cylinder S_edges (uedges H) {})"
    unfolding cylinder_def space_eq subgraph_def induced_subgraph_def edge_ugraph_def S_edges_def
    by (rule arg_cong[OF Collect_cong]) (metis (no_types) assms(1,2) Pow_iff all_edges_mono fst_conv inf_absorb1 inf_bot_left le_inf_iff snd_conv wellformed_all_edges)
  also have "\<dots> = p ^ card (uedges H)"
    proof (rule cylinder_empty_prob)
      have "uedges H \<subseteq> all_edges (uverts H)"
        by (rule wellformed_all_edges[OF assms(2)])
      also have "all_edges (uverts H) \<subseteq> all_edges S_verts"
        using assms by (auto simp: all_edges_mono[OF subset_trans])
      finally show "uedges H \<subseteq> S_edges"
        unfolding S_edges_def .
    qed
  finally show ?thesis
    .
qed

subsection{* Graph isomorphism *}

text{* We define graph isomorphism slightly different than in the literature. The usual definition
is that two graphs are isomorphic iff there exists a bijection between the vertex sets which
preserves the adjacency. However, this complicates many proofs.

Instead, we define the intuitive mapping operation on graphs. An isomorphism between two graphs
arises if there is a suitable mapping function from the first to the second graph. Later, we show
that this operation can be inverted. *}

fun map_ugraph :: "(nat \<Rightarrow> nat) \<Rightarrow> ugraph \<Rightarrow> ugraph" where
"map_ugraph f (V, E) = (f ` V, (\<lambda>e. f ` e) ` E)"

definition isomorphism :: "ugraph \<Rightarrow> ugraph \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" where
"isomorphism G\<^sub>1 G\<^sub>2 f \<equiv> bij_betw f (uverts G\<^sub>1) (uverts G\<^sub>2) \<and> G\<^sub>2 = map_ugraph f G\<^sub>1"

abbreviation isomorphic :: "ugraph \<Rightarrow> ugraph \<Rightarrow> bool" ("_ \<simeq> _") where
"G\<^sub>1 \<simeq> G\<^sub>2 \<equiv> uwellformed G\<^sub>1 \<and> uwellformed G\<^sub>2 \<and> (\<exists>f. isomorphism G\<^sub>1 G\<^sub>2 f)"

lemma map_ugraph_id: "map_ugraph id = id"
unfolding fun_eq_iff
by simp

lemma map_ugraph_trans: "map_ugraph (g \<circ> f) = (map_ugraph g) \<circ> (map_ugraph f)"
unfolding fun_eq_iff
by auto (metis imageI image_comp)+

lemma map_ugraph_wellformed:
  assumes "uwellformed G" and "inj_on f (uverts G)"
  shows "uwellformed (map_ugraph f G)"
unfolding uwellformed_def
proof safe
  fix e'
  assume "e' \<in> uedges (map_ugraph f G)"
  hence "e' \<in> (\<lambda>e. f ` e) ` (uedges G)"
    by (metis map_ugraph.simps snd_conv surjective_pairing)
  then obtain e where e: "e' = f ` e" "e \<in> uedges G"
    by blast
  hence "card e = 2" "e \<subseteq> uverts G"
    using assms(1) unfolding uwellformed_def by blast+
  thus "card e' = 2"
    using e(1) by (simp add: card_inj_subs[OF assms(2)])

  fix u'
  assume "u' \<in> e'"
  hence "u' \<in> f ` e"
    using e by force
  then obtain u where u: "u' = f u" "u \<in> e"
    by blast
  hence "u \<in> uverts G"
    using assms(1) e(2) unfolding uwellformed_def by blast
  hence "u' \<in> f ` uverts G"
    using u(1) by simp
  thus "u' \<in> uverts (map_ugraph f G)"
    by (metis map_ugraph.simps fst_conv surjective_pairing)
qed

lemma map_ugraph_finite: "finite_graph G \<Longrightarrow> finite_graph (map_ugraph f G)"
unfolding finite_graph_def
by (metis finite_imageI fst_conv map_ugraph.simps snd_conv surjective_pairing)

lemma map_ugraph_preserves_sub:
  assumes "subgraph G\<^sub>1 G\<^sub>2"
  shows "subgraph (map_ugraph f G\<^sub>1) (map_ugraph f G\<^sub>2)"
proof -
  have "f ` uverts G\<^sub>1 \<subseteq> f ` uverts G\<^sub>2" "(\<lambda>e. f ` e) ` uedges G\<^sub>1 \<subseteq> (\<lambda>e. f ` e) ` uedges G\<^sub>2"
    using assms(1) unfolding subgraph_def by auto
  thus ?thesis
    unfolding subgraph_def by (metis map_ugraph.simps fst_conv snd_conv surjective_pairing)
qed

lemma isomorphic_refl: "uwellformed G \<Longrightarrow> G \<simeq> G"
unfolding isomorphism_def
by (metis bij_betw_id id_def map_ugraph_id)

lemma isomorphic_trans:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2" and "G\<^sub>2 \<simeq> G\<^sub>3"
  shows "G\<^sub>1 \<simeq> G\<^sub>3"
proof -
  from assms obtain f\<^sub>1 f\<^sub>2 where
    bij: "bij_betw f\<^sub>1 (uverts G\<^sub>1) (uverts G\<^sub>2)" "bij_betw f\<^sub>2 (uverts G\<^sub>2) (uverts G\<^sub>3)" and
    map: "G\<^sub>2 = map_ugraph f\<^sub>1 G\<^sub>1" "G\<^sub>3 = map_ugraph f\<^sub>2 G\<^sub>2"
    unfolding isomorphism_def by blast

  let ?f = "f\<^sub>2 \<circ> f\<^sub>1"
  have "bij_betw ?f (uverts G\<^sub>1) (uverts G\<^sub>3)"
    using bij by (simp add: bij_betw_comp_iff)
  moreover have "G\<^sub>3 = map_ugraph ?f G\<^sub>1"
    using map by (simp add: map_ugraph_trans)
  moreover have "uwellformed G\<^sub>1" "uwellformed G\<^sub>3"
    using assms unfolding isomorphism_def by simp+
  ultimately show "G\<^sub>1 \<simeq> G\<^sub>3"
    unfolding isomorphism_def by blast
qed

lemma isomorphic_sym:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2"
  shows "G\<^sub>2 \<simeq> G\<^sub>1"
proof safe
  from assms obtain f where "isomorphism G\<^sub>1 G\<^sub>2 f"
    by blast
  hence bij: "bij_betw f (uverts G\<^sub>1) (uverts G\<^sub>2)" and map: "G\<^sub>2 = map_ugraph f G\<^sub>1"
    unfolding isomorphism_def by auto

  let ?f' = "inv_into (uverts G\<^sub>1) f"
  have bij': "bij_betw ?f' (uverts G\<^sub>2) (uverts G\<^sub>1)"
    by (rule bij_betw_inv_into) fact
  moreover have "uverts G\<^sub>1 = ?f' ` uverts G\<^sub>2"
    using bij' unfolding bij_betw_def by force
  moreover have "uedges G\<^sub>1 = (\<lambda>e. ?f' ` e) ` uedges G\<^sub>2"
    proof -
      have "uedges G\<^sub>1 = id ` uedges G\<^sub>1"
        by simp
      also have "\<dots> = (\<lambda>e. ?f' ` (f ` e)) ` uedges G\<^sub>1"
        proof (rule image_cong)
          fix a
          assume "a \<in> uedges G\<^sub>1"
          hence "a \<subseteq> uverts G\<^sub>1"
            using assms unfolding isomorphism_def uwellformed_def by blast
          thus "id a = inv_into (uverts G\<^sub>1) f ` f ` a"
            by (metis (full_types) id_def bij bij_betw_imp_inj_on inv_into_image_cancel)
        qed simp
      also have "\<dots> = (\<lambda>e. ?f' ` e) ` ((\<lambda>e. f ` e) ` uedges G\<^sub>1)"
        by (rule image_image[symmetric])
      also have "\<dots> = (\<lambda>e. ?f' ` e) ` uedges G\<^sub>2"
        using bij map by (metis map_ugraph.simps pair_collapse snd_eqD)
      finally show ?thesis
        .
    qed
  ultimately have "isomorphism G\<^sub>2 G\<^sub>1 ?f'"
    unfolding isomorphism_def by (metis map_ugraph.simps split_pairs)
  thus "\<exists>f. isomorphism G\<^sub>2 G\<^sub>1 f"
    by blast
qed (auto simp: assms)

lemma isomorphic_cards:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2"
  shows
    "card (uverts G\<^sub>1) = card (uverts G\<^sub>2)" (is "?V")
    "card (uedges G\<^sub>1) = card (uedges G\<^sub>2)" (is "?E")
proof -
  from assms obtain f where
    bij: "bij_betw f (uverts G\<^sub>1) (uverts G\<^sub>2)" and
    map: "G\<^sub>2 = map_ugraph f G\<^sub>1"
    unfolding isomorphism_def by blast
  from assms have wellformed: "uwellformed G\<^sub>1" "uwellformed G\<^sub>2"
    by simp+

  show ?V
    by (rule bij_betw_same_card[OF bij])

  let ?g = "\<lambda>e. f ` e"
  have "bij_betw ?g (Pow (uverts G\<^sub>1)) (Pow (uverts G\<^sub>2))"
    by (rule bij_lift[OF bij])
  moreover have "uedges G\<^sub>1 \<subseteq> Pow (uverts G\<^sub>1)"
    using wellformed(1) unfolding uwellformed_def by blast
  ultimately have "card (?g ` uedges G\<^sub>1) = card (uedges G\<^sub>1)"
    unfolding bij_betw_def by (metis card_inj_subs)
  thus ?E
    by (metis map map_ugraph.simps snd_conv surjective_pairing)
qed

subsection{* Isomorphic subgraphs *}

text{* The somewhat sloppy term `isomorphic subgraph' denotes a subgraph which is isomorphic to a
fixed other graph. For example, saying that a graph contains a triangle usually means that it
contains \emph{any} triangle, not the specific triangle with the nodes $1$, $2$ and $3$. Hence, such
a graph would have a triangle as an isomorphic subgraph. *}

definition subgraph_isomorphic :: "ugraph \<Rightarrow> ugraph \<Rightarrow> bool" ("_ \<sqsubseteq> _") where
"G' \<sqsubseteq> G \<equiv> uwellformed G \<and> (\<exists>G''. G' \<simeq> G'' \<and> subgraph G'' G)"

lemma subgraph_is_subgraph_isomorphic: "\<lbrakk> uwellformed G'; uwellformed G; subgraph G' G \<rbrakk> \<Longrightarrow> G' \<sqsubseteq> G"
unfolding subgraph_isomorphic_def
by (metis isomorphic_refl)

lemma isomorphic_is_subgraph_isomorphic: "G\<^sub>1 \<simeq> G\<^sub>2 \<Longrightarrow> G\<^sub>1 \<sqsubseteq> G\<^sub>2"
unfolding subgraph_isomorphic_def
by (metis subgraph_refl)

lemma subgraph_isomorphic_refl: "uwellformed G \<Longrightarrow> G \<sqsubseteq> G"
unfolding subgraph_isomorphic_def
by (metis isomorphic_refl subgraph_refl)

lemma subgraph_isomorphic_pre_iso_closed:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2" and "G\<^sub>2 \<sqsubseteq> G\<^sub>3"
  shows "G\<^sub>1 \<sqsubseteq> G\<^sub>3"
unfolding subgraph_isomorphic_def
proof
  show "uwellformed G\<^sub>3"
    using assms unfolding subgraph_isomorphic_def by blast
next
  from assms(2) obtain G\<^sub>2' where "G\<^sub>2 \<simeq> G\<^sub>2'" "subgraph G\<^sub>2' G\<^sub>3"
    unfolding subgraph_isomorphic_def by blast
  moreover with assms(1) have "G\<^sub>1 \<simeq> G\<^sub>2'"
    by (metis isomorphic_trans)
  ultimately show "\<exists>G''. G\<^sub>1 \<simeq> G'' \<and> subgraph G'' G\<^sub>3"
    by blast
qed

lemma subgraph_isomorphic_pre_subgraph_closed:
  assumes "uwellformed G\<^sub>1" and "subgraph G\<^sub>1 G\<^sub>2" and "G\<^sub>2 \<sqsubseteq> G\<^sub>3"
  shows "G\<^sub>1 \<sqsubseteq> G\<^sub>3"
unfolding subgraph_isomorphic_def
proof
  show "uwellformed G\<^sub>3"
    using assms unfolding subgraph_isomorphic_def by blast
next
  from assms(3) obtain G\<^sub>2' where "G\<^sub>2 \<simeq> G\<^sub>2'" "subgraph G\<^sub>2' G\<^sub>3"
    unfolding subgraph_isomorphic_def by blast
  then obtain f where bij: "bij_betw f (uverts G\<^sub>2) (uverts G\<^sub>2')" "G\<^sub>2' = map_ugraph f G\<^sub>2"
    unfolding isomorphism_def by blast
  let ?G\<^sub>1' = "map_ugraph f G\<^sub>1"

  have "bij_betw f (uverts G\<^sub>1) (f ` uverts G\<^sub>1)"
    using bij(1) assms(2) unfolding subgraph_def by (auto intro: bij_betw_subset)
  moreover hence "uwellformed ?G\<^sub>1'"
    using map_ugraph_wellformed[OF assms(1)] unfolding bij_betw_def ..
  ultimately have "G\<^sub>1 \<simeq> ?G\<^sub>1'"
    using assms(1) unfolding isomorphism_def by (metis map_ugraph.simps fst_conv surjective_pairing)
  moreover have "subgraph ?G\<^sub>1' G\<^sub>3" (* Yes, I will TOTALLY understand that step tomorrow. *)
    using subgraph_trans[OF map_ugraph_preserves_sub[OF assms(2)]] bij(2) `subgraph G\<^sub>2' G\<^sub>3` by simp
  ultimately show "\<exists>G''. G\<^sub>1 \<simeq> G'' \<and> subgraph G'' G\<^sub>3"
    by blast
qed

lemmas subgraph_isomorphic_pre_closed = subgraph_isomorphic_pre_subgraph_closed subgraph_isomorphic_pre_iso_closed

lemmas subgraph_isomorphic_post_closed = subgraph_isomorphic_post_iso_closed

lemmas subgraph_isomorphic_closed = subgraph_isomorphic_pre_closed subgraph_isomorphic_post_closed

subsection{* Density *}

text{* The density of a graph is the quotient of the number of edges and the number of vertices of
a graph. *}

definition density :: "ugraph \<Rightarrow> real" where
"density G = card (uedges G) / card (uverts G)"

text{* The maximum density of a graph is the density of its densest nonempty subgraph. *}

definition max_density :: "ugraph \<Rightarrow> real" where
"max_density G = Lattices_Big.Max (density ` nonempty_subgraphs G)"

text{* We prove some obvious results about the maximum density, such as that there is a subgraph
which has the maximum density and that the (maximum) density is preserved by isomorphisms. The
proofs are a bit complicated by the fact that most facts about @{term Lattices_Big.Max} require
non-emptiness of the target set, but we need that anyway to get a value out of it. *}

lemma max_density_is_max:
  assumes "finite_graph G" and "finite_graph G'" and "nonempty_graph G'" and "uwellformed G'" and "subgraph G' G"
  shows "density G' \<le> max_density G"
unfolding max_density_def
proof (rule Max_ge)
  show "finite (density ` nonempty_subgraphs G)"
    using assms(1) by (simp add: nonempty_subgraphs_finite)
next
  show "density G' \<in> density ` nonempty_subgraphs G"
    unfolding nonempty_subgraphs_def using assms by blast
qed

lemma max_density_gr_zero:
  assumes "finite_graph G" and "nonempty_graph G" and "uwellformed G"
  shows "0 < max_density G"
proof -
  have "0 < card (uverts G)" "0 < card (uedges G)"
    using assms unfolding finite_graph_def nonempty_graph_def by auto
  hence "0 < density G"
    unfolding density_def by simp
  also have "density G \<le> max_density G"
    using assms by (simp add: max_density_is_max subgraph_refl)
  finally show ?thesis
    .
qed

lemma isomorphic_density:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2"
  shows "density G\<^sub>1 = density G\<^sub>2"
unfolding density_def
using isomorphic_cards[OF assms]
by simp

lemma isomorphic_max_density:
  assumes "G\<^sub>1 \<simeq> G\<^sub>2" and "nonempty_graph G\<^sub>1" and "nonempty_graph G\<^sub>2" and "finite_graph G\<^sub>1" and "finite_graph G\<^sub>2"
  shows "max_density G\<^sub>1 = max_density G\<^sub>2"
proof -
  --{* The proof strategy is not completely straightforward. We first show that if two graphs are
       isomorphic, the maximum density of one graph is less or equal than the maximum density of
       the other graph. The reason is that this proof is quite long and the desired result directly
       follows from the symmetry of the isomorphism relation.\footnote{Some famous mathematician
       once said that if you prove that $a \le b$ and $b \le a$, you know \emph{that} these
       numbers are equal, but not \emph{why}. Since many proofs in this work are mostly opaque to
       me, I can live with that.} *}
  {
    fix A B
    assume A: "nonempty_graph A" "finite_graph A"
    assume iso: "A \<simeq> B"

    then obtain f where f: "B = map_ugraph f A" "bij_betw f (uverts A) (uverts B)"
      unfolding isomorphism_def by blast
    have wellformed: "uwellformed A"
      using iso unfolding isomorphism_def by simp
    --{* We observe that the set of densities of the subgraphs does not change if we map the
         subgraphs first. *}
    have "density ` nonempty_subgraphs A = density ` (map_ugraph f ` nonempty_subgraphs A)"
      proof (rule image_comp_cong)
        fix G
        assume "G \<in> nonempty_subgraphs A"
        hence "uverts G \<subseteq> uverts A" "uwellformed G"
          unfolding nonempty_subgraphs_def subgraph_def by simp+
        hence "inj_on f (uverts G)"
          using f(2) unfolding bij_betw_def by (metis subset_inj_on)
        hence "G \<simeq> map_ugraph f G"
          unfolding isomorphism_def bij_betw_def
          by (metis map_ugraph.simps fst_conv surjective_pairing map_ugraph_wellformed `uwellformed G`)
        thus "density G = density (map_ugraph f G)"
          by (fact isomorphic_density)
      qed
    --{* Additionally, we show that the operations @{term nonempty_subgraphs} and @{term map_ugraph}
         can be swapped without changing the densities. This is an obvious result, because
         @{term map_ugraph} does not change the structure of a graph. Still, the proof is a bit
         hairy, which is why we only show inclusion in one direction and use symmetry of isomorphism
         later. *}
    also have "\<dots> \<subseteq> density ` nonempty_subgraphs (map_ugraph f A)"
      proof (rule image_mono, rule subsetI)
        fix G''
        assume "G'' \<in> map_ugraph f ` nonempty_subgraphs A"
        then obtain G' where G_subst: "G'' = map_ugraph f G'" "G' \<in> nonempty_subgraphs A"
          by blast
        hence G': "subgraph G' A" "nonempty_graph G'" "uwellformed G'"
          unfolding nonempty_subgraphs_def by auto
        hence "inj_on f (uverts G')"
          using f unfolding bij_betw_def subgraph_def by (metis subset_inj_on)
        hence "uwellformed G''"
          using map_ugraph_wellformed G' G_subst by simp
        moreover have "nonempty_graph G''"
          using G' G_subst unfolding nonempty_graph_def by (metis map_ugraph.simps fst_conv snd_conv surjective_pairing empty_is_image)
        moreover have "subgraph G'' (map_ugraph f A)"
          using map_ugraph_preserves_sub G' G_subst by simp
        ultimately show "G'' \<in> nonempty_subgraphs (map_ugraph f A)"
          unfolding nonempty_subgraphs_def by simp
      qed
    finally have "density ` nonempty_subgraphs A \<subseteq> density ` nonempty_subgraphs (map_ugraph f A)"
      .
    hence "max_density A \<le> max_density (map_ugraph f A)"
      unfolding max_density_def
      proof (rule Max_mono)
        have "A \<in> nonempty_subgraphs A"
          using A iso unfolding nonempty_subgraphs_def by (simp add: subgraph_refl)
        thus "density ` nonempty_subgraphs A \<noteq> {}"
          by blast
      next
        have "finite (nonempty_subgraphs (map_ugraph f A))"
          by (rule nonempty_subgraphs_finite[OF map_ugraph_finite[OF A(2)]])
        thus "finite (density ` nonempty_subgraphs (map_ugraph f A))"
          by blast
      qed
    hence "max_density A \<le> max_density B"
      by (subst f)
  }
  note le = this

  show ?thesis
    using le[OF assms(2) assms(4) assms(1)] le[OF assms(3) assms(5) isomorphic_sym[OF assms(1)]]
    by (fact antisym)
qed

subsection{* Fixed selectors *}

text{* \label{sec:selector}
In the proof of the main theorem in the lecture notes, the concept of a ``fixed copy'' of a graph is
fundamental.

Let $H$ be a fixed graph. A `fixed selector' is basically a function mapping a set with the same
size as the vertex set of $H$ to a new graph which is isomorphic to $H$ and its vertex set is the
same as the input set.\footnote{We call such a selector \emph{fixed} because its result is
deterministic.} *}

definition "is_fixed_selector H f = (\<forall>V. finite V \<and> card (uverts H) = card V \<longrightarrow> H \<simeq> f V \<and> uverts (f V) = V)"

text{* Obviously, there may be many possible fixed selectors for a given graph. First, we show
that there is always at least one. This is sufficient, because we can always obtain that one and
use its properties without knowing exactly which one we chose. *}

lemma ex_fixed_selector:
  assumes "uwellformed H" and "finite_graph H"
  obtains f where "is_fixed_selector H f"
proof
  --{* I guess this is the only place in the whole work where we make use of a nifty little HOL
       feature called \emph{SOME}, which is basically Hilbert's choice operator. The reason is that
       any bijection between the the vertex set of @{term H} and the input set gives rise to a
       fixed selector function. In the lecture notes, a specific bijection was defined, but this
       is shorter and more elegant. *}
  let ?bij = "\<lambda>V. SOME g. bij_betw g (uverts H) V"
  let ?f = "\<lambda>V. map_ugraph (?bij V) H"
  {
    fix V :: "uvert set"
    assume "finite V" "card (uverts H) = card V"
    moreover have "finite (uverts H)"
      using assms unfolding finite_graph_def by simp
    ultimately have "bij_betw (?bij V) (uverts H) V"
      by (metis finite_same_card_bij someI_ex)
    moreover hence *: "uverts (?f V) = V \<and> uwellformed (?f V)"
      using map_ugraph_wellformed[OF assms(1)]
      by (metis bij_betw_def map_ugraph.simps fst_conv surjective_pairing)
    ultimately have **: "H \<simeq> ?f V"
      unfolding isomorphism_def using assms(1) by auto
    note * **
  }
  thus "is_fixed_selector H ?f"
    unfolding is_fixed_selector_def by blast
qed

lemma fixed_selector_induced_subgraph:
  assumes "is_fixed_selector H f" and "card (uverts H) = card V" and "finite V"
  assumes sub: "subgraph (f V) (induced_subgraph V G)" and V: "V \<subseteq> uverts G" and G: "uwellformed G"
  shows "H \<sqsubseteq> G"
proof -
  have post: "H \<simeq> f V" "uverts (f V) = V"
    using assms unfolding is_fixed_selector_def by auto

  have "H \<sqsubseteq> f V"
    by (rule isomorphic_is_subgraph_isomorphic)
       (simp add: post)
  also have "f V \<sqsubseteq> induced_subgraph V G"
    by (rule subgraph_is_subgraph_isomorphic)
       (auto simp: induced_wellformed[OF G V] post sub)
  also have "\<dots> \<sqsubseteq> G"
    by (rule subgraph_is_subgraph_isomorphic[OF induced_wellformed])
       (auto simp: G V induced_is_subgraph(1)[OF V])
  finally show "H \<sqsubseteq> G"
    .
qed

end


(*  Title:      HOL/Algebra/Lattice.thy
    Author:     Clemens Ballarin, started 7 November 2003
    Copyright:  Clemens Ballarin

Most congruence rules by Stephan Hohe.
With additional contributions from Alasdair Armstrong and Simon Foster.
*)

theory Lattice
imports Order
begin

section \<open>Lattices\<close>

subsection \<open>Supremum and infimum\<close>

definition
  sup :: "[_, 'a set] => 'a" ("\<Squnion>\<index>_" [90] 90)
  where "\<Squnion>\<^bsub>L\<^esub>A = (SOME x. least L x (Upper L A))"

definition
  inf :: "[_, 'a set] => 'a" ("\<Sqinter>\<index>_" [90] 90)
  where "\<Sqinter>\<^bsub>L\<^esub>A = (SOME x. greatest L x (Lower L A))"

definition supr ::
  "('a, 'b) gorder_scheme \<Rightarrow> 'c set \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> 'a "
  where "supr L A f = \<Squnion>\<^bsub>L\<^esub>(f ` A)"

definition infi ::
  "('a, 'b) gorder_scheme \<Rightarrow> 'c set \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> 'a "
  where "infi L A f = \<Sqinter>\<^bsub>L\<^esub>(f ` A)"

syntax
  "_inf1"     :: "('a, 'b) gorder_scheme \<Rightarrow> pttrns \<Rightarrow> 'a \<Rightarrow> 'a" ("(3IINF\<index> _./ _)" [0, 10] 10)
  "_inf"      :: "('a, 'b) gorder_scheme \<Rightarrow> pttrn \<Rightarrow> 'c set \<Rightarrow> 'a \<Rightarrow> 'a"  ("(3IINF\<index> _:_./ _)" [0, 0, 10] 10)
  "_sup1"     :: "('a, 'b) gorder_scheme \<Rightarrow> pttrns \<Rightarrow> 'a \<Rightarrow> 'a" ("(3SSUP\<index> _./ _)" [0, 10] 10)
  "_sup"      :: "('a, 'b) gorder_scheme \<Rightarrow> pttrn \<Rightarrow> 'c set \<Rightarrow> 'a \<Rightarrow> 'a"  ("(3SSUP\<index> _:_./ _)" [0, 0, 10] 10)

translations
  "IINF\<^bsub>L\<^esub> x. B"     == "CONST infi L CONST UNIV (%x. B)"
  "IINF\<^bsub>L\<^esub> x:A. B"   == "CONST infi L A (%x. B)"
  "SSUP\<^bsub>L\<^esub> x. B"     == "CONST supr L CONST UNIV (%x. B)"
  "SSUP\<^bsub>L\<^esub> x:A. B"   == "CONST supr L A (%x. B)"

definition
  join :: "[_, 'a, 'a] => 'a" (infixl "\<squnion>\<index>" 65)
  where "x \<squnion>\<^bsub>L\<^esub> y = \<Squnion>\<^bsub>L\<^esub>{x, y}"

definition
  meet :: "[_, 'a, 'a] => 'a" (infixl "\<sqinter>\<index>" 70)
  where "x \<sqinter>\<^bsub>L\<^esub> y = \<Sqinter>\<^bsub>L\<^esub>{x, y}"

definition
  LEAST_FP :: "('a, 'b) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("LFP\<index>") where
  "LEAST_FP L f = \<Sqinter>\<^bsub>L\<^esub> {u \<in> carrier L. f u \<sqsubseteq>\<^bsub>L\<^esub> u}"    \<comment> \<open>least fixed point\<close>

definition
  GREATEST_FP:: "('a, 'b) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("GFP\<index>") where
  "GREATEST_FP L f = \<Squnion>\<^bsub>L\<^esub> {u \<in> carrier L. u \<sqsubseteq>\<^bsub>L\<^esub> f u}"    \<comment> \<open>greatest fixed point\<close>

subsection \<open>Dual operators\<close>

lemma sup_dual [simp]:
  "\<Squnion>\<^bsub>inv_gorder L\<^esub>A = \<Sqinter>\<^bsub>L\<^esub>A"
  by (simp add: sup_def inf_def)

lemma inf_dual [simp]:
  "\<Sqinter>\<^bsub>inv_gorder L\<^esub>A = \<Squnion>\<^bsub>L\<^esub>A"
  by (simp add: sup_def inf_def)

lemma join_dual [simp]:
  "p \<squnion>\<^bsub>inv_gorder L\<^esub> q = p \<sqinter>\<^bsub>L\<^esub> q"
  by (simp add:join_def meet_def)

lemma meet_dual [simp]:
  "p \<sqinter>\<^bsub>inv_gorder L\<^esub> q = p \<squnion>\<^bsub>L\<^esub> q"
  by (simp add:join_def meet_def)

lemma top_dual [simp]:
  "\<top>\<^bsub>inv_gorder L\<^esub> = \<bottom>\<^bsub>L\<^esub>"
  by (simp add: top_def bottom_def)

lemma bottom_dual [simp]:
  "\<bottom>\<^bsub>inv_gorder L\<^esub> = \<top>\<^bsub>L\<^esub>"
  by (simp add: top_def bottom_def)

lemma LFP_dual [simp]:
  "LEAST_FP (inv_gorder L) f = GREATEST_FP L f"
  by (simp add:LEAST_FP_def GREATEST_FP_def)

lemma GFP_dual [simp]:
  "GREATEST_FP (inv_gorder L) f = LEAST_FP L f"
  by (simp add:LEAST_FP_def GREATEST_FP_def)

subsection \<open>Lattices\<close>

locale weak_upper_semilattice = weak_partial_order +
  assumes sup_of_two_exists:
    "[| x \<in> carrier L; y \<in> carrier L |] ==> \<exists>s. least L s (Upper L {x, y})"

locale weak_lower_semilattice = weak_partial_order +
  assumes inf_of_two_exists:
    "[| x \<in> carrier L; y \<in> carrier L |] ==> \<exists>s. greatest L s (Lower L {x, y})"

locale weak_lattice = weak_upper_semilattice + weak_lower_semilattice

lemma (in weak_lattice) dual_weak_lattice:
  "weak_lattice (inv_gorder L)"
proof -
  interpret dual: weak_partial_order "inv_gorder L"
    by (metis dual_weak_order)
  show ?thesis
  proof qed (simp_all add: inf_of_two_exists sup_of_two_exists)
qed

subsubsection \<open>Supremum\<close>

lemma (in weak_upper_semilattice) joinI:
  "[| !!l. least L l (Upper L {x, y}) ==> P l; x \<in> carrier L; y \<in> carrier L |]
  ==> P (x \<squnion> y)"
proof (unfold join_def sup_def)
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
    and P: "!!l. least L l (Upper L {x, y}) ==> P l"
  with sup_of_two_exists obtain s where "least L s (Upper L {x, y})" by fast
  with L show "P (SOME l. least L l (Upper L {x, y}))"
    by (fast intro: someI2 P)
qed

lemma (in weak_upper_semilattice) join_closed [simp]:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<squnion> y \<in> carrier L"
  by (rule joinI) (rule least_closed)

lemma (in weak_upper_semilattice) join_cong_l:
  assumes carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
    and xx': "x .= x'"
  shows "x \<squnion> y .= x' \<squnion> y"
proof (rule joinI, rule joinI)
  fix a b
  from xx' carr
      have seq: "{x, y} {.=} {x', y}" by (rule set_eq_pairI)

  assume leasta: "least L a (Upper L {x, y})"
  assume "least L b (Upper L {x', y})"
  with carr
      have leastb: "least L b (Upper L {x, y})"
      by (simp add: least_Upper_cong_r[OF _ _ seq])

  from leasta leastb
      show "a .= b" by (rule weak_least_unique)
qed (rule carr)+

lemma (in weak_upper_semilattice) join_cong_r:
  assumes carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
    and yy': "y .= y'"
  shows "x \<squnion> y .= x \<squnion> y'"
proof (rule joinI, rule joinI)
  fix a b
  have "{x, y} = {y, x}" by fast
  also from carr yy'
      have "{y, x} {.=} {y', x}" by (intro set_eq_pairI)
  also have "{y', x} = {x, y'}" by fast
  finally
      have seq: "{x, y} {.=} {x, y'}" .

  assume leasta: "least L a (Upper L {x, y})"
  assume "least L b (Upper L {x, y'})"
  with carr
      have leastb: "least L b (Upper L {x, y})"
      by (simp add: least_Upper_cong_r[OF _ _ seq])

  from leasta leastb
      show "a .= b" by (rule weak_least_unique)
qed (rule carr)+

lemma (in weak_partial_order) sup_of_singletonI:      (* only reflexivity needed ? *)
  "x \<in> carrier L ==> least L x (Upper L {x})"
  by (rule least_UpperI) auto

lemma (in weak_partial_order) weak_sup_of_singleton [simp]:
  "x \<in> carrier L ==> \<Squnion>{x} .= x"
  unfolding sup_def
  by (rule someI2) (auto intro: weak_least_unique sup_of_singletonI)

lemma (in weak_partial_order) sup_of_singleton_closed [simp]:
  "x \<in> carrier L \<Longrightarrow> \<Squnion>{x} \<in> carrier L"
  unfolding sup_def
  by (rule someI2) (auto intro: sup_of_singletonI)

text \<open>Condition on \<open>A\<close>: supremum exists.\<close>

lemma (in weak_upper_semilattice) sup_insertI:
  "[| !!s. least L s (Upper L (insert x A)) ==> P s;
  least L a (Upper L A); x \<in> carrier L; A \<subseteq> carrier L |]
  ==> P (\<Squnion>(insert x A))"
proof (unfold sup_def)
  assume L: "x \<in> carrier L"  "A \<subseteq> carrier L"
    and P: "!!l. least L l (Upper L (insert x A)) ==> P l"
    and least_a: "least L a (Upper L A)"
  from L least_a have La: "a \<in> carrier L" by simp
  from L sup_of_two_exists least_a
  obtain s where least_s: "least L s (Upper L {a, x})" by blast
  show "P (SOME l. least L l (Upper L (insert x A)))"
  proof (rule someI2)
    show "least L s (Upper L (insert x A))"
    proof (rule least_UpperI)
      fix z
      assume "z \<in> insert x A"
      then show "z \<sqsubseteq> s"
      proof
        assume "z = x" then show ?thesis
          by (simp add: least_Upper_above [OF least_s] L La)
      next
        assume "z \<in> A"
        with L least_s least_a show ?thesis
          by (rule_tac le_trans [where y = a]) (auto dest: least_Upper_above)
      qed
    next
      fix y
      assume y: "y \<in> Upper L (insert x A)"
      show "s \<sqsubseteq> y"
      proof (rule least_le [OF least_s], rule Upper_memI)
        fix z
        assume z: "z \<in> {a, x}"
        then show "z \<sqsubseteq> y"
        proof
          have y': "y \<in> Upper L A"
            by (meson Upper_antimono in_mono subset_insertI y)
          assume "z = a"
          with y' least_a show ?thesis by (fast dest: least_le)
        next
          assume "z \<in> {x}"
          with y L show ?thesis by blast
        qed
      qed (rule Upper_closed [THEN subsetD, OF y])
    next
      from L show "insert x A \<subseteq> carrier L" by simp
      from least_s show "s \<in> carrier L" by simp
    qed
  qed (rule P)
qed

lemma (in weak_upper_semilattice) finite_sup_least:
  "[| finite A; A \<subseteq> carrier L; A \<noteq> {} |] ==> least L (\<Squnion>A) (Upper L A)"
proof (induct set: finite)
  case empty
  then show ?case by simp
next
  case (insert x A)
  show ?case
  proof (cases "A = {}")
    case True
    with insert show ?thesis
      by simp (simp add: least_cong [OF weak_sup_of_singleton] sup_of_singletonI)
        (* The above step is hairy; least_cong can make simp loop.
        Would want special version of simp to apply least_cong. *)
  next
    case False
    with insert have "least L (\<Squnion>A) (Upper L A)" by simp
    with _ show ?thesis
      by (rule sup_insertI) (simp_all add: insert [simplified])
  qed
qed

lemma (in weak_upper_semilattice) finite_sup_insertI:
  assumes P: "!!l. least L l (Upper L (insert x A)) ==> P l"
    and xA: "finite A"  "x \<in> carrier L"  "A \<subseteq> carrier L"
  shows "P (\<Squnion> (insert x A))"
proof (cases "A = {}")
  case True with P and xA show ?thesis
    by (simp add: finite_sup_least)
next
  case False with P and xA show ?thesis
    by (simp add: sup_insertI finite_sup_least)
qed

lemma (in weak_upper_semilattice) finite_sup_closed [simp]:
  "[| finite A; A \<subseteq> carrier L; A \<noteq> {} |] ==> \<Squnion>A \<in> carrier L"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case insert then show ?case
    by - (rule finite_sup_insertI, simp_all)
qed

lemma (in weak_upper_semilattice) join_left:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqsubseteq> x \<squnion> y"
  by (rule joinI [folded join_def]) (blast dest: least_mem)

lemma (in weak_upper_semilattice) join_right:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> y \<sqsubseteq> x \<squnion> y"
  by (rule joinI [folded join_def]) (blast dest: least_mem)

lemma (in weak_upper_semilattice) sup_of_two_least:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> least L (\<Squnion>{x, y}) (Upper L {x, y})"
proof (unfold sup_def)
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
  with sup_of_two_exists obtain s where "least L s (Upper L {x, y})" by fast
  with L show "least L (SOME z. least L z (Upper L {x, y})) (Upper L {x, y})"
  by (fast intro: someI2 weak_least_unique)  (* blast fails *)
qed

lemma (in weak_upper_semilattice) join_le:
  assumes sub: "x \<sqsubseteq> z"  "y \<sqsubseteq> z"
    and x: "x \<in> carrier L" and y: "y \<in> carrier L" and z: "z \<in> carrier L"
  shows "x \<squnion> y \<sqsubseteq> z"
proof (rule joinI [OF _ x y])
  fix s
  assume "least L s (Upper L {x, y})"
  with sub z show "s \<sqsubseteq> z" by (fast elim: least_le intro: Upper_memI)
qed

lemma (in weak_lattice) weak_le_iff_meet:
  assumes "x \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubseteq> y \<longleftrightarrow> (x \<squnion> y) .= y"
  by (meson assms(1) assms(2) join_closed join_le join_left join_right le_cong_r local.le_refl weak_le_antisym)

lemma (in weak_upper_semilattice) weak_join_assoc_lemma:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "x \<squnion> (y \<squnion> z) .= \<Squnion>{x, y, z}"
proof (rule finite_sup_insertI)
  \<comment> \<open>The textbook argument in Jacobson I, p 457\<close>
  fix s
  assume sup: "least L s (Upper L {x, y, z})"
  show "x \<squnion> (y \<squnion> z) .= s"
  proof (rule weak_le_antisym)
    from sup L show "x \<squnion> (y \<squnion> z) \<sqsubseteq> s"
      by (fastforce intro!: join_le elim: least_Upper_above)
  next
    from sup L show "s \<sqsubseteq> x \<squnion> (y \<squnion> z)"
    by (erule_tac least_le)
      (blast intro!: Upper_memI intro: le_trans join_left join_right join_closed)
  qed (simp_all add: L least_closed [OF sup])
qed (simp_all add: L)

text \<open>Commutativity holds for \<open>=\<close>.\<close>

lemma join_comm:
  fixes L (structure)
  shows "x \<squnion> y = y \<squnion> x"
  by (unfold join_def) (simp add: insert_commute)

lemma (in weak_upper_semilattice) weak_join_assoc:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "(x \<squnion> y) \<squnion> z .= x \<squnion> (y \<squnion> z)"
proof -
  (* FIXME: could be simplified by improved simp: uniform use of .=,
     omit [symmetric] in last step. *)
  have "(x \<squnion> y) \<squnion> z = z \<squnion> (x \<squnion> y)" by (simp only: join_comm)
  also from L have "... .= \<Squnion>{z, x, y}" by (simp add: weak_join_assoc_lemma)
  also from L have "... = \<Squnion>{x, y, z}" by (simp add: insert_commute)
  also from L have "... .= x \<squnion> (y \<squnion> z)" by (simp add: weak_join_assoc_lemma [symmetric])
  finally show ?thesis by (simp add: L)
qed

subsubsection \<open>Infimum\<close>

lemma (in weak_lower_semilattice) meetI:
  "[| !!i. greatest L i (Lower L {x, y}) ==> P i;
  x \<in> carrier L; y \<in> carrier L |]
  ==> P (x \<sqinter> y)"
proof (unfold meet_def inf_def)
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
    and P: "!!g. greatest L g (Lower L {x, y}) ==> P g"
  with inf_of_two_exists obtain i where "greatest L i (Lower L {x, y})" by fast
  with L show "P (SOME g. greatest L g (Lower L {x, y}))"
  by (fast intro: someI2 weak_greatest_unique P)
qed

lemma (in weak_lower_semilattice) meet_closed [simp]:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqinter> y \<in> carrier L"
  by (rule meetI) (rule greatest_closed)

lemma (in weak_lower_semilattice) meet_cong_l:
  assumes carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
    and xx': "x .= x'"
  shows "x \<sqinter> y .= x' \<sqinter> y"
proof (rule meetI, rule meetI)
  fix a b
  from xx' carr
      have seq: "{x, y} {.=} {x', y}" by (rule set_eq_pairI)

  assume greatesta: "greatest L a (Lower L {x, y})"
  assume "greatest L b (Lower L {x', y})"
  with carr
      have greatestb: "greatest L b (Lower L {x, y})"
      by (simp add: greatest_Lower_cong_r[OF _ _ seq])

  from greatesta greatestb
      show "a .= b" by (rule weak_greatest_unique)
qed (rule carr)+

lemma (in weak_lower_semilattice) meet_cong_r:
  assumes carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
    and yy': "y .= y'"
  shows "x \<sqinter> y .= x \<sqinter> y'"
proof (rule meetI, rule meetI)
  fix a b
  have "{x, y} = {y, x}" by fast
  also from carr yy'
      have "{y, x} {.=} {y', x}" by (intro set_eq_pairI)
  also have "{y', x} = {x, y'}" by fast
  finally
      have seq: "{x, y} {.=} {x, y'}" .

  assume greatesta: "greatest L a (Lower L {x, y})"
  assume "greatest L b (Lower L {x, y'})"
  with carr
      have greatestb: "greatest L b (Lower L {x, y})"
      by (simp add: greatest_Lower_cong_r[OF _ _ seq])

  from greatesta greatestb
      show "a .= b" by (rule weak_greatest_unique)
qed (rule carr)+

lemma (in weak_partial_order) inf_of_singletonI:      (* only reflexivity needed ? *)
  "x \<in> carrier L ==> greatest L x (Lower L {x})"
  by (rule greatest_LowerI) auto

lemma (in weak_partial_order) weak_inf_of_singleton [simp]:
  "x \<in> carrier L ==> \<Sqinter>{x} .= x"
  unfolding inf_def
  by (rule someI2) (auto intro: weak_greatest_unique inf_of_singletonI)

lemma (in weak_partial_order) inf_of_singleton_closed:
  "x \<in> carrier L ==> \<Sqinter>{x} \<in> carrier L"
  unfolding inf_def
  by (rule someI2) (auto intro: inf_of_singletonI)

text \<open>Condition on \<open>A\<close>: infimum exists.\<close>

lemma (in weak_lower_semilattice) inf_insertI:
  "[| !!i. greatest L i (Lower L (insert x A)) ==> P i;
  greatest L a (Lower L A); x \<in> carrier L; A \<subseteq> carrier L |]
  ==> P (\<Sqinter>(insert x A))"
proof (unfold inf_def)
  assume L: "x \<in> carrier L"  "A \<subseteq> carrier L"
    and P: "!!g. greatest L g (Lower L (insert x A)) ==> P g"
    and greatest_a: "greatest L a (Lower L A)"
  from L greatest_a have La: "a \<in> carrier L" by simp
  from L inf_of_two_exists greatest_a
  obtain i where greatest_i: "greatest L i (Lower L {a, x})" by blast
  show "P (SOME g. greatest L g (Lower L (insert x A)))"
  proof (rule someI2)
    show "greatest L i (Lower L (insert x A))"
    proof (rule greatest_LowerI)
      fix z
      assume "z \<in> insert x A"
      then show "i \<sqsubseteq> z"
      proof
        assume "z = x" then show ?thesis
          by (simp add: greatest_Lower_below [OF greatest_i] L La)
      next
        assume "z \<in> A"
        with L greatest_i greatest_a show ?thesis
          by (rule_tac le_trans [where y = a]) (auto dest: greatest_Lower_below)
      qed
    next
      fix y
      assume y: "y \<in> Lower L (insert x A)"
      show "y \<sqsubseteq> i"
      proof (rule greatest_le [OF greatest_i], rule Lower_memI)
        fix z
        assume z: "z \<in> {a, x}"
        then show "y \<sqsubseteq> z"
        proof
          have y': "y \<in> Lower L A"
            by (meson Lower_antimono in_mono subset_insertI y)
          assume "z = a"
          with y' greatest_a show ?thesis by (fast dest: greatest_le)
        next
          assume "z \<in> {x}"
          with y L show ?thesis by blast
        qed
      qed (rule Lower_closed [THEN subsetD, OF y])
    next
      from L show "insert x A \<subseteq> carrier L" by simp
      from greatest_i show "i \<in> carrier L" by simp
    qed
  qed (rule P)
qed

lemma (in weak_lower_semilattice) finite_inf_greatest:
  "[| finite A; A \<subseteq> carrier L; A \<noteq> {} |] ==> greatest L (\<Sqinter>A) (Lower L A)"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case (insert x A)
  show ?case
  proof (cases "A = {}")
    case True
    with insert show ?thesis
      by simp (simp add: greatest_cong [OF weak_inf_of_singleton]
        inf_of_singleton_closed inf_of_singletonI)
  next
    case False
    from insert show ?thesis
    proof (rule_tac inf_insertI)
      from False insert show "greatest L (\<Sqinter>A) (Lower L A)" by simp
    qed simp_all
  qed
qed

lemma (in weak_lower_semilattice) finite_inf_insertI:
  assumes P: "!!i. greatest L i (Lower L (insert x A)) ==> P i"
    and xA: "finite A"  "x \<in> carrier L"  "A \<subseteq> carrier L"
  shows "P (\<Sqinter> (insert x A))"
proof (cases "A = {}")
  case True with P and xA show ?thesis
    by (simp add: finite_inf_greatest)
next
  case False with P and xA show ?thesis
    by (simp add: inf_insertI finite_inf_greatest)
qed

lemma (in weak_lower_semilattice) finite_inf_closed [simp]:
  "[| finite A; A \<subseteq> carrier L; A \<noteq> {} |] ==> \<Sqinter>A \<in> carrier L"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case insert then show ?case
    by (rule_tac finite_inf_insertI) (simp_all)
qed

lemma (in weak_lower_semilattice) meet_left:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqinter> y \<sqsubseteq> x"
  by (rule meetI [folded meet_def]) (blast dest: greatest_mem)

lemma (in weak_lower_semilattice) meet_right:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqinter> y \<sqsubseteq> y"
  by (rule meetI [folded meet_def]) (blast dest: greatest_mem)

lemma (in weak_lower_semilattice) inf_of_two_greatest:
  "[| x \<in> carrier L; y \<in> carrier L |] ==>
  greatest L (\<Sqinter>{x, y}) (Lower L {x, y})"
proof (unfold inf_def)
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
  with inf_of_two_exists obtain s where "greatest L s (Lower L {x, y})" by fast
  with L
  show "greatest L (SOME z. greatest L z (Lower L {x, y})) (Lower L {x, y})"
  by (fast intro: someI2 weak_greatest_unique)  (* blast fails *)
qed

lemma (in weak_lower_semilattice) meet_le:
  assumes sub: "z \<sqsubseteq> x"  "z \<sqsubseteq> y"
    and x: "x \<in> carrier L" and y: "y \<in> carrier L" and z: "z \<in> carrier L"
  shows "z \<sqsubseteq> x \<sqinter> y"
proof (rule meetI [OF _ x y])
  fix i
  assume "greatest L i (Lower L {x, y})"
  with sub z show "z \<sqsubseteq> i" by (fast elim: greatest_le intro: Lower_memI)
qed

lemma (in weak_lattice) weak_le_iff_join:
  assumes "x \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubseteq> y \<longleftrightarrow> x .= (x \<sqinter> y)"
  by (meson assms(1) assms(2) local.le_refl local.le_trans meet_closed meet_le meet_left meet_right weak_le_antisym weak_refl)

lemma (in weak_lower_semilattice) weak_meet_assoc_lemma:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "x \<sqinter> (y \<sqinter> z) .= \<Sqinter>{x, y, z}"
proof (rule finite_inf_insertI)
  txt \<open>The textbook argument in Jacobson I, p 457\<close>
  fix i
  assume inf: "greatest L i (Lower L {x, y, z})"
  show "x \<sqinter> (y \<sqinter> z) .= i"
  proof (rule weak_le_antisym)
    from inf L show "i \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
      by (fastforce intro!: meet_le elim: greatest_Lower_below)
  next
    from inf L show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> i"
    by (erule_tac greatest_le)
      (blast intro!: Lower_memI intro: le_trans meet_left meet_right meet_closed)
  qed (simp_all add: L greatest_closed [OF inf])
qed (simp_all add: L)

lemma (in weak_lower_semilattice) weak_meet_assoc:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "(x \<sqinter> y) \<sqinter> z .= x \<sqinter> (y \<sqinter> z)"
proof -
  (* FIXME: improved simp, see weak_join_assoc above *)
  have "(x \<sqinter> y) \<sqinter> z = z \<sqinter> (x \<sqinter> y)" by (simp only: meet_comm)
  also from L have "... .= \<Sqinter> {z, x, y}" by (simp add: weak_meet_assoc_lemma)
  also from L have "... = \<Sqinter> {x, y, z}" by (simp add: insert_commute)
  also from L have "... .= x \<sqinter> (y \<sqinter> z)" by (simp add: weak_meet_assoc_lemma [symmetric])
  finally show ?thesis by (simp add: L)
qed

text \<open>Total orders are lattices.\<close>

sublocale weak_total_order \<subseteq> weak?: weak_lattice
proof
  fix x y
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
  show "\<exists>s. least L s (Upper L {x, y})"
  proof -
    note total L
    moreover
    {
      assume "x \<sqsubseteq> y"
      with L have "least L y (Upper L {x, y})"
        by (rule_tac least_UpperI) auto
    }
    moreover
    {
      assume "y \<sqsubseteq> x"
      with L have "least L x (Upper L {x, y})"
        by (rule_tac least_UpperI) auto
    }
    ultimately show ?thesis by blast
  qed
next
  fix x y
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
  show "\<exists>i. greatest L i (Lower L {x, y})"
  proof -
    note total L
    moreover
    {
      assume "y \<sqsubseteq> x"
      with L have "greatest L y (Lower L {x, y})"
        by (rule_tac greatest_LowerI) auto
    }
    moreover
    {
      assume "x \<sqsubseteq> y"
      with L have "greatest L x (Lower L {x, y})"
        by (rule_tac greatest_LowerI) auto
    }
    ultimately show ?thesis by blast
  qed
qed

subsection \<open>Weak Bounded Lattices\<close>

locale weak_bounded_lattice =
  weak_lattice +
  weak_partial_order_bottom +
  weak_partial_order_top
begin

lemma bottom_meet: "x \<in> carrier L \<Longrightarrow> \<bottom> \<sqinter> x .= \<bottom>"
  by (metis bottom_least least_def meet_closed meet_left weak_le_antisym)

lemma bottom_join: "x \<in> carrier L \<Longrightarrow> \<bottom> \<squnion> x .= x"
  by (metis bottom_least join_closed join_le join_right le_refl least_def weak_le_antisym)

lemma bottom_weak_eq:
  "\<lbrakk> b \<in> carrier L; \<And> x. x \<in> carrier L \<Longrightarrow> b \<sqsubseteq> x \<rbrakk> \<Longrightarrow> b .= \<bottom>"
  by (metis bottom_closed bottom_lower weak_le_antisym)

lemma top_join: "x \<in> carrier L \<Longrightarrow> \<top> \<squnion> x .= \<top>"
  by (metis join_closed join_left top_closed top_higher weak_le_antisym)

lemma top_meet: "x \<in> carrier L \<Longrightarrow> \<top> \<sqinter> x .= x"
  by (metis le_refl meet_closed meet_le meet_right top_closed top_higher weak_le_antisym)

lemma top_weak_eq:  "\<lbrakk> t \<in> carrier L; \<And> x. x \<in> carrier L \<Longrightarrow> x \<sqsubseteq> t \<rbrakk> \<Longrightarrow> t .= \<top>"
  by (metis top_closed top_higher weak_le_antisym)

end

sublocale weak_bounded_lattice \<subseteq> weak_partial_order ..

subsection \<open>Lattices where \<open>eq\<close> is the Equality\<close>

locale upper_semilattice = partial_order +
  assumes sup_of_two_exists:
    "[| x \<in> carrier L; y \<in> carrier L |] ==> \<exists>s. least L s (Upper L {x, y})"

sublocale upper_semilattice \<subseteq> weak?: weak_upper_semilattice
  by unfold_locales (rule sup_of_two_exists)

locale lower_semilattice = partial_order +
  assumes inf_of_two_exists:
    "[| x \<in> carrier L; y \<in> carrier L |] ==> \<exists>s. greatest L s (Lower L {x, y})"

sublocale lower_semilattice \<subseteq> weak?: weak_lower_semilattice
  by unfold_locales (rule inf_of_two_exists)

locale lattice = upper_semilattice + lower_semilattice

sublocale lattice \<subseteq> weak_lattice ..

lemma (in lattice) dual_lattice:
  "lattice (inv_gorder L)"
proof -
  interpret dual: weak_lattice "inv_gorder L"
    by (metis dual_weak_lattice)

  show ?thesis
    apply (unfold_locales)
    apply (simp_all add: inf_of_two_exists sup_of_two_exists)
    apply (rule eq_is_equal)
  done
qed

lemma (in lattice) le_iff_join:
  assumes "x \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubseteq> y \<longleftrightarrow> x = (x \<sqinter> y)"
  by (simp add: assms(1) assms(2) eq_is_equal weak_le_iff_join)

lemma (in lattice) le_iff_meet:
  assumes "x \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubseteq> y \<longleftrightarrow> (x \<squnion> y) = y"
  by (simp add: assms eq_is_equal weak_le_iff_meet)

text \<open> Total orders are lattices. \<close>

sublocale total_order \<subseteq> weak?: lattice
  by standard (auto intro: weak.weak.sup_of_two_exists weak.weak.inf_of_two_exists)

text \<open>Functions that preserve joins and meets\<close>

definition join_pres :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
"join_pres X Y f \<equiv> lattice X \<and> lattice Y \<and> (\<forall> x \<in> carrier X. \<forall> y \<in> carrier X. f (x \<squnion>\<^bsub>X\<^esub> y) = f x \<squnion>\<^bsub>Y\<^esub> f y)"

definition meet_pres :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
"meet_pres X Y f \<equiv> lattice X \<and> lattice Y \<and> (\<forall> x \<in> carrier X. \<forall> y \<in> carrier X. f (x \<sqinter>\<^bsub>X\<^esub> y) = f x \<sqinter>\<^bsub>Y\<^esub> f y)"

lemma join_pres_isotone:
  assumes "f \<in> carrier X \<rightarrow> carrier Y" "join_pres X Y f"
  shows "isotone X Y f"
proof (rule isotoneI)
  show "weak_partial_order X" "weak_partial_order Y"
    using assms unfolding join_pres_def lattice_def upper_semilattice_def lower_semilattice_def
    by (meson partial_order.axioms(1))+
  show "\<And>x y. \<lbrakk>x \<in> carrier X; y \<in> carrier X; x \<sqsubseteq>\<^bsub>X\<^esub> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq>\<^bsub>Y\<^esub> f y"
    by (metis (no_types, lifting) PiE assms join_pres_def lattice.le_iff_meet)
qed

lemma meet_pres_isotone:
  assumes "f \<in> carrier X \<rightarrow> carrier Y" "meet_pres X Y f"
  shows "isotone X Y f"
proof (rule isotoneI)
  show "weak_partial_order X" "weak_partial_order Y"
    using assms unfolding meet_pres_def lattice_def upper_semilattice_def lower_semilattice_def
    by (meson partial_order.axioms(1))+
  show "\<And>x y. \<lbrakk>x \<in> carrier X; y \<in> carrier X; x \<sqsubseteq>\<^bsub>X\<^esub> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq>\<^bsub>Y\<^esub> f y"
    by (metis (no_types, lifting) PiE assms lattice.le_iff_join meet_pres_def)
qed

subsection \<open>Bounded Lattices\<close>

locale bounded_lattice =
  lattice +
  weak_partial_order_bottom +
  weak_partial_order_top

sublocale bounded_lattice \<subseteq> weak_bounded_lattice ..

context bounded_lattice
begin

lemma bottom_eq:
  "\<lbrakk> b \<in> carrier L; \<And> x. x \<in> carrier L \<Longrightarrow> b \<sqsubseteq> x \<rbrakk> \<Longrightarrow> b = \<bottom>"
  by (metis bottom_closed bottom_lower le_antisym)

lemma top_eq:  "\<lbrakk> t \<in> carrier L; \<And> x. x \<in> carrier L \<Longrightarrow> x \<sqsubseteq> t \<rbrakk> \<Longrightarrow> t = \<top>"
  by (metis le_antisym top_closed top_higher)

end

hide_const (open) Lattice.inf
hide_const (open) Lattice.sup

end


(*<*)
theory Trie imports Main begin
(*>*)
text\<open>
To minimize running time, each node of a trie should contain an array that maps
letters to subtries. We have chosen a
representation where the subtries are held in an association list, i.e.\ a
list of (letter,trie) pairs.  Abstracting over the alphabet \<^typ>\<open>'a\<close> and the
values \<^typ>\<open>'v\<close> we define a trie as follows:
\<close>

datatype ('a,'v)trie = Trie  "'v option"  "('a * ('a,'v)trie)list"

text\<open>\noindent
\index{datatypes!and nested recursion}%
The first component is the optional value, the second component the
association list of subtries.  This is an example of nested recursion involving products,
which is fine because products are datatypes as well.
We define two selector functions:
\<close>

primrec "value" :: "('a,'v)trie \<Rightarrow> 'v option" where
"value(Trie ov al) = ov"
primrec alist :: "('a,'v)trie \<Rightarrow> ('a * ('a,'v)trie)list" where
"alist(Trie ov al) = al"

text\<open>\noindent
Association lists come with a generic lookup function.  Its result
involves type \<open>option\<close> because a lookup can fail:
\<close>

primrec assoc :: "('key * 'val)list \<Rightarrow> 'key \<Rightarrow> 'val option" where
"assoc [] x = None" |
"assoc (p#ps) x =
   (let (a,b) = p in if a=x then Some b else assoc ps x)"

text\<open>
Now we can define the lookup function for tries. It descends into the trie
examining the letters of the search string one by one. As
recursion on lists is simpler than on tries, let us express this as primitive
recursion on the search string argument:
\<close>

primrec lookup :: "('a,'v)trie \<Rightarrow> 'a list \<Rightarrow> 'v option" where
"lookup t [] = value t" |
"lookup t (a#as) = (case assoc (alist t) a of
                      None \<Rightarrow> None
                    | Some at \<Rightarrow> lookup at as)"

text\<open>
As a first simple property we prove that looking up a string in the empty
trie \<^term>\<open>Trie None []\<close> always returns \<^const>\<open>None\<close>. The proof merely
distinguishes the two cases whether the search string is empty or not:
\<close>

text\<open>
Things begin to get interesting with the definition of an update function
that adds a new (string, value) pair to a trie, overwriting the old value
associated with that string:
\<close>

primrec update:: "('a,'v)trie \<Rightarrow> 'a list \<Rightarrow> 'v \<Rightarrow> ('a,'v)trie" where
"update t []     v = Trie (Some v) (alist t)" |
"update t (a#as) v =
   (let tt = (case assoc (alist t) a of
                None \<Rightarrow> Trie None [] | Some at \<Rightarrow> at)
    in Trie (value t) ((a,update tt as v) # alist t))"

text\<open>\noindent
The base case is obvious. In the recursive case the subtrie
\<^term>\<open>tt\<close> associated with the first letter \<^term>\<open>a\<close> is extracted,
recursively updated, and then placed in front of the association list.
The old subtrie associated with \<^term>\<open>a\<close> is still in the association list
but no longer accessible via \<^const>\<open>assoc\<close>. Clearly, there is room here for
optimizations!

Before we start on any proofs about \<^const>\<open>update\<close> we tell the simplifier to
expand all \<open>let\<close>s and to split all \<open>case\<close>-constructs over
options:
\<close>

declare Let_def[simp] option.split[split]

text\<open>\noindent
The reason becomes clear when looking (probably after a failed proof
attempt) at the body of \<^const>\<open>update\<close>: it contains both
\<open>let\<close> and a case distinction over type \<open>option\<close>.

Our main goal is to prove the correct interaction of \<^const>\<open>update\<close> and
\<^const>\<open>lookup\<close>:
\<close>

theorem "\<forall>t v bs. lookup (update t as v) bs =
                    (if as=bs then Some v else lookup t bs)"

txt\<open>\noindent
Our plan is to induct on \<^term>\<open>as\<close>; hence the remaining variables are
quantified. From the definitions it is clear that induction on either
\<^term>\<open>as\<close> or \<^term>\<open>bs\<close> is required. The choice of \<^term>\<open>as\<close> is
guided by the intuition that simplification of \<^const>\<open>lookup\<close> might be easier
if \<^const>\<open>update\<close> has already been simplified, which can only happen if
\<^term>\<open>as\<close> is instantiated.
The start of the proof is conventional:
\<close>
apply(induct_tac as, auto)

txt\<open>\noindent
Unfortunately, this time we are left with three intimidating looking subgoals:
\begin{isabelle}
~1.~\dots~{\isasymLongrightarrow}~lookup~\dots~bs~=~lookup~t~bs\isanewline
~2.~\dots~{\isasymLongrightarrow}~lookup~\dots~bs~=~lookup~t~bs\isanewline
~3.~\dots~{\isasymLongrightarrow}~lookup~\dots~bs~=~lookup~t~bs
\end{isabelle}
Clearly, if we want to make headway we have to instantiate \<^term>\<open>bs\<close> as
well now. It turns out that instead of induction, case distinction
suffices:
\<close>
apply(case_tac[!] bs, auto)
done

text\<open>\noindent
\index{subgoal numbering}%
All methods ending in \<open>tac\<close> take an optional first argument that
specifies the range of subgoals they are applied to, where \<open>[!]\<close> means
all subgoals, i.e.\ \<open>[1-3]\<close> in our case. Individual subgoal numbers,
e.g. \<open>[2]\<close> are also allowed.

This proof may look surprisingly straightforward. However, note that this
comes at a cost: the proof script is unreadable because the intermediate
proof states are invisible, and we rely on the (possibly brittle) magic of
\<open>auto\<close> (\<open>simp_all\<close> will not do --- try it) to split the subgoals
of the induction up in such a way that case distinction on \<^term>\<open>bs\<close> makes
sense and solves the proof.

\begin{exercise}
  Modify \<^const>\<open>update\<close> (and its type) such that it allows both insertion and
  deletion of entries with a single function.  Prove the corresponding version
  of the main theorem above.
  Optimize your function such that it shrinks tries after
  deletion if possible.
\end{exercise}

\begin{exercise}
  Write an improved version of \<^const>\<open>update\<close> that does not suffer from the
  space leak (pointed out above) caused by not deleting overwritten entries
  from the association list. Prove the main theorem for your improved
  \<^const>\<open>update\<close>.
\end{exercise}

\begin{exercise}
  Conceptually, each node contains a mapping from letters to optional
  subtries. Above we have implemented this by means of an association
  list. Replay the development replacing \<^typ>\<open>('a * ('a,'v)trie)list\<close>
  with \<^typ>\<open>'a \<Rightarrow> ('a,'v)trie option\<close>.
\end{exercise}

\<close>

(*<*)

(* Exercise 1. Solution by Getrud Bauer *)

primrec update1 :: "('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a, 'v) trie"
where
  "update1 t []     vo = Trie vo (alist t)" |
  "update1 t (a#as) vo =
     (let tt = (case assoc (alist t) a of
                  None \<Rightarrow> Trie None []
                | Some at \<Rightarrow> at)
      in Trie (value t) ((a, update1 tt as vo) # alist t))"

theorem [simp]: "\<forall>t v bs. lookup (update1 t as v) bs =
                    (if as = bs then v else lookup t bs)"
apply (induct_tac as, auto)
apply (case_tac[!] bs, auto)
done

(* Exercise 2. Solution by Getrud Bauer *)

primrec overwrite :: "'a \<Rightarrow> 'b \<Rightarrow> ('a * 'b) list \<Rightarrow> ('a * 'b) list" where
"overwrite a v [] = [(a,v)]" |
"overwrite a v (p#ps) = (if a = fst p then (a,v)#ps else p # overwrite a v ps)"

lemma [simp]: "\<forall> a v b. assoc (overwrite a v ps) b = assoc ((a,v)#ps) b"
apply (induct_tac ps, auto)
apply (case_tac[!] a)
done

primrec update2 :: "('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a, 'v) trie"
where
  "update2 t []     vo = Trie vo (alist t)" |
  "update2 t (a#as) vo =
     (let tt = (case assoc (alist t) a of
                  None \<Rightarrow> Trie None []
                | Some at \<Rightarrow> at)
      in Trie (value t) (overwrite a (update2 tt as vo) (alist t)))"

theorem "\<forall>t v bs. lookup (update2 t as vo) bs =
                    (if as = bs then vo else lookup t bs)"
apply (induct_tac as, auto)
apply (case_tac[!] bs, auto)
done

(* Exercise 3. Solution by Getrud Bauer *)
datatype ('a,dead 'v) triem = Triem  "'v option" "'a \<Rightarrow> ('a,'v) triem option"

primrec valuem :: "('a, 'v) triem \<Rightarrow> 'v option" where
"valuem (Triem ov m) = ov"

primrec mapping :: "('a,'v) triem \<Rightarrow> 'a \<Rightarrow> ('a, 'v) triem option" where
"mapping (Triem ov m) = m"

primrec lookupm :: "('a,'v) triem \<Rightarrow> 'a list \<Rightarrow> 'v option" where
  "lookupm t [] = valuem t" |
  "lookupm t (a#as) = (case mapping t a of
                        None \<Rightarrow> None
                      | Some at \<Rightarrow> lookupm at as)"

lemma [simp]: "lookupm (Triem None  (\<lambda>c. None)) as = None"
apply (case_tac as, simp_all)
done

primrec updatem :: "('a,'v)triem \<Rightarrow> 'a list \<Rightarrow> 'v \<Rightarrow> ('a,'v)triem" where
  "updatem t []     v = Triem (Some v) (mapping t)" |
  "updatem t (a#as) v =
     (let tt = (case mapping t a of
                  None \<Rightarrow> Triem None (\<lambda>c. None)
                | Some at \<Rightarrow> at)
      in Triem (valuem t)
              (\<lambda>c. if c = a then Some (updatem tt as v) else mapping t c))"

theorem "\<forall>t v bs. lookupm (updatem t as v) bs =
                    (if as = bs then Some v else lookupm t bs)"
apply (induct_tac as, auto)
apply (case_tac[!] bs, auto)
done

end
(*>*)


theory P10 imports Main begin

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

theorem [simp]: "sq n = n * n"
  apply (induct n)
   apply auto
  done

lemma aux[rule_format]: "\<forall>m. m <= n \<longrightarrow> sq n = ((n + (n-m))* m) + sq (n-m)"
  apply (induct_tac n, auto)
  apply (case_tac m, auto)
  done

theorem MM2: "100 \<le> n \<Longrightarrow> sq n = ((n + (n - 100))* 100) + sq (n - 100)"
  by (rule aux)

lemma binomial [simp]: "sq (a+b) = (sq a + sq b + 2 * a * b)"
  apply (induct a)
   apply auto
  done

theorem MM3: "sq((10 * n) + 5) = ((n * (Suc n)) * 100) + 25"
proof (induct n)
case 0
  then show ?case by simp
next
  case (Suc n)
  assume "sq (10 * n + 5) = n * Suc n * 100 + 25"
  have "sq (10 * Suc n + 5) = sq (10 * n + 10 + 5)" by simp
  also have "\<dots> = sq (10 * n + 15)" by (simp add: add.assoc)
  also have "\<dots> = (sq (10 * n) + sq 15 + (2 * (10 * n) * 15))" using P10.binomial by blast
  also have "\<dots> = ((10 * n * 10 * n) + sq 15 + (2 * (10 * n) * 15))" by simp
  also have "\<dots> = ((100 * n * n) + sq 15 + (2 * (10 * n) * 15))" by simp
  also have "\<dots> = ((100 * n * n) + 225 + (30 * (10 * n)))" by simp
  finally have "\<dots> = ((100 * n * n) + (300 * n) + 225)" by (simp add: add.assoc)
  hence 1: "sq (10 * Suc n + 5) = ((100 * n * n) + (300 * n) + 225)"
    using \<open>sq (10 * n + 10 + 5) = sq (10 * n + 15)\<close>
          \<open>sq (10 * n + 15) = sq (10 * n) + sq 15 + 2 * (10 * n) * 15\<close> by auto
  have "Suc n * Suc (Suc n) * 100 + 25 = (n+1) * (n+1+1) * 100 + 25" by simp
  also have "\<dots> = (n+1) * (n+2) * 100 + 25" by simp
  also have "\<dots> = (n*n + 3 * n + 2) * 100 + 25" by simp
  also have "\<dots> = (100 * n * n) + (300 * n) + 25 + 200" by simp
  finally have "\<dots> = ((100 * n * n) + 225 + (30 * (10 * n)))" by simp
  hence 2: "Suc n * Suc (Suc n) * 100 + 25 = ((100 * n * n) + 225 + (30 * (10 * n)))"
    by simp
  then show ?case using 1 2 by simp
qed

end