(* Author: Lukas Koller *)
theory BergePrimAdaptor
  imports Main tsp.Misc "Prim_Dijkstra_Simple.Undirected_Graph" tsp.MinSpanningTree
    (* "Prim_Dijkstra_Simple.Prim_Impl" *)
begin

section \<open>From Berge to Prim\<close>

text \<open>Translate graph from \<open>Berge\<close> to graph from \<open>Prim_Dijkstra_Simple.Undirected_Graph\<close>.\<close>
definition "prim_of_berge E \<equiv> Undirected_Graph.graph (Vs E) {(u,v)| u v. {u,v} \<in> E}"

text \<open>Function to translate from \<open>Berge.path\<close> to \<open>Undirected_Graph.path\<close>.\<close>
fun dedges_of_path where
  "dedges_of_path [] = []"
| "dedges_of_path [v] = []"
| "dedges_of_path (u#v#P) = (u,v) # (dedges_of_path (v#P))"

lemma dedges_length: "length (dedges_of_path P) = length (edges_of_path P)"
  by (induction P rule: dedges_of_path.induct) auto

lemma dedges_of_path_nilE:
  assumes "dedges_of_path P = []"
  obtains v where "P = [] \<or> P = [v]"
  using assms by (induction P rule: dedges_of_path.induct) auto

lemma dedges_of_path_nonnilE:
  assumes "dedges_of_path P \<noteq> []"
  shows "P \<noteq> []" "\<And>v. P \<noteq> [v]"
  using assms by auto

lemma dedges_of_path_nil_length: "dedges_of_path P = [] \<Longrightarrow> length P \<le> 1"
  by (induction P rule: dedges_of_path.induct) auto

lemma dedges_of_path_nonnil:
  assumes "length P > 1"
  shows "dedges_of_path P \<noteq> []"
  using assms by (induction P rule: dedges_of_path.induct) auto

lemma map_dedges_of_path: "map uedge (dedges_of_path P) = edges_of_path P"
  by (induction P rule: dedges_of_path.induct) auto

lemma tl_dedges_of_path:
  assumes "P = dedges_of_path P'"
  shows "tl P = dedges_of_path (tl P')"
  using assms by (induction P' rule: dedges_of_path.induct) auto

lemma prim_epath_last_node:
  assumes "P \<noteq> []" "hd P = u" "Undirected_Graph.path G u (dedges_of_path P) v"
  shows "last P = v"
  using assms by (induction P arbitrary: u rule: dedges_of_path.induct) auto

lemma simple_path_equiv1:
  assumes "is_simple P"
  shows "Undirected_Graph.simple (dedges_of_path P)"
  unfolding Undirected_Graph.simple_def using assms
  by (auto elim: is_simpleE simp: map_dedges_of_path)

lemma simple_path_equiv2:
  assumes "Undirected_Graph.simple (dedges_of_path P)"
  shows "is_simple P"
  unfolding Undirected_Graph.simple_def using assms
  by (auto intro: is_simpleI simp: simple_def map_dedges_of_path)

text \<open>Function to translate from \<open>Undirected_Graph.path\<close> to \<open>Berge.path\<close>.\<close>
fun vpath_of_epath where
  "vpath_of_epath [] = []"
| "vpath_of_epath P = map fst P @ [snd (last P)]"

lemma vpath_of_epathE:
  assumes "P\<^sub>v = vpath_of_epath P"
  obtains "P\<^sub>v = []" | u v vs where "P\<^sub>v = u#v#vs"
  using assms by (induction P rule: list012.induct) auto

lemma berge_vpath_of_epath:
  assumes "path E P" "length P > 1"
  shows "P = vpath_of_epath (dedges_of_path P)"
  using assms by (induction P rule: list0123.induct) auto

lemma vpath_of_epath_cancel:
  "dedges_of_path (vpath_of_epath (dedges_of_path P\<^sub>v)) = dedges_of_path P\<^sub>v"
  by (induction P\<^sub>v rule: list0123.induct) auto

lemma walk_vpath_elim_epath:
  assumes "walk_betw E u P\<^sub>v v"
  obtains "P\<^sub>v = [u]" "u = v"
  | P where "P\<^sub>v = vpath_of_epath P" "dedges_of_path (vpath_of_epath P) = P"
  using assms walk_between_nonempty_path[OF assms(1)]
proof (induction P\<^sub>v rule: list012.induct)
  case (3 u v P\<^sub>v)
  hence "u#v#P\<^sub>v = vpath_of_epath (dedges_of_path (u#v#P\<^sub>v))"
    by (intro berge_vpath_of_epath) auto
  then show ?case
    using 3 vpath_of_epath_cancel by metis
qed auto

lemma prim_vpath_of_epath:
  assumes "Undirected_Graph.path G u P v"
  shows "P = dedges_of_path (vpath_of_epath P)"
  using assms
proof (induction P arbitrary: u rule: dedges_of_path.induct)
  case (3 e\<^sub>1 e\<^sub>2 P)
  then obtain x\<^sub>1 x\<^sub>2 where
    [simp]: "e\<^sub>1 = (u,x\<^sub>1)" and "e\<^sub>1 \<in> edges G" "Undirected_Graph.path G x\<^sub>1 (e\<^sub>2#P) v" and
    [simp]: "e\<^sub>2 = (x\<^sub>1,x\<^sub>2)" and "e\<^sub>2 \<in> edges G" "Undirected_Graph.path G x\<^sub>2 P v"
    by auto
  hence "e\<^sub>1#e\<^sub>2#P = (u,x\<^sub>1)#dedges_of_path (vpath_of_epath (e\<^sub>2#P))"
    using "3.IH" by fastforce
  also have "... = dedges_of_path (vpath_of_epath (e\<^sub>1#e\<^sub>2#P))"
    by auto
  finally show ?case .
qed auto

lemma prim_vpath_of_epathE:
  assumes "Undirected_Graph.path G u P v"
  obtains P' where "P = dedges_of_path P'"
  using assms prim_vpath_of_epath[of G] by auto

lemma epath_split_hd1:
  assumes "dedges_of_path (vpath_of_epath (e\<^sub>1#e\<^sub>2#P)) = e\<^sub>1#e\<^sub>2#P" "hd (vpath_of_epath (e\<^sub>1#e\<^sub>2#P)) = u"
  obtains x where "e\<^sub>1 = (u,x)" "fst e\<^sub>2 = x"
  using assms by (induction P) fastforce+

lemma epath_split_hd2:
  assumes "dedges_of_path (vpath_of_epath (e\<^sub>1#e\<^sub>2#P)) = e\<^sub>1#e\<^sub>2#P"
  obtains u x where "e\<^sub>1 = (u,x)" "fst e\<^sub>2 = x"
  using assms by (induction P) (meson epath_split_hd1)+

context graph_abs
begin

lemma prim_finite: "finite (Vs E)" "finite {(u,v)| u v. {u,v} \<in> E}"
  using graph finite_subset[of "{(u,v)| u v. {u,v} \<in> E}" "Vs E \<times> Vs E"]
  by (auto intro: vs_member_intro)

lemma prim_nodes_aux: "fst ` {(u,v) |u v. {u,v} \<in> E} \<union> snd ` {(u,v) |u v. {u,v} \<in> E} \<subseteq> Vs E"
  (is "fst ` ?V \<union> snd ` ?V \<subseteq> Vs E")
proof
  fix v
  assume "v \<in> fst ` ?V \<union> snd ` ?V"
  then consider "v \<in> fst ` ?V" | "v \<in> snd ` ?V"
    by auto
  thus "v \<in> Vs E"
    by cases (auto intro: edges_are_Vs)
qed

lemma prim_nodes[simp]: "nodes (prim_of_berge E) = Vs E"
  unfolding prim_of_berge_def using graph_accs[OF prim_finite] prim_nodes_aux
  by (auto simp: Un_absorb2)

lemma prim_edges[simp]: "edges (prim_of_berge E) = {(u,v)| u v. {u,v} \<in> E}"
  unfolding prim_of_berge_def using graph graph_accs[OF prim_finite] by (auto simp: insert_commute)

lemma nodes_equiv1: "v \<in> Vs E \<Longrightarrow> v \<in> nodes (prim_of_berge E)"
  using graph_accs[OF prim_finite] by auto

lemma nodes_equiv2: "v \<in> nodes (prim_of_berge E) \<Longrightarrow> v \<in> Vs E"
  by auto

lemma edges_equiv1: "{u,v} \<in> E \<Longrightarrow> (u,v) \<in> edges (prim_of_berge E)"
  by auto

lemma edges_equiv2: "(u,v) \<in> edges (prim_of_berge E) \<Longrightarrow> {u,v} \<in> E"
  by auto

lemma edges_eq: "E = uedge ` edges (prim_of_berge E)"
  using graph by (auto simp: uedge_def)

lemma path_edges_subset1:
  assumes "set (edges_of_path P) \<subseteq> E"
  shows "set (dedges_of_path P) \<subseteq> edges (prim_of_berge E)"
  using assms by (induction P rule: edges_of_path.induct) auto

lemma path_edges_subset2:
  assumes "set (dedges_of_path P) \<subseteq> edges (prim_of_berge E)"
  shows "set (edges_of_path P) \<subseteq> E"
  using assms by (induction P rule: dedges_of_path.induct) auto

lemma berge_walk_is_prim_path:
  assumes "walk_betw E u P v"
  shows "Undirected_Graph.path (prim_of_berge E) u (dedges_of_path P) v"
  using assms path_transs1 by (induction u P v rule: induct_walk_betw) auto

lemma prim_path_is_berge_path:
  assumes "set P \<subseteq> Vs E" "Undirected_Graph.path (prim_of_berge E) u (dedges_of_path P) v"
  shows "path E P"
  using assms by (induction P arbitrary: u rule: dedges_of_path.induct) (auto intro: path.intros)

lemma prim_path_is_berge_walk:
  assumes "P \<noteq> []" "hd P = u" "u \<in> Vs E"
      and "Undirected_Graph.path (prim_of_berge E) u (dedges_of_path P) v"
  shows "walk_betw E u P v"
proof (rule nonempty_path_walk_between)
  have "set (edges_of_path P) \<subseteq> E"
    using path_edges[OF assms(4)] by (intro path_edges_subset2)
  hence "set P \<subseteq> Vs E"
    using assms by (intro edges_of_vpath_are_vs) auto
  thus "path E P" "P \<noteq> []" "hd P = u" "last P = v"
    using assms prim_path_is_berge_path by (auto simp: prim_epath_last_node)
qed

lemma walk_iff_rtrancl_edges:
  assumes "u \<in> Vs E" "v \<in> Vs E"
  shows "(\<exists>P. walk_betw E u P v) \<longleftrightarrow> (u,v) \<in> (edges (prim_of_berge E))\<^sup>*"
proof
  assume "\<exists>P. walk_betw E u P v"
  thus "(u,v) \<in> (edges (prim_of_berge E))\<^sup>*"
    using berge_walk_is_prim_path by (intro iffD2[OF rtrancl_edges_iff_path]) auto
next
  assume "(u,v) \<in> (edges (prim_of_berge E))\<^sup>*"
  thus "\<exists>P. walk_betw E u P v"
    using assms
  proof (induction rule: rtrancl_induct)
    case base
    hence "walk_betw E u [u] u"
      by (auto intro: path.intros nonempty_path_walk_between)
    thus ?case
      by auto
  next
    case (step y z)
    hence "{y,z} \<in> E"
      by (intro edges_equiv2)
    moreover hence "y \<in> Vs E"
      by (intro vs_member_intro) auto
    ultimately obtain P where "walk_betw E u P y" "path E [y,z]"
      using step.prems step.IH by (auto intro: path.intros)
    moreover hence "walk_betw E y [y,z] z"
      by (auto intro: path.intros nonempty_path_walk_between)
    ultimately have "walk_betw E u (P @ tl [y,z]) z"
      by (intro walk_transitive)
    thus ?case
      by auto
  qed
qed

lemma conn_comp_equiv:
  assumes "u \<in> Vs E" "v \<in> Vs E"
  shows "v \<in> connected_component E u \<longleftrightarrow> (u,v) \<in> (edges (prim_of_berge E))\<^sup>*"
proof
  assume "v \<in> connected_component E u"
  thus "(u,v) \<in> (edges (prim_of_berge E))\<^sup>*"
    using assms
    by (intro iffD1[OF walk_iff_rtrancl_edges]) (auto elim: in_connected_component_has_path)
next
  assume "(u,v) \<in> (edges (prim_of_berge E))\<^sup>*"
  hence "(\<exists>p. walk_betw E u p v)"
    using assms by (intro iffD2[OF walk_iff_rtrancl_edges])
  thus "v \<in> connected_component E u"
    by (auto intro: has_path_in_connected_component)
qed

lemma connected_equiv1:
  assumes "is_connected E"
  shows "connected (prim_of_berge E)"
proof (rule connectedI)
  fix u v
  assume "u \<in> nodes (prim_of_berge E)" "v \<in> nodes (prim_of_berge E)"
  moreover hence "v \<in> connected_component E u"
    using assms by (auto elim: is_connectedE)
  ultimately show "(u,v) \<in> (edges (prim_of_berge E))\<^sup>*"
    using conn_comp_equiv by auto
qed

lemma connected_equiv2:
  assumes "connected (prim_of_berge E)"
  shows "is_connected E"
proof (rule is_connectedI)
  fix u v
  assume "u \<in> Vs E" "v \<in> Vs E"
  moreover hence "(u,v) \<in> (edges (prim_of_berge E))\<^sup>*"
    using assms by (intro connectedD) auto
  ultimately show "v \<in> connected_component E u"
    using conn_comp_equiv by auto
qed

lemma dedges_path_hd_Vs_mem:
  assumes "Undirected_Graph.path (prim_of_berge E) u (dedges_of_path P) v" "dedges_of_path P \<noteq> []"
  shows "hd P = u" "u \<in> Vs E"
  using assms by (induction P rule: dedges_of_path.induct) (auto intro: edges_are_Vs edges_equiv2)

lemma acyclic_equiv1:
  assumes "is_acyclic E"
  shows "cycle_free (prim_of_berge E)"
proof (rule cycle_freeI)
  fix P u
  assume "Undirected_Graph.path (prim_of_berge E) u P u" "P \<noteq> []" "simple P"
  moreover then obtain P' where "P = dedges_of_path P'"
    by (auto elim: prim_vpath_of_epathE)
  moreover have "is_simple P'"
    using calculation by (auto intro: simple_path_equiv2)
  moreover have "0 < length (edges_of_path P')"
    using calculation by (auto simp: dedges_length[symmetric])
  moreover have "walk_betw E u P' u"
    using calculation dedges_path_hd_Vs_mem by (intro prim_path_is_berge_walk) auto
  ultimately have "is_cycle E P'"
    by (auto intro: is_cycleI)
  thus "False"
    using assms is_acyclicE by auto
qed

lemma acyclic_equiv2:
  assumes "cycle_free (prim_of_berge E)"
  shows "is_acyclic E"
proof (rule ccontr)
  assume "\<not> is_acyclic E"
  then obtain C where "is_cycle E C"
    by (auto elim: not_acyclicE)
  then obtain u where "is_simple C" "0 < length (edges_of_path C)" "walk_betw E u C u"
    by (auto elim: is_cycleE)
  moreover hence "Undirected_Graph.path (prim_of_berge E) u (dedges_of_path C) u"
    by (intro berge_walk_is_prim_path)
  moreover have "dedges_of_path C \<noteq> []"
    using calculation by (auto simp: dedges_length[symmetric])
  moreover have "simple (dedges_of_path C)"
    using calculation by (intro simple_path_equiv1)
  ultimately show "False"
    using assms by (intro cycle_freeD) auto
qed

lemma tree_equiv1: "is_tree E \<Longrightarrow> tree (prim_of_berge E)"
  unfolding tree_def using connected_equiv1 acyclic_equiv1 is_treeE by auto

lemma tree_equiv2: "tree (prim_of_berge E) \<Longrightarrow> is_tree E"
  using connected_equiv2 acyclic_equiv2 by (auto intro: is_treeI simp: tree_def)

end

context graph_abs2
begin

lemma st_equiv1:
  assumes "is_st E\<^sub>1 E\<^sub>2"
  shows "is_spanning_tree (prim_of_berge E\<^sub>1) (prim_of_berge E\<^sub>2)"
  unfolding is_spanning_tree_def
proof (intro conjI)
  have "is_tree E\<^sub>2"
    using assms by (elim is_stE)
  thus "tree (prim_of_berge E\<^sub>2)"
    by (intro E\<^sub>2.tree_equiv1)

  have "Vs E\<^sub>1 = Vs E\<^sub>2"
    using assms by (elim is_stE)
  thus "nodes (prim_of_berge E\<^sub>2) = nodes (prim_of_berge E\<^sub>1)"
    by auto

  have "E\<^sub>2 \<subseteq> E\<^sub>1"
    using assms by (elim is_stE)
  thus "edges (prim_of_berge E\<^sub>2) \<subseteq> edges (prim_of_berge E\<^sub>1)"
    by auto
qed

lemma st_equiv2:
  assumes "is_spanning_tree (prim_of_berge E\<^sub>1) (prim_of_berge E\<^sub>2)"
  shows "is_st E\<^sub>1 E\<^sub>2"
proof (intro is_stI)
  have "tree (prim_of_berge E\<^sub>2)"
    using assms[unfolded is_spanning_tree_def] by auto
  thus "is_tree E\<^sub>2"
    by (intro E\<^sub>2.tree_equiv2)

  have "nodes (prim_of_berge E\<^sub>2) = nodes (prim_of_berge E\<^sub>1)"
    using assms[unfolded is_spanning_tree_def] by auto
  thus "Vs E\<^sub>1 = Vs E\<^sub>2"
    by auto

  have "edges (prim_of_berge E\<^sub>2) \<subseteq> edges (prim_of_berge E\<^sub>1)"
    using assms[unfolded is_spanning_tree_def] by auto
  thus "E\<^sub>2 \<subseteq> E\<^sub>1"
    by (subst E\<^sub>2.edges_eq; subst E\<^sub>1.edges_eq) auto
qed

end

context graph_abs
begin

lemma st_equiv1: "is_st E T \<Longrightarrow> is_spanning_tree (prim_of_berge E) (prim_of_berge T)"
  using st_is_graph by (intro graph_abs2.st_equiv1) unfold_locales

lemma st_equiv2:
  "graph_invar T \<Longrightarrow> is_spanning_tree (prim_of_berge E) (prim_of_berge T) \<Longrightarrow> is_st E T"
  by (intro graph_abs2.st_equiv2) unfold_locales

end

section \<open>From Prim to Berge\<close>

text \<open>Translate graph from \<open>Prim_Dijkstra_Simple.Undirected_Graph\<close> to graph from \<open>Berge\<close>.\<close>
definition "berge_of_prim G \<equiv> uedge ` edges G"

lemma berge_of_prim_def2: "berge_of_prim G = {{u,v} | u v. (u,v) \<in> edges G}"
  unfolding berge_of_prim_def by (auto simp add: uedge_def)

locale prim_graph_abs =
  fixes V E G
  defines "G \<equiv> graph V E"
  assumes finite_V: "finite V" and finite_E: "finite E"
      and irrefl_E: "irrefl E" and V_subset: "V \<subseteq> fst ` E \<union> snd ` E"
begin

lemma edges_G[simp]: "edges G = E \<union> E\<inverse>"
  and nodes_G[simp]: "nodes G = fst ` E \<union> snd ` E"
  unfolding G_def using graph_accs[OF finite_V finite_E] irrefl_E V_subset
  by (auto simp: irrefl_def)

lemma berge_edges_invar:
  assumes "e \<in> berge_of_prim G"
  obtains u v where "e = {u,v}" "u \<noteq> v" "(u,v) \<in> edges G"
proof -
  obtain u v where "e = {u,v}" "(u,v) \<in> edges G"
    using assms by (auto simp: berge_of_prim_def uedge_def)
  moreover hence "u \<noteq> v"
    by (intro edges_irreflI)
  ultimately show ?thesis
    using that by auto
qed

lemma berge_finite: "finite (berge_of_prim G)"
  unfolding berge_of_prim_def uedge_def using finite_E by blast

lemma berge_finite_Vs: "finite (Vs (berge_of_prim G))"
  using berge_finite berge_edges_invar by (auto intro: finite_VsI)

lemma berge_graph: "graph_invar (berge_of_prim G)"
  using berge_finite berge_edges_invar by (intro graph_invarI2) metis+

sublocale graph_abs "berge_of_prim G"
  using berge_graph by unfold_locales

lemma edges_equiv1: "(u,v) \<in> edges G \<Longrightarrow> {u,v} \<in> berge_of_prim G"
  unfolding berge_of_prim_def uedge_def by auto

lemma edges_equiv1_uedge: "e \<in> edges G \<Longrightarrow> uedge e \<in> berge_of_prim G"
  unfolding berge_of_prim_def uedge_def by auto

lemma edges_equiv2: "{u,v} \<in> berge_of_prim G \<Longrightarrow> (u,v) \<in> edges G"
  using berge_edges_invar by (metis doubleton_eq_iff edges_sym')+

lemma edges_equiv2_uedge: "uedge e \<in> berge_of_prim G \<Longrightarrow> e \<in> edges G"
  unfolding uedge_def using edges_equiv2 by (auto split: prod.splits)

lemma berge_nodes[simp]: "Vs (berge_of_prim G) = nodes G"
proof
  show "Vs (berge_of_prim G) \<subseteq> nodes G"
  proof
    fix v
    assume "v \<in> Vs (berge_of_prim G)"
    then obtain u where "{u,v} \<in> berge_of_prim G"
      using berge_graph by (elim vs_member_elim2) auto
    hence "(u,v) \<in> edges G"
      using edges_equiv2 by auto
    then consider "(u,v) \<in> E" "u \<noteq> v" | "(v,u) \<in> E" "u \<noteq> v"
      by auto
    thus "v \<in> nodes G"
      by cases force+
  qed
next
  show "nodes G \<subseteq> Vs (berge_of_prim G)"
  proof
    fix v
    assume "v \<in> nodes G"
    then consider u where "(v,u) \<in> E" | u where "(u,v) \<in> E"
      by force
    thus "v \<in> Vs (berge_of_prim G)"
      by cases (fastforce intro: edges_are_Vs[OF edges_equiv1])+
  qed
qed

lemma nodes_equiv1: "v \<in> nodes G \<Longrightarrow> v \<in> Vs (berge_of_prim G)"
  by auto

lemma nodes_equiv2: "v \<in> Vs (berge_of_prim G) \<Longrightarrow> v \<in> nodes G"
  by auto

lemma edges_eq: "edges G = {(u,v) | u v. {u,v} \<in> berge_of_prim G}"
  using edges_equiv1 edges_equiv2 by auto

lemma path_edges_subset1:
  assumes "set (edges_of_path P) \<subseteq> berge_of_prim G"
  shows "set (dedges_of_path P) \<subseteq> edges G"
  using assms
proof (induction P rule: edges_of_path.induct)
  case (3 u v P)
  moreover hence "(u,v) \<in> edges G"
    by (intro edges_equiv2) auto
  ultimately show ?case
    by auto
qed auto

lemma path_edges_subset2:
  assumes "set (dedges_of_path P) \<subseteq> edges G"
  shows "set (edges_of_path P) \<subseteq> berge_of_prim G"
  using assms by (induction P rule: dedges_of_path.induct) (auto simp: berge_of_prim_def2)

lemma berge_vpath_hd_of_epath_is_prim_edge:
  assumes "path (berge_of_prim G) (vpath_of_epath (e#P))" (is "path ?E _")
      and "dedges_of_path (vpath_of_epath (e#P)) = (e#P)"
  shows "e \<in> edges G"
  using assms
proof (induction P)
  case Nil
  then obtain u v where [simp]: "e = (u,v)" and "path ?E [u,v]"
    by (cases e) auto
  thus ?case
    by (intro edges_equiv2_uedge) (auto simp: uedge_def)
next
  case (Cons e\<^sub>1 P)
  then obtain u x where [simp]: "e = (u,x)" and [simp]: "fst e\<^sub>1 = x"
    by (elim epath_split_hd2)
  hence "uedge e \<in> ?E"
    using Cons path_edges_subset by (auto simp: uedge_def)
  thus ?case
    by (intro edges_equiv2_uedge)
qed

lemma berge_walk_is_prim_path:
  assumes "walk_betw (berge_of_prim G) u (vpath_of_epath P) v" (is "walk_betw ?E u _ v")
      and "dedges_of_path (vpath_of_epath P) = P"
  shows "Undirected_Graph.path G u P v"
  using walk_between_nonempty_path[OF assms(1)] assms(2)
proof (induction P arbitrary: u rule: list012.induct)
  case 1
  thus ?case using walk_nonempty by fastforce
next
  case (2 e)
  moreover hence "e \<in> edges G"
    by (intro berge_vpath_hd_of_epath_is_prim_edge)
  ultimately show ?case
    by auto
next
  case (3 e\<^sub>1 e\<^sub>2 P)
  then obtain x where [simp]: "e\<^sub>1 = (u,x)" and [simp]: "fst e\<^sub>2 = x"
    by (elim epath_split_hd1)
  moreover have "e\<^sub>1 \<in> edges G"
    using 3 by (intro berge_vpath_hd_of_epath_is_prim_edge[of e\<^sub>1 "e\<^sub>2#P"])
  ultimately show ?case
    using 3 by auto
qed

lemma prim_path_is_berge_path:
  assumes "Undirected_Graph.path G u P v"
  shows "path (berge_of_prim G) (vpath_of_epath P)"
  using assms
proof (induction P arbitrary: u rule: list012.induct)
  case (2 e)
  then obtain u v where "e = (u,v)" "e \<in> edges G"
    by auto
  moreover hence "vpath_of_epath [e] = [u,v]"
    by auto
  moreover have "{u,v} \<in> berge_of_prim G"
    using calculation by (intro edges_equiv1) auto
  ultimately show ?case
    by (subst \<open>vpath_of_epath [e] = [u,v]\<close>) (intro edge_is_path)
next
  case (3 e\<^sub>1 e\<^sub>2 P)
  moreover then obtain x y where "e\<^sub>1 = (u,x)" "e\<^sub>2 = (x,y)"
    by auto
  ultimately show ?case by (auto intro: edges_equiv1)
qed auto

lemma prim_path_is_berge_walk:
  assumes "P \<noteq> []" "fst (hd P) = u" "u \<in> Vs (berge_of_prim G)"
      and "Undirected_Graph.path G u P v"
  shows "walk_betw (berge_of_prim G) u (vpath_of_epath P) v"
proof (rule nonempty_path_walk_between)
  show "path (berge_of_prim G) (vpath_of_epath P)"
    using assms by (intro prim_path_is_berge_path)
  show "vpath_of_epath P \<noteq> []"
    using assms by (cases P) auto
  moreover show "hd (vpath_of_epath P) = u"
    using assms by (cases P) auto
  ultimately show "last (vpath_of_epath P) = v"
    using assms by (metis prim_epath_last_node prim_vpath_of_epath)
qed

lemma walk_iff_rtrancl_edges:
  assumes "u \<in> Vs (berge_of_prim G)" "v \<in> Vs (berge_of_prim G)"
  shows "(\<exists>P. walk_betw (berge_of_prim G) u P v) \<longleftrightarrow> (u,v) \<in> (edges G)\<^sup>*"
proof
  assume "\<exists>P. walk_betw (berge_of_prim G) u P v"
  then obtain P\<^sub>v where "walk_betw (berge_of_prim G) u P\<^sub>v v"
    by auto
  then consider "P\<^sub>v = [u]" "u = v"
    | P where "walk_betw (berge_of_prim G) u (vpath_of_epath P) v"
      "dedges_of_path (vpath_of_epath P) = P"
    by (auto elim: walk_vpath_elim_epath)
  thus "(u,v) \<in> (edges G)\<^sup>*"
  proof cases
    fix P
    assume "walk_betw (berge_of_prim G) u (vpath_of_epath P) v"
      "dedges_of_path (vpath_of_epath P) = P"
    thus "(u,v) \<in> (edges G)\<^sup>*"
      using berge_walk_is_prim_path by (intro iffD2[OF rtrancl_edges_iff_path]) auto
  qed auto
next
  assume "(u,v) \<in> (edges G)\<^sup>*"
  thus "\<exists>P. walk_betw (berge_of_prim G) u P v"
    using assms
  proof (induction rule: rtrancl_induct)
    case base
    hence "walk_betw (berge_of_prim G) u [u] u"
      by (intro nonempty_path_walk_between) (auto intro: path1)
    thus ?case
      by auto
  next
    case (step y z)
    hence "{y,z} \<in> (berge_of_prim G)"
      by (intro edges_equiv1)
    moreover hence "y \<in> Vs (berge_of_prim G)"
      by (intro vs_member_intro) auto
    ultimately obtain P where "walk_betw (berge_of_prim G) u P y" "path (berge_of_prim G) [y,z]"
      using step.prems step.IH by (auto intro: path.intros)
    moreover hence "walk_betw (berge_of_prim G) y [y,z] z"
      by (intro nonempty_path_walk_between) (auto intro: path.intros)
    ultimately have "walk_betw (berge_of_prim G) u (P @ tl [y,z]) z"
      by (intro walk_transitive)
    thus ?case
      by auto
  qed
qed

lemma conn_comp_equiv:
  assumes "u \<in> Vs (berge_of_prim G)" "v \<in> Vs (berge_of_prim G)"
  shows "v \<in> connected_component (berge_of_prim G) u \<longleftrightarrow> (u,v) \<in> (edges G)\<^sup>*"
proof
  assume "v \<in> connected_component (berge_of_prim G) u"
  then obtain P where "walk_betw (berge_of_prim G) u P v"
    using assms by (elim in_connected_component_has_path) auto
  thus "(u,v) \<in> (edges G)\<^sup>*"
    using assms by (intro iffD1[OF walk_iff_rtrancl_edges]) auto
next
  assume "(u,v) \<in> (edges G)\<^sup>*"
  hence "(\<exists>p. walk_betw (berge_of_prim G) u p v)"
    using assms by (intro iffD2[OF walk_iff_rtrancl_edges])
  thus "v \<in> connected_component (berge_of_prim G) u"
    by (auto intro: has_path_in_connected_component)
qed

lemma connected_equiv1:
  assumes "is_connected (berge_of_prim G)"
  shows "connected G"
proof (rule connectedI)
  fix u v
  assume "u \<in> nodes G" "v \<in> nodes G"
  moreover hence "v \<in> connected_component (berge_of_prim G) u"
    using assms by (intro is_connectedE) auto
  ultimately show "(u,v) \<in> (edges G)\<^sup>*"
    using conn_comp_equiv by auto
qed

lemma connected_equiv2:
  assumes "connected G"
  shows "is_connected (berge_of_prim G)"
proof (rule is_connectedI)
  fix u v
  assume "u \<in> Vs (berge_of_prim G)" "v \<in> Vs (berge_of_prim G)"
  moreover hence "(u,v) \<in> (edges G)\<^sup>*"
    using assms by (intro connectedD) auto
  ultimately show "v \<in> connected_component (berge_of_prim G) u"
    using conn_comp_equiv by auto
qed

lemma dedges_path_hd_Vs_mem:
  assumes "Undirected_Graph.path G u P v" "P \<noteq> []"
  shows "fst (hd P) = u" "u \<in> Vs (berge_of_prim G)"
  using assms
proof (induction P rule: dedges_of_path.induct)
  case (2 e)
  {
    case 1
    then show ?case by auto
  next
    case 2
    then show ?case
      by (intro edges_are_Vs) (auto intro: edges_equiv1)
  }
next
  case (3 e\<^sub>1 e\<^sub>2 P)
  {
    case 1
    then show ?case by auto
  next
    case 2
    moreover hence "uedge e\<^sub>1 \<in> berge_of_prim G"
      by (intro edges_equiv1_uedge) auto
    ultimately show ?case
      by (intro vs_member_intro) auto
  }
qed auto

lemma acyclic_equiv1:
  assumes "is_acyclic (berge_of_prim G)"
  shows "cycle_free G"
proof (rule cycle_freeI)
  fix P u
  assume "Undirected_Graph.path G u P u" "P \<noteq> []" "simple P"
  moreover hence "P = dedges_of_path (vpath_of_epath P)" (is "P = dedges_of_path ?P")
    apply (intro prim_vpath_of_epath)
    by (auto elim: prim_vpath_of_epathE)
  moreover have "is_simple ?P"
    using calculation by (auto intro: simple_path_equiv2)
  moreover have "0 < length (edges_of_path ?P)"
    using calculation by (auto simp: dedges_length[symmetric])
  moreover have "walk_betw (berge_of_prim G) u ?P u"
    using calculation dedges_path_hd_Vs_mem by (intro prim_path_is_berge_walk)
  ultimately have "is_cycle (berge_of_prim G) ?P"
    by (auto intro: is_cycleI)
  thus "False"
    using assms is_acyclicE by auto
qed

lemma acyclic_equiv2:
  assumes "cycle_free G"
  shows "is_acyclic (berge_of_prim G)"
proof (rule ccontr)
  assume "\<not> is_acyclic (berge_of_prim G)"
  then obtain C where "is_cycle (berge_of_prim G) C"
    by (auto elim: not_acyclicE)
  then obtain u where "is_simple C" "0 < length (edges_of_path C)"
    "walk_betw (berge_of_prim G) u C u"
    by (auto elim: is_cycleE)
  moreover hence "1 < length C"
    using edges_of_path_length by (metis zero_less_diff)
  moreover have "walk_betw (berge_of_prim G) u (vpath_of_epath (dedges_of_path C)) u"
    using calculation by (subst berge_vpath_of_epath[symmetric]) auto
  moreover hence "Undirected_Graph.path G u (dedges_of_path C) u"
    using vpath_of_epath_cancel by (intro berge_walk_is_prim_path)
  moreover have "dedges_of_path C \<noteq> []"
    using calculation by (auto simp: dedges_length[symmetric])
  moreover have "simple (dedges_of_path C)"
    using calculation by (intro simple_path_equiv1)
  ultimately show "False"
    using assms by (intro cycle_freeD) auto
qed

lemma tree_equiv1: "is_tree (berge_of_prim G) \<Longrightarrow> tree G"
  unfolding tree_def using connected_equiv1 acyclic_equiv1 is_treeE by auto

lemma tree_equiv2: "tree G \<Longrightarrow> is_tree (berge_of_prim G)"
  using connected_equiv2 acyclic_equiv2 by (auto intro: is_treeI simp: tree_def)

end

locale prim_graph_abs2 =
  G: prim_graph_abs V E G +
  T: prim_graph_abs V E' T for V E E' G T
begin

lemma st_equiv1:
  assumes "is_st (berge_of_prim G) (berge_of_prim T)"
  shows "is_spanning_tree G T"
  unfolding is_spanning_tree_def
proof (intro conjI)
  have "is_tree (berge_of_prim T)"
    using assms by (elim is_stE)
  thus "tree T"
    by (intro T.tree_equiv1)

  have "Vs (berge_of_prim G) = Vs (berge_of_prim T)"
    using assms by (elim is_stE)
  thus "nodes T = nodes G"
    by auto

  have "berge_of_prim T \<subseteq> berge_of_prim G"
    using assms by (elim is_stE)
  thus "edges T \<subseteq> edges G"
    by (subst T.edges_eq; subst G.edges_eq) auto
qed

lemma st_equiv2:
  assumes "is_spanning_tree G T"
  shows "is_st (berge_of_prim G) (berge_of_prim T)"
proof (intro is_stI)
  have "tree T"
    using assms[unfolded is_spanning_tree_def] by auto
  thus "is_tree (berge_of_prim T)"
    by (intro T.tree_equiv2)

  have "nodes G = nodes T"
    using assms[unfolded is_spanning_tree_def] by auto
  thus "Vs (berge_of_prim G) = Vs (berge_of_prim T)"
    by auto

  have "edges T \<subseteq> edges G"
    using assms[unfolded is_spanning_tree_def] by auto
  thus "berge_of_prim T \<subseteq> berge_of_prim G"
    unfolding berge_of_prim_def2 by auto
qed

end

lemma uedge_union_converse: "uedge ` (A \<union> A\<inverse>) = uedge ` A"
  unfolding uedge_def by auto

lemma uedge_set: "uedge ` A = {{u,v} |u v. (u,v) \<in> A}"
  unfolding uedge_def by auto

lemma Vs_uedge: "Vs (uedge ` A) = fst ` A \<union> snd ` A"
  unfolding Vs_def uedge_def by force

lemma vertex_in_uedge:
  assumes "e \<in> A" "v \<in> uedge e"
  shows "v \<in> fst ` A \<union> snd ` A"
proof -
  have "v \<in> Vs (uedge ` A)"
    using assms by (intro vs_member_intro) auto
  thus ?thesis
    by (auto simp: Vs_uedge)
qed

locale prim_subgraph_abs =
  prim_graph_abs V E G for V E G +
  fixes E\<^sub>T
  assumes E\<^sub>T_subset: "E\<^sub>T \<subseteq> E"
      (* Berge cannot represent a graph with a single node! *)
      and card_nodes_G: "card (nodes G) \<ge> 2"
begin

lemma finite_E\<^sub>T: "finite E\<^sub>T"
  by (intro finite_subset[OF E\<^sub>T_subset finite_E])

lemma irrefl_E\<^sub>T: "irrefl E\<^sub>T"
  by (intro irrefl_subset[OF irrefl_E E\<^sub>T_subset])

lemma prim_subgraph_nodes: "nodes (graph V E\<^sub>T) = V \<union> fst ` E\<^sub>T \<union> snd ` E\<^sub>T"
  using finite_V finite_E\<^sub>T by (auto simp: graph_accs(1))

lemma prim_subgraph_edges: "edges (graph V E\<^sub>T) = E\<^sub>T \<union> E\<^sub>T\<inverse>"
  using finite_V finite_E\<^sub>T irrefl_E\<^sub>T by (auto simp: graph_accs(2) irrefl_def)

lemma st_V_subset:
  assumes "is_st (berge_of_prim G) (berge_of_prim (graph V E\<^sub>T))"
      (is "is_st (berge_of_prim G) (berge_of_prim ?T)")
  shows "V \<subseteq> fst ` E\<^sub>T \<union> snd ` E\<^sub>T"
proof -
  have "V \<subseteq> Vs (berge_of_prim G)"
    using V_subset by auto
  also have "... = Vs (berge_of_prim ?T)"
    using assms by (elim is_stE)
  also have "... = Vs (uedge ` (E\<^sub>T \<union> E\<^sub>T\<inverse>))"
    unfolding berge_of_prim_def2 using assms by (auto simp: prim_subgraph_edges uedge_set)
  also have "... = fst ` E\<^sub>T \<union> snd ` E\<^sub>T"
    by (auto simp: uedge_union_converse Vs_uedge)
  finally show ?thesis .
qed

lemma connected_graph_get_edge_for_node:
  assumes "connected (graph V E\<^sub>T)"
      and "u \<in> nodes (graph V E\<^sub>T)" "v \<in> nodes (graph V E\<^sub>T)" "u \<noteq> v"
  obtains e where "e \<in> E\<^sub>T" "u \<in> uedge e"
proof -
  have "(u,v) \<in> (edges (graph V E\<^sub>T))\<^sup>*"
    using assms[unfolded connected_def] by auto
  then obtain P where "Undirected_Graph.path (graph V E\<^sub>T) u P v"
    using rtrancl_edges_iff_path by fastforce
  then obtain e P' where "Undirected_Graph.path (graph V E\<^sub>T) u (e#P') v"
    using assms by (cases P) auto
  hence "e \<in> E\<^sub>T \<union> E\<^sub>T\<inverse>" and "u \<in> uedge e"
    by (auto simp: prim_subgraph_edges)
  then obtain e' where "e' \<in> E\<^sub>T" "u \<in> uedge e'"
    by fastforce
  thus ?thesis
    using that by auto
qed

lemma connected_graph_nodes_subset:
  assumes "connected (graph V E\<^sub>T)" "u \<in> nodes (graph V E\<^sub>T)" "v \<in> nodes (graph V E\<^sub>T)" "u \<noteq> v"
  shows "nodes (graph V E\<^sub>T) \<subseteq> fst ` E\<^sub>T \<union> snd ` E\<^sub>T"
proof
  fix x
  assume vertex_x: "x \<in> nodes (graph V E\<^sub>T)"
  consider "x \<noteq> u" | "x \<noteq> v"
    using assms by auto
  thus "x \<in> fst ` E\<^sub>T \<union> snd ` E\<^sub>T"
  proof cases
    assume "x \<noteq> u"
    then obtain e where "e \<in> E\<^sub>T" "x \<in> uedge e"
      using assms vertex_x by (elim connected_graph_get_edge_for_node)
    hence "x \<in> fst ` E\<^sub>T \<union> snd ` E\<^sub>T"
      by (intro vertex_in_uedge)
    thus ?thesis
      by auto
  next
    assume "x \<noteq> v"
    then obtain e where "e \<in> E\<^sub>T" "x \<in> uedge e"
      using assms vertex_x by (elim connected_graph_get_edge_for_node)
    hence "x \<in> fst ` E\<^sub>T \<union> snd ` E\<^sub>T"
      by (intro vertex_in_uedge)
    thus ?thesis
      by auto
  qed
qed

lemma spanning_tree_V_subset:
  assumes "is_spanning_tree G (graph V E\<^sub>T)"
  obtains "V \<subseteq> fst ` E\<^sub>T \<union> snd ` E\<^sub>T"
  using nodes_finite assms[unfolded is_spanning_tree_def] card_nodes_G
proof (induction "nodes (graph V E\<^sub>T)" rule: finite2_induct)
  case (singleton x)
  hence "card {x} \<ge> 2"
    by auto
  thus ?case
    by auto
next
  case (insert2 u v)
  moreover hence "connected (graph V E\<^sub>T)"
    unfolding tree_def by auto
  ultimately have "nodes (graph V E\<^sub>T) \<subseteq> fst ` E\<^sub>T \<union> snd ` E\<^sub>T"
    by (intro that connected_graph_nodes_subset) auto
  hence "V \<subseteq> fst ` E\<^sub>T \<union> snd ` E\<^sub>T"
     by (auto simp: prim_subgraph_nodes)
   thus ?case
    by (intro that connected_graph_nodes_subset) auto
qed auto (* induction just for case distinction *)

lemmas subgraph_props = finite_V st_V_subset finite_E\<^sub>T irrefl_E\<^sub>T spanning_tree_V_subset

lemma st_equiv1:
  assumes "is_st (berge_of_prim G) (berge_of_prim (graph V E\<^sub>T))"
  shows "is_spanning_tree G (graph V E\<^sub>T)"
  unfolding G_def
  using assms subgraph_props
  apply (intro prim_graph_abs2.st_equiv1)
  apply unfold_locales
  apply (auto simp: G_def)
  done

lemma st_equiv2:
  assumes "is_spanning_tree G (graph V E\<^sub>T)"
  shows "is_st (berge_of_prim G) (berge_of_prim (graph V E\<^sub>T))"
  unfolding G_def
  using assms subgraph_props
  apply (intro prim_graph_abs2.st_equiv2)
  apply unfold_locales
  apply (auto simp: G_def)
  done

end

context prim_graph_abs
begin

lemma st_equiv1:
  assumes "E\<^sub>T \<subseteq> E" "card (nodes G) \<ge> 2" and "is_st (berge_of_prim G) (berge_of_prim (graph V E\<^sub>T))"
  shows "is_spanning_tree G (graph V E\<^sub>T)"
  using assms unfolding G_def by (intro prim_subgraph_abs.st_equiv1) unfold_locales

lemma st_equiv2:
  assumes "E\<^sub>T \<subseteq> E" "card (nodes G) \<ge> 2" and "is_spanning_tree G (graph V E\<^sub>T)"
  shows "is_st (berge_of_prim G) (berge_of_prim (graph V E\<^sub>T))"
  using assms unfolding G_def by (intro prim_subgraph_abs.st_equiv2) unfold_locales

lemma prim_of_berge_of_prim: "prim_of_berge (berge_of_prim G) = G"
  unfolding prim_of_berge_def by (metis berge_nodes edges_eq graph_eq)

end

section \<open>Minimum Spanning-Tree Equivalence\<close>

locale nat_w_graph_abs = (* nat weights *)
  pos_w_graph_abs E c for E :: "'a set set" and c :: "'a set \<Rightarrow> nat"
begin

lemma cost_of_st_eq1: "graph_invar T \<Longrightarrow> cost_of_st\<^sub>c T = weight c (prim_of_berge T)"
  by (subst graph_abs.edges_eq[of T]; unfold_locales) (auto simp: weight_alt)

lemma cost_of_st_eq2: "cost_of_st\<^sub>c (berge_of_prim T) = weight c T"
  unfolding weight_alt berge_of_prim_def by auto

lemma mst_equiv1:
  assumes "is_mst E c T"
  shows "is_MST c (prim_of_berge E) (prim_of_berge T)"
  unfolding is_MST_def
proof
  have "is_st E T"
    using assms by (elim is_mstE)
  thus "is_spanning_tree (prim_of_berge E) (prim_of_berge T)"
    by (intro st_equiv1)
  have "is_st E T"
    using assms by (elim is_mstE)
  then consider "graph_invar T" "T = {}" | "graph_invar T" "card (Vs T) \<ge> 2"
    using graph_subset[OF graph is_stE(1)] by (auto elim: st_card_Vs)
  thus "\<forall>T'. is_spanning_tree (prim_of_berge E) T' \<longrightarrow> weight c (prim_of_berge T) \<le> weight c T'"
  proof (intro allI impI; cases)
    fix T'
    assume "is_spanning_tree (prim_of_berge E) T'" and "T = {}" "graph_invar T"
    hence "weight c (prim_of_berge T) = 0"
      by (auto simp: cost_of_st_eq1[symmetric])
    thus "weight c (prim_of_berge T) \<le> weight c T'"
      by auto
  next
    fix T'
    assume "is_spanning_tree (prim_of_berge E) T'" and "card (Vs T) \<ge> 2" "graph_invar T"
    hence "is_st E (berge_of_prim T')"
      sorry (* TODO: need a lemma *)
    moreover have "\<And>T'. is_st E T' \<Longrightarrow> cost_of_st\<^sub>c T \<le> cost_of_st\<^sub>c T'"
      using assms by (elim is_mstE)
    ultimately have "cost_of_st\<^sub>c T \<le> cost_of_st\<^sub>c (berge_of_prim T')"
      by auto
    hence "weight c (prim_of_berge T) \<le> cost_of_st\<^sub>c (berge_of_prim T')"
      using \<open>card (Vs T) \<ge> 2\<close> \<open>graph_invar T\<close> by (auto simp: cost_of_st_eq1)
    also have "... \<le> weight c T'"
      by (auto simp: cost_of_st_eq2)
    finally show "weight c (prim_of_berge T) \<le> weight c T'"
      by auto
  qed
qed

lemma mst_equiv2:
  assumes "graph_invar T" "is_MST c (prim_of_berge E) (prim_of_berge T)"
  shows "is_mst E c T"
proof (intro is_mstI)
  show "is_st E T"
    using assms[unfolded is_MST_def] by (auto intro: st_equiv2)
  show "\<And>T'. is_st E T' \<Longrightarrow> cost_of_st\<^sub>c T \<le> cost_of_st\<^sub>c T'"
  proof -
    fix T'
    assume "is_st E T'"
    moreover hence "graph_invar T'"
      by (intro st_is_graph)
    moreover hence "is_spanning_tree (prim_of_berge E) (prim_of_berge T')"
      using calculation by (intro st_equiv1)
    moreover hence "weight c (prim_of_berge T) \<le> weight c (prim_of_berge T')"
      using assms[unfolded is_MST_def] by auto
    moreover have "graph_invar T"
      using \<open>is_st E T\<close> by (intro st_is_graph)
    ultimately show "cost_of_st\<^sub>c T \<le> cost_of_st\<^sub>c T'"
      by (auto simp: cost_of_st_eq1)
  qed
qed

end

(* TODO: use Prim_Dijkstra_Simple implementation *)

fun prim_impl where
  "prim_impl c E = undefined" (* translate params to prim_impl, or prim_list_impl_int *)

(* interpretation mst E c prim_impl'
  sorry *)

end


(*  Title:      HOL/Nitpick_Examples/Hotel_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2010-2011

Nitpick example based on Tobias Nipkow's hotel key card formalization.
*)

section \<open>Nitpick Example Based on Tobias Nipkow's Hotel Key Card
          Formalization\<close>

theory Hotel_Nits
imports MainRLT
begin

nitpick_params [verbose, max_potential = 0, sat_solver = MiniSat,
                max_threads = 1, timeout = 240]

typedecl guest
typedecl key
typedecl room

type_synonym keycard = "key \<times> key"

record state =
  owns :: "room \<Rightarrow> guest option"
  currk :: "room \<Rightarrow> key"
  issued :: "key set"
  cards :: "guest \<Rightarrow> keycard set"
  roomk :: "room \<Rightarrow> key"
  isin :: "room \<Rightarrow> guest set"
  safe :: "room \<Rightarrow> bool"

inductive_set reach :: "state set" where
init:
"inj initk \<Longrightarrow>
 \<lparr>owns = (\<lambda>r. None), currk = initk, issued = range initk, cards = (\<lambda>g. {}),
  roomk = initk, isin = (\<lambda>r. {}), safe = (\<lambda>r. True)\<rparr> \<in> reach" |
check_in:
"\<lbrakk>s \<in> reach; k \<notin> issued s\<rbrakk> \<Longrightarrow>
 s\<lparr>currk := (currk s)(r := k), issued := issued s \<union> {k},
   cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
   owns :=  (owns s)(r := Some g), safe := (safe s)(r := False)\<rparr> \<in> reach" |
enter_room:
"\<lbrakk>s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'}\<rbrakk> \<Longrightarrow>
 s\<lparr>isin := (isin s)(r := isin s r \<union> {g}),
   roomk := (roomk s)(r := k'),
   safe := (safe s)(r := owns s r = Some g \<and> isin s r = {} \<^cancel>\<open>\<and> k' = currk s r\<close>
                         \<or> safe s r)\<rparr> \<in> reach" |
exit_room:
"\<lbrakk>s \<in> reach; g \<in> isin s r\<rbrakk> \<Longrightarrow> s\<lparr>isin := (isin s)(r := isin s r - {g})\<rparr> \<in> reach"

theorem safe: "s \<in> reach \<Longrightarrow> safe s r \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"
nitpick [card room = 1, card guest = 2, card "guest option" = 3,
         card key = 4, card state = 6, show_consts, format = 2,
         expect = genuine]
(* nitpick [card room = 1, card guest = 2, expect = genuine] *) (* slow *)
oops

end


(* Author: Florian Haftmann, TU Muenchen *)

section {* Preorders with explicit equivalence relation *}

theory Preorder
imports Orderings
begin

class preorder_equiv = preorder
begin

definition equiv :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "equiv x y \<longleftrightarrow> x \<le> y \<and> y \<le> x"

notation
  equiv ("op ~~") and
  equiv ("(_/ ~~ _)" [51, 51] 50)

notation (xsymbols)
  equiv ("op \<approx>") and
  equiv ("(_/ \<approx> _)"  [51, 51] 50)

notation (HTML output)
  equiv ("op \<approx>") and
  equiv ("(_/ \<approx> _)"  [51, 51] 50)

lemma refl [iff]:
  "x \<approx> x"
  unfolding equiv_def by simp

lemma trans:
  "x \<approx> y \<Longrightarrow> y \<approx> z \<Longrightarrow> x \<approx> z"
  unfolding equiv_def by (auto intro: order_trans)

lemma antisym:
  "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x \<approx> y"
  unfolding equiv_def ..

lemma less_le: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> x \<approx> y"
  by (auto simp add: equiv_def less_le_not_le)

lemma le_less: "x \<le> y \<longleftrightarrow> x < y \<or> x \<approx> y"
  by (auto simp add: equiv_def less_le)

lemma le_imp_less_or_eq: "x \<le> y \<Longrightarrow> x < y \<or> x \<approx> y"
  by (simp add: less_le)

lemma less_imp_not_eq: "x < y \<Longrightarrow> x \<approx> y \<longleftrightarrow> False"
  by (simp add: less_le)

lemma less_imp_not_eq2: "x < y \<Longrightarrow> y \<approx> x \<longleftrightarrow> False"
  by (simp add: equiv_def less_le)

lemma neq_le_trans: "\<not> a \<approx> b \<Longrightarrow> a \<le> b \<Longrightarrow> a < b"
  by (simp add: less_le)

lemma le_neq_trans: "a \<le> b \<Longrightarrow> \<not> a \<approx> b \<Longrightarrow> a < b"
  by (simp add: less_le)

lemma antisym_conv: "y \<le> x \<Longrightarrow> x \<le> y \<longleftrightarrow> x \<approx> y"
  by (simp add: equiv_def)

end

end


theory Exercise7
  imports Main
begin

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

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

datatype instr =
  LOADI val |
  LOAD vname |
  ADD

type_synonym stack = "val list"

abbreviation hd2 :: "'a list \<Rightarrow> 'a" where
"hd2 xs \<equiv> hd (tl xs)"

abbreviation tl2 :: "'a list \<Rightarrow> 'a list" where
"tl2 xs \<equiv> tl (tl xs)"

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

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk" |
"exec (i#ins) s stk = exec ins s (exec1 i s stk)"

lemma exec_rev_app [simp]: "exec (a @ b) s stk = exec b s (exec a s stk)"
  apply (induction a s stk arbitrary: b rule: exec.induct)
   apply auto
  done

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (aexp.N n) = [(LOADI n)]" |
"comp (aexp.V v) = [(LOAD v)]" |
"comp (aexp.Plus a b) = (comp a) @ (comp b) @ [(ADD)]"

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
empty: "ok n [] n" |
loadi: "ok n ins n' ==> ok n (ins @ [(LOADI _)]) (n' + 1)" |
load: "ok n ins n' ==> ok n (ins @ [(LOAD _)]) (n' + 1)" |
add: "ok n ins (n' + 2) \<Longrightarrow> ok n (ins @ [(ADD)]) (n' + 1)"

lemma chg_impl_instructs: "ok n ins n' \<Longrightarrow> n \<noteq> n' \<Longrightarrow> ins \<noteq> []"
  apply (induction rule: ok.induct)
     apply simp_all
  done

lemma ok_app: "ok n2 b n3 \<Longrightarrow> ok n1 a n2 \<Longrightarrow> ok n1 (a @ b) n3"
  apply (induction rule: ok.induct)
     apply simp
    apply (metis append.assoc ok.loadi)
   apply (metis append.assoc ok.load)
  apply (metis append.assoc ok.add)
  done

theorem ok_predicts_depth: "
  ok n ins n'
  \<Longrightarrow> length stk = n
  \<Longrightarrow> length (exec ins s stk) = n'
"
  apply (induction rule: ok.induct)
     apply simp_all
  done

theorem comp_is_ok: "ok n (comp a) (n + 1)"
  apply (induction a arbitrary: n)
    apply (metis Groups.add_ac(2) append.left_neutral comp.simps(1) ok.simps plus_1_eq_Suc)
   apply (metis Groups.add_ac(2) append.left_neutral comp.simps(2) ok.simps plus_1_eq_Suc)
  apply (smt (verit, best) One_nat_def ab_semigroup_add_class.add_ac(1) comp.simps(3) numerals(2) ok.intros(4) ok_app plus_1_eq_Suc)
  done

end


(*  Title:      HOL/SET_Protocol/Message_SET.thy
    Author:     Giampaolo Bella
    Author:     Fabio Massacci
    Author:     Lawrence C Paulson
*)

section\<open>The Message Theory, Modified for SET\<close>

theory Message_SET
imports Main "~~/src/HOL/Library/Nat_Bijection"
begin

subsection\<open>General Lemmas\<close>

text\<open>Needed occasionally with \<open>spy_analz_tac\<close>, e.g. in
     \<open>analz_insert_Key_newK\<close>\<close>

lemma Un_absorb3 [simp] : "A \<union> (B \<union> A) = B \<union> A"
by blast

text\<open>Collapses redundant cases in the huge protocol proofs\<close>
lemmas disj_simps = disj_comms disj_left_absorb disj_assoc

text\<open>Effective with assumptions like @{term "K \<notin> range pubK"} and
   @{term "K \<notin> invKey`range pubK"}\<close>
lemma notin_image_iff: "(y \<notin> f`I) = (\<forall>i\<in>I. f i \<noteq> y)"
by blast

text\<open>Effective with the assumption @{term "KK \<subseteq> - (range(invKey o pubK))"}\<close>
lemma disjoint_image_iff: "(A <= - (f`I)) = (\<forall>i\<in>I. f i \<notin> A)"
by blast

type_synonym key = nat

consts
  all_symmetric :: bool        \<comment>\<open>true if all keys are symmetric\<close>
  invKey        :: "key=>key"  \<comment>\<open>inverse of a symmetric key\<close>

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric --> invKey = id"
    by (rule exI [of _ id], auto)

text\<open>The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa\<close>

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"

text\<open>Agents. We allow any number of certification authorities, cardholders
            merchants, and payment gateways.\<close>
datatype
  agent = CA nat | Cardholder nat | Merchant nat | PG nat | Spy

text\<open>Messages\<close>
datatype
     msg = Agent  agent     \<comment>\<open>Agent names\<close>
         | Number nat       \<comment>\<open>Ordinary integers, timestamps, ...\<close>
         | Nonce  nat       \<comment>\<open>Unguessable nonces\<close>
         | Pan    nat       \<comment>\<open>Unguessable Primary Account Numbers (??)\<close>
         | Key    key       \<comment>\<open>Crypto keys\<close>
         | Hash   msg       \<comment>\<open>Hashing\<close>
         | MPair  msg msg   \<comment>\<open>Compound messages\<close>
         | Crypt  key msg   \<comment>\<open>Encryption, public- or shared-key\<close>

(*Concrete syntax: messages appear as \<open>\<lbrace>A,B,NA\<rbrace>\<close>, etc...*)
syntax
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2\<lbrace>_,/ _\<rbrace>)")
translations
  "\<lbrace>x, y, z\<rbrace>"   == "\<lbrace>x, \<lbrace>y, z\<rbrace>\<rbrace>"
  "\<lbrace>x, y\<rbrace>"      == "CONST MPair x y"

definition nat_of_agent :: "agent => nat" where
   "nat_of_agent == case_agent (curry prod_encode 0)
                               (curry prod_encode 1)
                               (curry prod_encode 2)
                               (curry prod_encode 3)
                               (prod_encode (4,0))"
    \<comment>\<open>maps each agent to a unique natural number, for specifications\<close>

text\<open>The function is indeed injective\<close>
lemma inj_nat_of_agent: "inj nat_of_agent"
by (simp add: nat_of_agent_def inj_on_def curry_def prod_encode_eq split: agent.split)

definition
  (*Keys useful to decrypt elements of a message set*)
  keysFor :: "msg set => key set"
  where "keysFor H = invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsubsection\<open>Inductive definition of all "parts" of a message.\<close>

inductive_set
  parts :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro]:               "X \<in> H ==> X \<in> parts H"
  | Fst:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> X \<in> parts H"
  | Snd:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

(*Monotonicity*)
lemma parts_mono: "G<=H ==> parts(G) <= parts(H)"
apply auto
apply (erule parts.induct)
apply (auto dest: Fst Snd Body)
done

subsubsection\<open>Inverse of keys\<close>

(*Equations hold because constructors are injective; cannot prove for all f*)
lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
by auto

lemma Nonce_Key_image_eq [simp]: "(Nonce x \<notin> Key`A)"
by auto

lemma Cardholder_image_eq [simp]: "(Cardholder x \<in> Cardholder`A) = (x \<in> A)"
by auto

lemma CA_image_eq [simp]: "(CA x \<in> CA`A) = (x \<in> A)"
by auto

lemma Pan_image_eq [simp]: "(Pan x \<in> Pan`A) = (x \<in> A)"
by auto

lemma Pan_Key_image_eq [simp]: "(Pan x \<notin> Key`A)"
by auto

lemma Nonce_Pan_image_eq [simp]: "(Nonce x \<notin> Pan`A)"
by auto

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K=K')"
apply safe
apply (drule_tac f = invKey in arg_cong, simp)
done

subsection\<open>keysFor operator\<close>

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

(*Monotonicity*)
lemma keysFor_mono: "G\<subseteq>H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Pan [simp]: "keysFor (insert (Pan A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert \<lbrace>X,Y\<rbrace> H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection\<open>Inductive relation "parts"\<close>

lemma MPair_parts:
     "[| \<lbrace>X,Y\<rbrace> \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!]  parts.Body [dest!]
text\<open>NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  \<open>MPair_parts\<close> is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.\<close>

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct, blast+)
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

(*WARNING: loops if H = {Y}, therefore must not be repeated!*)
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
by (erule parts.induct, fast+)

subsubsection\<open>Unions\<close>

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
apply (subst insert_is_Un [of _ H])
apply (simp only: parts_Un)
done

(*TWO inserts to avoid looping.  This rewrite is better than nothing.
  Not suitable for Addsimps: its behaviour can be strange.*)
lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
apply (simp add: Un_assoc)
apply (simp add: parts_insert [symmetric])
done

lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)

lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_UN [simp]: "parts(\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts(H x))"
by (intro equalityI parts_UN_subset1 parts_UN_subset2)

(*Added to simplify arguments to parts, analz and synth.
  NOTE: the UN versions are no longer used!*)

text\<open>This allows \<open>blast\<close> to simplify occurrences of
  @{term "parts(G\<union>H)"} in the assumption.\<close>
declare parts_Un [THEN equalityD1, THEN subsetD, THEN UnE, elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (drule parts_mono, blast)

(*Cut*)
lemma parts_cut:
     "[| Y\<in> parts (insert X G);  X\<in> parts H |] ==> Y\<in> parts (G \<union> H)"
by (erule parts_trans, auto)

lemma parts_cut_eq [simp]: "X\<in> parts H ==> parts (insert X H) = parts H"
by (force dest!: parts_cut intro: parts_insertI)

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Number [simp]:
     "parts (insert (Number N) H) = insert (Number N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Pan [simp]:
     "parts (insert (Pan A) H) = insert (Pan A) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Hash [simp]:
     "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) =
          insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (erule parts.induct)
apply (blast intro: parts.Body)+
done

lemma parts_insert_MPair [simp]:
     "parts (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (erule parts.induct)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
apply auto
apply (erule parts.induct, auto)
done

lemma parts_image_Pan [simp]: "parts (Pan`A) = Pan`A"
apply auto
apply (erule parts.induct, auto)
done

(*In any message, there is an upper bound N on its greatest nonce.*)
lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n --> Nonce n \<notin> parts {msg}"
apply (induct_tac "msg")
apply (simp_all (no_asm_simp) add: exI parts_insert2)
(*MPair case: blast_tac works out the necessary sum itself!*)
prefer 2 apply (blast elim!: add_leE)
(*Nonce case*)
apply (rename_tac nat)
apply (rule_tac x = "N + Suc nat" in exI)
apply (auto elim!: add_leE)
done

(* Ditto, for numbers.*)
lemma msg_Number_supply: "\<exists>N. \<forall>n. N<=n --> Number n \<notin> parts {msg}"
apply (induct_tac "msg")
apply (simp_all (no_asm_simp) add: exI parts_insert2)
prefer 2 apply (blast elim!: add_leE)
apply (rename_tac nat)
apply (rule_tac x = "N + Suc nat" in exI, auto)
done

subsection\<open>Inductive relation "analz"\<close>

text\<open>Inductive definition of "analz" -- what can be broken down from a set of
    messages, including keys.  A form of downward closure.  Pairs can
    be taken apart; messages decrypted with known keys.\<close>

inductive_set
  analz :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] :    "X \<in> H ==> X \<in> analz H"
  | Fst:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> X \<in> analz H"
  | Snd:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "[|Crypt K X \<in> analz H; Key(invKey K): analz H|] ==> X \<in> analz H"

(*Monotonicity; Lemma 1 of Lowe's paper*)
lemma analz_mono: "G<=H ==> analz(G) <= analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: Fst Snd)
done

text\<open>Making it safe speeds up proofs\<close>
lemma MPair_analz [elim!]:
     "[| \<lbrace>X,Y\<rbrace> \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
apply (rule equalityI)
apply (rule analz_subset_parts [THEN parts_mono, THEN subset_trans], simp)
apply (blast intro: analz_increasing [THEN parts_mono, THEN subsetD])
done

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection\<open>General equational properties\<close>

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

(*Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other*)
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Number [simp]:
     "analz (insert (Number N) H) = insert (Number N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Hash [simp]:
     "analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

(*Can only pull out Keys if they are not needed to decrypt the rest*)
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

(*Can pull out enCrypted message if the Key is not known*)
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Pan [simp]:
     "analz (insert (Pan A) H) = insert (Pan A) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

(*Case analysis: either the message is secure, or it is not!
  Effective, but can cause subgoals to blow up!
  Use with if_split;  apparently split_tac does not cope with patterns
  such as "analz (insert (Crypt K X) H)" *)
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

(*This rule supposes "for the sake of argument" that we have the key.*)
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

lemma analz_image_Pan [simp]: "analz (Pan`A) = Pan`A"
apply auto
apply (erule analz.induct, auto)
done

subsubsection\<open>Idempotence and transitivity\<close>

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

(*Cut; Lemma 2 of Lowe*)
lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (erule analz_trans, blast)

(*Cut can be proved easily by induction on
   "Y: analz (insert X H) ==> X: analz H --> Y: analz H"
*)

(*This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated. *)
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI)

text\<open>A congruence rule for "analz"\<close>

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H'
               |] ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
apply clarify
apply (erule analz.induct)
apply (best intro: analz_mono [THEN subsetD])+
done

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H'
               |] ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

(*If there are no pairs or encryptions then analz does nothing*)
lemma analz_trivial:
     "[| \<forall>X Y. \<lbrace>X,Y\<rbrace> \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

(*These two are obsolete (with a single Spy) but cost little to prove...*)
lemma analz_UN_analz_lemma:
     "X\<in> analz (\<Union>i\<in>A. analz (H i)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
done

lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])

subsection\<open>Inductive relation "synth"\<close>

text\<open>Inductive definition of "synth" -- what can be built up from a set of
    messages.  A form of upward closure.  Pairs can be built, messages
    encrypted with known keys.  Agent names are public domain.
    Numbers can be guessed, but Nonces cannot be.\<close>

inductive_set
  synth :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | Number [intro]:   "Number n  \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H ==> Hash X \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> \<lbrace>X,Y\<rbrace> \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

(*Monotonicity*)
lemma synth_mono: "G<=H ==> synth(G) <= synth(H)"
apply auto
apply (erule synth.induct)
apply (auto dest: Fst Snd Body)
done

(*NO Agent_synth, as any Agent name can be synthesized.  Ditto for Number*)
inductive_cases Nonce_synth [elim!]: "Nonce n \<in> synth H"
inductive_cases Key_synth   [elim!]: "Key K \<in> synth H"
inductive_cases Hash_synth  [elim!]: "Hash X \<in> synth H"
inductive_cases MPair_synth [elim!]: "\<lbrace>X,Y\<rbrace> \<in> synth H"
inductive_cases Crypt_synth [elim!]: "Crypt K X \<in> synth H"
inductive_cases Pan_synth   [elim!]: "Pan A \<in> synth H"

lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection\<open>Unions\<close>

(*Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.*)
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, blast+)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

(*Cut; Lemma 2 of Lowe*)
lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (erule synth_trans, blast)

lemma Agent_synth [simp]: "Agent A \<in> synth H"
by blast

lemma Number_synth [simp]: "Number n \<in> synth H"
by blast

lemma Nonce_synth_eq [simp]: "(Nonce N \<in> synth H) = (Nonce N \<in> H)"
by blast

lemma Crypt_synth_eq [simp]: "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma Pan_synth_eq [simp]: "(Pan A \<in> synth H) = (Pan A \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection\<open>Combinations of parts, analz and synth\<close>

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD]
                    parts.Fst parts.Snd parts.Body)+
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
prefer 5 apply (blast intro: analz_mono [THEN [2] rev_subsetD])
apply (blast intro: analz.Fst analz.Snd analz.Decrypt)+
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
apply (cut_tac H = "{}" in analz_synth_Un)
apply (simp (no_asm_use))
done

subsubsection\<open>For reasoning about the Fake rule in traces\<close>

lemma parts_insert_subset_Un: "X\<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (rule subset_trans [OF parts_mono parts_Un_subset2], blast)

(*More specifically for Fake.  Very occasionally we could do with a version
  of the form  parts{X} \<subseteq> synth (analz H) \<union> parts H *)
lemma Fake_parts_insert: "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
apply (drule parts_insert_subset_Un)
apply (simp (no_asm_use))
apply blast
done

lemma Fake_parts_insert_in_Un:
     "[|Z \<in> parts (insert X H);  X: synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (blast dest: Fake_parts_insert [THEN subsetD, dest])

(*H is sometimes (Key ` KK \<union> spies evs), so can't put G=H*)
lemma Fake_analz_insert:
     "X\<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H) ")
prefer 2 apply (blast intro: analz_mono [THEN [2] rev_subsetD] analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
apply (simp (no_asm_use))
apply blast
done

lemma analz_conj_parts [simp]:
     "(X \<in> analz H & X \<in> parts H) = (X \<in> analz H)"
by (blast intro: analz_subset_parts [THEN subsetD])

lemma analz_disj_parts [simp]:
     "(X \<in> analz H | X \<in> parts H) = (X \<in> parts H)"
by (blast intro: analz_subset_parts [THEN subsetD])

(*Without this equation, other rules for synth and analz would yield
  redundant cases*)
lemma MPair_synth_analz [iff]:
     "(\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) =
      (X \<in> synth (analz H) & Y \<in> synth (analz H))"
by blast

lemma Crypt_synth_analz:
     "[| Key K \<in> analz H;  Key (invKey K) \<in> analz H |]
       ==> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast

lemma Hash_synth_analz [simp]:
     "X \<notin> synth (analz H)
      ==> (Hash\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) = (Hash\<lbrace>X,Y\<rbrace> \<in> analz H)"
by blast

(*We do NOT want Crypt... messages broken up in protocols!!*)
declare parts.Body [rule del]

text\<open>Rewrites to push in Key and Crypt messages, so that other messages can
    be pulled out using the \<open>analz_insert\<close> rules\<close>

lemmas pushKeys =
  insert_commute [of "Key K" "Agent C"]
  insert_commute [of "Key K" "Nonce N"]
  insert_commute [of "Key K" "Number N"]
  insert_commute [of "Key K" "Pan PAN"]
  insert_commute [of "Key K" "Hash X"]
  insert_commute [of "Key K" "MPair X Y"]
  insert_commute [of "Key K" "Crypt X K'"]
  for K C N PAN X Y K'

lemmas pushCrypts =
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Nonce N"]
  insert_commute [of "Crypt X K" "Number N"]
  insert_commute [of "Crypt X K" "Pan PAN"]
  insert_commute [of "Crypt X K" "Hash X'"]
  insert_commute [of "Crypt X K" "MPair X' Y"]
  for X K C N PAN X' Y

text\<open>Cannot be added with \<open>[simp]\<close> -- messages should not always be
  re-ordered.\<close>
lemmas pushes = pushKeys pushCrypts

subsection\<open>Tactics useful for many protocol proofs\<close>
(*<*)
ML
\<open>
(*Analysis of Fake cases.  Also works for messages that forward unknown parts,
  but this application is no longer necessary if analz_insert_eq is used.
  DEPENDS UPON "X" REFERRING TO THE FRADULENT MESSAGE *)

fun impOfSubs th = th RSN (2, @{thm rev_subsetD})

(*Apply rules to break down assumptions of the form
  Y \<in> parts(insert X H)  and  Y \<in> analz(insert X H)
*)
fun Fake_insert_tac ctxt =
    dresolve_tac ctxt [impOfSubs @{thm Fake_analz_insert},
                  impOfSubs @{thm Fake_parts_insert}] THEN'
    eresolve_tac ctxt [asm_rl, @{thm synth.Inj}];

fun Fake_insert_simp_tac ctxt i =
  REPEAT (Fake_insert_tac ctxt i) THEN asm_full_simp_tac ctxt i;

fun atomic_spy_analz_tac ctxt =
  SELECT_GOAL
    (Fake_insert_simp_tac ctxt 1 THEN
      IF_UNSOLVED
        (Blast.depth_tac (ctxt addIs [@{thm analz_insertI},
            impOfSubs @{thm analz_subset_parts}]) 4 1));

fun spy_analz_tac ctxt i =
  DETERM
   (SELECT_GOAL
     (EVERY
      [  (*push in occurrences of X...*)
       (REPEAT o CHANGED)
         (Rule_Insts.res_inst_tac ctxt [((("x", 1), Position.none), "X")] []
          (insert_commute RS ssubst) 1),
       (*...allowing further simplifications*)
       simp_tac ctxt 1,
       REPEAT (FIRSTGOAL (resolve_tac ctxt [allI,impI,notI,conjI,iffI])),
       DEPTH_SOLVE (atomic_spy_analz_tac ctxt 1)]) i);
\<close>
(*>*)

(*By default only o_apply is built-in.  But in the presence of eta-expansion
  this means that some terms displayed as (f o g) will be rewritten, and others
  will not!*)
declare o_def [simp]

lemma Crypt_notin_image_Key [simp]: "Crypt K X \<notin> Key ` A"
by auto

lemma Hash_notin_image_Key [simp] :"Hash X \<notin> Key ` A"
by auto

lemma synth_analz_mono: "G<=H ==> synth (analz(G)) <= synth (analz(H))"
by (simp add: synth_mono analz_mono)

lemma Fake_analz_eq [simp]:
     "X \<in> synth(analz H) ==> synth (analz (insert X H)) = synth (analz H)"
apply (drule Fake_analz_insert[of _ _ "H"])
apply (simp add: synth_increasing[THEN Un_absorb2])
apply (drule synth_mono)
apply (simp add: synth_idem)
apply (blast intro: synth_analz_mono [THEN [2] rev_subsetD])
done

text\<open>Two generalizations of \<open>analz_insert_eq\<close>\<close>
lemma gen_analz_insert_eq [rule_format]:
     "X \<in> analz H ==> ALL G. H \<subseteq> G --> analz (insert X G) = analz G"
by (blast intro: analz_cut analz_insertI analz_mono [THEN [2] rev_subsetD])

lemma synth_analz_insert_eq [rule_format]:
     "X \<in> synth (analz H)
      ==> ALL G. H \<subseteq> G --> (Key K \<in> analz (insert X G)) = (Key K \<in> analz G)"
apply (erule synth.induct)
apply (simp_all add: gen_analz_insert_eq subset_trans [OF _ subset_insertI])
done

lemma Fake_parts_sing:
     "X \<in> synth (analz H) ==> parts{X} \<subseteq> synth (analz H) \<union> parts H"
apply (rule subset_trans)
 apply (erule_tac [2] Fake_parts_insert)
apply (simp add: parts_mono)
done

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

method_setup spy_analz = \<open>
    Scan.succeed (SIMPLE_METHOD' o spy_analz_tac)\<close>
    "for proving the Fake case when analz is involved"

method_setup atomic_spy_analz = \<open>
    Scan.succeed (SIMPLE_METHOD' o atomic_spy_analz_tac)\<close>
    "for debugging spy_analz"

method_setup Fake_insert_simp = \<open>
    Scan.succeed (SIMPLE_METHOD' o Fake_insert_simp_tac)\<close>
    "for debugging spy_analz"

end


section \<open> Differential Equations and their Solutions \<close>

theory utp_differential
  imports utp_hyrel
begin

type_synonym 'c ODE = "real \<Rightarrow> 'c \<Rightarrow> 'c"

text \<open> An ordinary differential equation, @{typ "'c ODE"} is Isabelle is specified as a function
  from a real number, denoting the present time, and the continuous state @{typ "'c"} to the
  continuous state. Intuitively, the input @{typ "'c"} is the present value of the continuous
  variables, and that output @{typ "'c"} gives the derivative, that is the rate at which
  the continuous state is changing. For example, the ODE $\dot{x} = 5 \cdot x$, which states
  that $x$ is changing at a rate of $5 \cdot x$, is written in Isabelle as
  @{term "\<lambda> (t::real) (x::real). 5 * x"}. Of course we can only quantify this for certain kinds of
  type @{typ "'c"} and so we will usually require that @{typ "'c"} is a vector of real numbers,
  or some isomorphic structure. For more information on ODEs in Isabelle, please see~\cite{Immler2012}
  for a paper on an Isabelle analysis library for ODEs that this work depends on.
  \<close>

abbreviation hasDerivAtBefore ::
  "(real \<Rightarrow> 'a :: real_normed_vector, '\<alpha>) uexpr \<Rightarrow>
   ('a, '\<alpha>) uexpr \<Rightarrow>
   (real, '\<alpha>) uexpr \<Rightarrow>
   (real, '\<alpha>) uexpr \<Rightarrow>
   '\<alpha> upred" ("_ has-deriv _ at _ < _" [90, 0, 0, 91] 90) where
"hasDerivAtBefore \<equiv> qtop (\<lambda> f f' t l. (f has_vector_derivative f') (at t within {0..l}))"

abbreviation hasDerivAll ::
  "(real \<Rightarrow> 'a::real_normed_vector, 'd, 'c::t2_space) hyexpr \<Rightarrow>
  (real \<Rightarrow> 'a, 'd, 'c) hyexpr \<Rightarrow> ('d,'c) hyrel" ("_ has-vderiv _" [90, 91] 90) where
"hasDerivAll \<equiv> trop (\<lambda> l f f'. (f has_vderiv_on f') ({0..l})) \<^bold>l"

translations
  "x has-vderiv y" <=
  "CONST trop (\<lambda>l f f'. CONST Vector_Derivative_On.has_vderiv_on f1 f1' {0..l2}) \<^bold>l x y"

abbreviation hasOdeDerivAt ::
  "((real \<Rightarrow> 'c :: real_normed_vector), '\<alpha>) uexpr \<Rightarrow>
   ('c ODE, '\<alpha>) uexpr \<Rightarrow>
   (real, '\<alpha>) uexpr \<Rightarrow>
   (real, '\<alpha>) uexpr \<Rightarrow> '\<alpha> upred" ("_ has-ode-deriv _ at _ < _" [90, 0, 0, 91] 90)
where "hasOdeDerivAt \<F> \<F>' \<tau> l \<equiv>
       qtop (\<lambda> \<F> \<F>' \<tau> l. (\<F> has_vector_derivative \<F>' \<tau> (\<F> \<tau>)) (at \<tau> within {0..l})) \<F> \<F>' \<tau> l"

definition lensHasDeriv ::
  "('a::real_normed_vector \<Longrightarrow> 'c::topological_space) \<Rightarrow> (real \<Rightarrow> ('a, 'c) uexpr) \<Rightarrow> ('d, 'c) hyrel" where
[upred_defs]: "lensHasDeriv x f = ($tr <\<^sub>u $tr\<acute> \<and> (\<^bold>\<forall> t \<in> {0..<\<^bold>l}\<^sub>u \<bullet> x~ has-deriv \<lceil>f(t)\<rceil>\<^sub>> @\<^sub>u t at \<guillemotleft>t\<guillemotright> < \<^bold>l))"

syntax
  "_has_der" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_ has-der _" [90, 91] 90)

translations
  "_has_der a f" => "CONST lensHasDeriv a (\<lambda> _time_var. f)"
  "_has_der a f" <= "CONST lensHasDeriv a (\<lambda> t. f)"

lemma lensHasDeriv_RR_closed [closure]: "(x has-der v(ti)) is RR"
  by (rel_auto)

lemma unrest_st'_lensHasDeriv [unrest]: "$st\<acute> \<sharp> (x has-der v(ti))"
  by (rel_auto)

text \<open> We introduce the notation @{term "\<F> has-ode-deriv \<F>' at t < \<tau>"} to mean that the derivative
  of a function @{term "\<F>"} is given by the ODE @{term "\<F>'"} at a point $t$ in the time domain
  $[0,\tau]$. Note, that unlike for our hybrid relational calculus we deal with ODEs over closed
  intervals; the final value at $\tau$ will correspond to the after value of the continuous
  state and justify that our timed trace is piecewise convergent. \<close>

definition hODE ::
  "('a::ordered_euclidean_space \<Longrightarrow> 'c::t2_space) \<Rightarrow>
   'a ODE \<Rightarrow> ('d, 'c) hyrel" where
[urel_defs]: "hODE x \<F>' = (\<^bold>\<exists> (\<F>, l) \<bullet> \<guillemotleft>l\<guillemotright> =\<^sub>u \<^bold>l \<and> ll(x) \<and> $tr <\<^sub>u $tr\<acute> \<and> \<lceil> \<guillemotleft>\<F>\<guillemotright> has-ode-deriv \<guillemotleft>\<F>'\<guillemotright> at \<guillemotleft>ti\<guillemotright> < \<guillemotleft>l\<guillemotright> \<and> $x\<acute> =\<^sub>u \<guillemotleft>\<F>\<guillemotright>(\<guillemotleft>ti\<guillemotright>)\<^sub>a \<rceil>\<^sub>h)"

syntax
  "_hODE" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<langle>_ \<bullet> _\<rangle>\<^sub>h")

translations
  "_hODE a P" => "CONST hODE a (\<lambda> _time_var. P)"
  "_hODE a P" <= "CONST hODE a (\<lambda> t. P)"

lemma hODE_RR_closed [closure]: "\<langle>x \<bullet> F(ti)\<rangle>\<^sub>h is RR"
  by (rel_auto)

lemma hODE_unrests [unrest]:
  "$ok \<sharp> \<langle>x \<bullet> F(ti)\<rangle>\<^sub>h" "$ok\<acute> \<sharp> \<langle>x \<bullet> F(ti)\<rangle>\<^sub>h"
  "$wait \<sharp> \<langle>x \<bullet> F(ti)\<rangle>\<^sub>h" "$wait\<acute> \<sharp> \<langle>x \<bullet> F(ti)\<rangle>\<^sub>h"
  "$st\<acute> \<sharp> \<langle>x \<bullet> F(ti)\<rangle>\<^sub>h"
  by (rel_auto)+

text \<open> We next introduce the construct @{term "\<langle>x \<bullet> \<F>'\<rangle>\<^sub>h"}, which states that continuous state lens
  $x$ evolves according the ODE described by @{term "\<F>'"}. The lens $x$ identifies a portion of
  the continuous state; that is it is not necessary that this construct define evolution for
  all continuous variables, only those specified. The others will evolve arbitrarily. The definition states that there is a function
  @{term "\<F>"} and evolution length @{term "l"}, such that at each instant $\tau$ in the time
  domain, @{term "\<F>'"} is the derivative @{term "\<F>"} and the continuous state $x$ is given by
  @{term "\<F>"}. Function @{term "\<F>"} is thus the solution of the ODE, and the definition states
  that such a solution exists. This actually may not always be the case, and if not such solution
  exists then the predicate will have the value @{term "false"}, the miraculous program. Note
  that since we use the hybrid interval operator here, the ODE will automatically pick up its
  initial value from the before value of $x$; thus an initial value problem is posed by this
  construct. Moreover, the final value of $x$ will be the value that the ODE tends toward at
  the limit, which is always defined as per our previous definition. \<close>

abbreviation hODE_IVP ("\<langle>_ := _ \<bullet> _\<rangle>\<^sub>h") where
"\<langle>x := x\<^sub>0 \<bullet> \<F>'\<rangle>\<^sub>h \<equiv> (st:\<^bold>c:x := x\<^sub>0 ;; \<langle>x \<bullet> \<F>'\<rangle>\<^sub>h)"

text \<open> We also set up notation that explicitly sets up the initial value for the continuous state,
  @{term "\<langle>x := x\<^sub>0 \<bullet> \<F>'\<rangle>\<^sub>h"}, which states that the initial value of @{term "x"} in the ODE
  @{term "\<F>'"} takes its value from @{term "x\<^sub>0"}. We next prove some important theorems about
  solutions to ODEs. \<close>

abbreviation hODE_frame ::
  "('a::ordered_euclidean_space \<Longrightarrow> 'c::t2_space) \<Rightarrow>
   'a ODE \<Rightarrow> ('d, 'c) hyrel" where
"hODE_frame x \<F>' \<equiv> hFrame x (hODE x \<F>')"

syntax
  "_hODE_frame" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<langle>_ : _\<rangle>\<^sub>h")

translations
  "_hODE_frame a P" => "CONST hODE_frame a (\<lambda> _time_var. P)"
  "_hODE_frame a P" <= "CONST hODE_frame a (\<lambda> t. P)"

text \<open> ODEs can also have a frame attached, which the above operator provides. It implicitly
  contains the assumption that all variables not mentioned in the ODE are held constant
  during evolution. \<close>

lemma at_has_deriv [simp]:
  "(f has-ode-deriv f' at ti < l) @\<^sub>u t = (f @\<^sub>u t) has-ode-deriv (f' @\<^sub>u t) at (ti @\<^sub>u t) < (l @\<^sub>u t)"
  by (simp add: at_def usubst alpha)

lemma at_within_closed_open:
  "\<lbrakk> 0 \<le> (t::real); t < l \<rbrakk> \<Longrightarrow> (at t within {0..l}) = (at t within {0..<l})"
  by (rule at_within_nhd[where S="{..<l}"], auto)

lemma hODE_as_has_der:
  assumes "vwb_lens x"
  shows "hODE x F' = (ll(x) \<and> x has-der \<guillemotleft>F' ti\<guillemotright>(&x)\<^sub>a)"
proof (rule antisym)
  show "hODE x F' \<sqsubseteq> (ll(x) \<and> x has-der \<guillemotleft>F' ti\<guillemotright>(&x)\<^sub>a)"
    by (rel_simp, metis tt_apply_minus)
  show "(ll(x) \<and> x has-der \<guillemotleft>F' ti\<guillemotright>(&x)\<^sub>a) \<sqsubseteq> hODE x F'"
  proof (rel_simp)
    fix tr b tr' t F
    assume a:
       "get\<^bsub>x\<^esub> b = get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(end\<^sub>t tr))" "tr < tr'"
       "\<forall>t. 0 \<le> t \<and> t < end\<^sub>t (tr' - tr) \<longrightarrow>
            (F has_vector_derivative F' t (F t)) (at t within {0..end\<^sub>t (tr' - tr)}) \<and> get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr)) = F t"
       "0 \<le> t" "t < end\<^sub>t (tr' - tr)"

    from a(3) have b: "\<And> t. t \<in> {0..<end\<^sub>t (tr' - tr)} \<Longrightarrow> F(t) = get\<^bsub>x\<^esub> (\<langle>tr' - tr\<rangle>\<^sub>t(t))"
      apply (auto)
      apply (drule_tac x="t" in spec)
      apply (simp)
      using a(2) apply auto
    done

    have c: "(F has_vector_derivative F' t (F t)) (at t within {0..<end\<^sub>t (tr' - tr)})" (is "?P")
      using a(3) a(4) a(5) at_within_closed_open by auto

    let ?G = "(\<lambda>t. get\<^bsub>x\<^esub> (\<langle>tr' - tr\<rangle>\<^sub>t(t)))"

    from a(4,5) b have "?P \<longleftrightarrow> (?G has_vector_derivative F' t (F t)) (at t within {0..<end\<^sub>t (tr' - tr)})"
      by (rule_tac has_vector_derivative_cong_ev, auto)

    with a(4,5) c show "(?G has_vector_derivative F' t (F t)) (at t within {0..end\<^sub>t (tr' - tr)})"
      by (simp add: at_within_closed_open)
  qed
qed

lemma ode_to_ivp:
  "vwb_lens x \<Longrightarrow> \<langle>x \<bullet> \<F>'\<rangle>\<^sub>h = (\<^bold>\<exists> x\<^sub>0 \<bullet> \<guillemotleft>x\<^sub>0\<guillemotright> =\<^sub>u $st:\<^bold>c:x \<and> \<langle>x := \<guillemotleft>x\<^sub>0\<guillemotright> \<bullet> \<F>'\<rangle>\<^sub>h)"
  by (rel_auto)

lemma ode_solution_refine:
  "\<lbrakk> vwb_lens x;
     \<forall> x. \<forall> l > 0. (\<F>(x) usolves_ode \<F>' from 0) {0..l} UNIV;
     \<forall> x. \<F>(x)(0) = x \<rbrakk>
   \<Longrightarrow> \<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>h \<sqsubseteq> x \<leftarrow>\<^sub>h \<guillemotleft>\<F>\<guillemotright>($x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a"
  apply (rel_auto)
  apply (rename_tac tr b tr')
  apply (rule_tac x="\<F> (get\<^bsub>x\<^esub>b)" in exI)
  apply (auto simp add: usolves_ode_from_def solves_ode_def has_vderiv_on_def)[1]
done

lemma usolves_ode_subset:
  "\<lbrakk> (f usolves_ode f' from t\<^sub>0) T A; S \<subseteq> T; t\<^sub>0 \<in> S; is_interval S \<rbrakk> \<Longrightarrow> (f usolves_ode f' from t\<^sub>0) S A"
  apply (auto simp add: usolves_ode_from_def solves_ode_def has_vderiv_on_def)
  apply (meson has_vector_derivative_within_subset subset_iff)
  apply (meson dual_order.trans)
done

lemma ode_uniq_solution_refine:
  assumes
    "vwb_lens x" "\<forall> x. \<forall> l > 0. (\<F>(x) usolves_ode \<F>' from 0) {0..l} UNIV" "\<forall> x. \<F>(x)(0) = x"
  shows "x \<leftarrow>\<^sub>h \<guillemotleft>\<F>\<guillemotright>($x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a \<sqsubseteq> \<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>h"
proof (rel_simp)
  fix tr b tr' \<G> t

  assume a:
    "tr < tr'"
    "get\<^bsub>x\<^esub> b = get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t (end\<^sub>t tr))"
    "tr \<le> tr'"
    "\<forall>t. 0 \<le> t \<and> t < end\<^sub>t (tr' - tr) \<longrightarrow>
         (\<G> has_vector_derivative \<F>' t (\<G> t)) (at t within {0..end\<^sub>t (tr' - tr)}) \<and> get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr)) = \<G> t"
    "0 \<le> t" "t < end\<^sub>t (tr' - tr)"

  let ?l = "end\<^sub>t (tr' - tr)"

  have l_nz: "?l > 0"
    using a by linarith

  from assms a have F_sol:"(\<F> (get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(end\<^sub>t tr))) usolves_ode \<F>' from 0) {0..?l} UNIV"
    by auto

  have G_sol: "(\<G> solves_ode \<F>') {0..<?l} UNIV"
  proof (rule solves_odeI, simp_all)
    from a show "(\<G> has_vderiv_on (\<lambda>x. \<F>' x (\<G> x))) {0..<?l}"
      apply (auto intro: has_vector_derivative_within_subset simp add: has_vderiv_on_def)
      apply (rename_tac t')
      apply (drule_tac x="t'" in spec)
      apply (auto intro: has_vector_derivative_within_subset)
    done
  qed

  have G_init: "\<G> 0 = \<F> (get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(end\<^sub>t tr))) 0"
    using a(4) assms(3) l_nz by auto

  show "\<G> t = \<F> (get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(end\<^sub>t tr))) t"
    by (rule_tac usolves_odeD(4)[OF F_sol, of "{0..<end\<^sub>t (tr' - tr)}"], auto simp add: l_nz G_sol G_init a)
qed

theorem ode_solution:
  assumes
    "vwb_lens x" "\<forall> x. \<forall> l > 0. (\<F>(x) usolves_ode \<F>' from 0) {0..l} UNIV" "\<forall> x. \<F>(x)(0) = x"
  shows "\<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>h = x \<leftarrow>\<^sub>h \<guillemotleft>\<F>\<guillemotright>($x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a"
  using ode_solution_refine[of x \<F> \<F>'] ode_uniq_solution_refine[of x \<F> \<F>']
  by (auto intro: antisym simp add: assms)

theorem ode_solution':
  assumes
    "vwb_lens x"
    "\<And> x l. l > 0 \<Longrightarrow> (\<F>(x) usolves_ode \<F>' from 0) {0..l} UNIV"
    "\<And> x. \<F>(x)(0) = x"
  shows "\<langle>x \<bullet> \<F>'(ti)\<rangle>\<^sub>h = x \<leftarrow>\<^sub>h \<guillemotleft>\<F>\<guillemotright>($x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a"
  by (simp add: assms(1) assms(2) assms(3) ode_solution)

theorem ode_frame_solution:
  assumes
    "vwb_lens x"
    "\<And> x l. l > 0 \<Longrightarrow> (\<F>(x) usolves_ode \<F>' from 0) {0..l} UNIV"
    "\<And> x. \<F>(x)(0) = x"
  shows "\<langle>x : \<F>'(ti)\<rangle>\<^sub>h = {[x \<mapsto>\<^sub>s \<guillemotleft>\<F>\<guillemotright>(&x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a]}\<^sub>h"
proof -
  have "\<langle>x : \<F>'(ti)\<rangle>\<^sub>h = x:[x \<leftarrow>\<^sub>h \<guillemotleft>\<F>\<guillemotright>($x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a]\<^sub>h"
    by (simp add: ode_solution'[where \<F>=\<F>] assms)
  also from assms(1) have "... = (\<lceil>$x\<acute> =\<^sub>u \<guillemotleft>\<F>\<guillemotright>($x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a \<and> x:[true]\<rceil>\<^sub>h \<and> 0 <\<^sub>u \<^bold>l)"
    by (rel_auto)
  also from assms(1) have "... = (\<lceil>x:[$x\<acute> =\<^sub>u \<guillemotleft>\<F>\<guillemotright>($x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a]\<rceil>\<^sub>h \<and> 0 <\<^sub>u \<^bold>l)"
    by (simp add: frame_conj_true unrest)
  also have "... = (\<lceil>x:[$x\<acute> =\<^sub>u \<lceil>\<guillemotleft>\<F>\<guillemotright>(&x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a\<rceil>\<^sub><]\<rceil>\<^sub>h \<and> 0 <\<^sub>u \<^bold>l)"
    by (rel_auto)
  also from assms(1) have "... = {[x \<mapsto>\<^sub>s \<guillemotleft>\<F>\<guillemotright>(&x)\<^sub>a(\<guillemotleft>ti\<guillemotright>)\<^sub>a]}\<^sub>h"
    by (simp add: frame_is_assign hEvolves_def, rel_auto)
  finally show ?thesis .
qed

lemma uos_impl_uniq_sol:
  assumes "unique_on_strip t0 T f' L" "is_interval T"
  and "(f solves_ode f') T UNIV"
shows "(f usolves_ode f' from t0) T UNIV"
proof -
  interpret uos: unique_on_strip t0 T f' L
    by (simp add: assms)
  thm uos.solution_usolves_ode
  have "\<forall> t \<in> T. f t = uos.solution (f t0) t"
  proof (auto)
    fix t
    assume "t \<in> T"
    thus "f t = uos.solution (f t0) t"
      using usolves_odeD(4)[where T'="T" and z="f" and t="t", OF uos.solution_usolves_ode[of "f t0"]]
      by (simp add: assms)
  qed
  thus ?thesis
    using assms(3) uos.solution_usolves_ode usolves_ode_solves_odeI by blast
qed

text \<open> \emph{ode\_cert} is a simple tactic for certifying solutions to systems of differential equations \<close>

method ode_cert = (rule_tac solves_odeI, simp_all add: has_vderiv_on_def, safe intro!: has_vector_derivative_Pair, (rule has_vector_derivative_eq_rhs, (rule derivative_intros; (simp)?)+, simp)+)

text \<open> \emph{linear\_ode} certifies unique solutions for linears ODEs. \<close>

method linear_ode =
  (rule_tac uos_impl_uniq_sol[where L=1], (unfold_locales, auto intro!: continuous_on_Pair continuous_on_const Topological_Spaces.continuous_on_fst Topological_Spaces.continuous_on_snd continuous_on_snd simp add: lipschitz_on_def dist_Pair_Pair prod.case_eq_if)[1], (auto)[1], ode_cert)

text \<open> \emph{ode\_solve} tries to rewrite an ODE to a solution. The solution must be passed
  as a mandatory term parameter. \<close>

method ode_solve
  for sol :: "'a::ordered_euclidean_space \<Rightarrow> real \<Rightarrow> 'a"
  = ((subst ode_solution'[where \<F> = "sol"]; (simp add: prod.case_eq_if)?), linear_ode)

text \<open> Version of above with frame \<close>

method ode_fsolve
  for sol :: "'a::ordered_euclidean_space \<Rightarrow> real \<Rightarrow> 'a"
  = ((subst ode_frame_solution[where \<F> = "sol"]; (simp add: prod.case_eq_if)?), linear_ode)

text \<open> Example illustrating the relationship between derivative constrains and ordinary differential
  equations. If a variable has a constant derivative then this is equivalent to a trivial ODE. \<close>

lemma der_const_ode:
  assumes "vwb_lens x" "continuous_on UNIV get\<^bsub>x\<^esub>"
  shows "(ll(x) \<and> x has-der \<guillemotleft>n\<guillemotright>) = \<langle>x \<bullet> \<lambda> x. n\<rangle>\<^sub>h" (is "?lhs = ?rhs")
proof (rule antisym)
  show "?lhs \<sqsubseteq> ?rhs"
  proof (rel_simp)
    fix tr tr' f b t
    assume a:
      "get\<^bsub>x\<^esub> b = get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(end\<^sub>t tr))"
       "tr < tr'"
       "\<forall>t. 0 \<le> t \<and> t < end\<^sub>t (tr' - tr) \<longrightarrow>
             (f has_vector_derivative n) (at t within {0..end\<^sub>t (tr' - tr)}) \<and>
             get\<^bsub>x\<^esub> (\<langle>tr'\<rangle>\<^sub>t(t + end\<^sub>t tr)) = f t"
       "0 \<le> t" "t < end\<^sub>t (tr' - tr)"
    from a(3)
    have b: "(f has_vector_derivative n) (at t within {0..end\<^sub>t (tr' - tr)})"
      using a(4) a(5) by blast
    have c: "(\<And>t. t \<in> {0..<end\<^sub>t (tr' - tr)} \<Longrightarrow> f t = get\<^bsub>x\<^esub> (\<langle>tr'-tr\<rangle>\<^sub>tt))"
      by (simp add: a(2) a(3) dual_order.strict_implies_order)

    have "(f has_vector_derivative n) (at t within {0..<end\<^sub>t (tr' - tr)}) \<longleftrightarrow>
          ((\<lambda>t. get\<^bsub>x\<^esub> (\<langle>tr'-tr\<rangle>\<^sub>tt)) has_vector_derivative n) (at t within {0..<end\<^sub>t (tr' - tr)})"
      by (rule has_vector_derivative_cong_ev, simp_all add: a c)

    with b show "((\<lambda>t. get\<^bsub>x\<^esub> (\<langle>tr'-tr\<rangle>\<^sub>tt)) has_vector_derivative n) (at t within {0..end\<^sub>t (tr' - tr)})"
      using a(4) a(5) at_within_closed_open b by auto
  qed
  show "?rhs \<sqsubseteq> ?lhs"
    by (rel_auto)
qed

lemma hODE_conj:
  "(\<langle>x \<bullet> F'(ti)\<rangle>\<^sub>h \<and> \<langle>y \<bullet> G'(ti)\<rangle>\<^sub>h) = \<langle>{&x,&y} \<bullet> (\<lambda> (x, y). (F' ti x, G' ti y))\<rangle>\<^sub>h"
  apply (rel_auto)
    apply (rename_tac tr b tr' F G)
    apply (rule_tac x="\<lambda> t. (F t, G t)" in exI)
    apply (clarsimp)
    apply (rename_tac tr b tr' F G t)
    apply (drule_tac x="t" in spec)
    apply (simp)
    apply (drule_tac x="t" in spec)
        apply (simp)
  using Pair_has_vector_derivative apply blast
   apply (rename_tac tr b tr' FG)
   apply (rule_tac x="fst \<circ> FG" in exI)
   apply (clarsimp)
   apply (rename_tac tr b tr' FG t)
   apply (drule_tac x="t" in spec)
    apply (auto intro:derivative_intros)
   apply (metis fst_conv)
  apply (rename_tac tr b tr' FG)
   apply (rule_tac x="snd \<circ> FG" in exI)
   apply (clarsimp)
   apply (rename_tac tr b tr' FG t)
    apply (auto intro:derivative_intros)
  apply (metis snd_conv)
done

end