(*
Title: MoreGraph.thy
Author:Wenda Li, Fabian Hellauer removed valid_unMultigraph's second assumption and dependent results.
*)

theory MoreGraph_alt imports Complex_Main Dijkstra_Shortest_Path.Graph
begin
section \<open>Undirected Multigraph and undirected trails\<close>

locale valid_unMultigraph=valid_graph G for G::"('v,'w) graph"+
              assumes corres[simp]: "(v,w,u') \<in> edges G \<longleftrightarrow> (u',w,v) \<in> edges G"

fun (in valid_unMultigraph) is_trail :: "'v \<Rightarrow> ('v,'w) path \<Rightarrow> 'v \<Rightarrow> bool" where
      "is_trail v [] v' \<longleftrightarrow> v=v' \<and> v'\<in> V" |
      "is_trail v ((v1,w,v2)#ps) v' \<longleftrightarrow> v=v1 \<and> (v1,w,v2)\<in>E \<and>
                (v1,w,v2)\<notin>set ps \<and>(v2,w,v1)\<notin>set ps \<and> is_trail v2 ps v'"

(*This section mainly includes lemmas related to degrees of nodes, especially when edges and paths
are removed from an undirected graph*)
section \<open>Degrees and related properties\<close>

definition degree :: "'v \<Rightarrow> ('v,'w) graph \<Rightarrow> nat" where
    "degree v g\<equiv> card({e. e\<in>edges g \<and> fst e=v})"

definition odd_nodes_set :: "('v,'w) graph \<Rightarrow> 'v set" where
    "odd_nodes_set g \<equiv> {v. v\<in>nodes g \<and> odd(degree v g)}"

  (*return the number of nodes with an odd degree in the current valid multigraph*)
definition num_of_odd_nodes :: "('v, 'w) graph \<Rightarrow> nat" where
    "num_of_odd_nodes g\<equiv> card( odd_nodes_set g)"

definition num_of_even_nodes :: "('v, 'w) graph \<Rightarrow> nat" where
    "num_of_even_nodes g\<equiv> card( {v. v\<in>nodes g \<and> even(degree v g)})"

definition del_unEdge where "del_unEdge v e v' g \<equiv> \<lparr>
    nodes = nodes g, edges = edges g - {(v,e,v'),(v',e,v)} \<rparr>"

definition rev_path :: "('v,'w) path \<Rightarrow> ('v,'w) path" where
    "rev_path ps \<equiv> map (\<lambda>(a,b,c).(c,b,a)) (rev ps)"

fun rem_unPath:: "('v,'w) path \<Rightarrow> ('v,'w) graph \<Rightarrow> ('v,'w) graph" where
    "rem_unPath [] g= g"|
    "rem_unPath ((v,w,v')#ps) g=
        rem_unPath ps (del_unEdge v w v' g)"

lemma del_undirected: "del_unEdge v e v' g = delete_edge v' e v (delete_edge v e v' g)"
  unfolding del_unEdge_def delete_edge_def by auto

lemma delete_edge_sym: "del_unEdge v e v' g = del_unEdge v' e v g"
  unfolding del_unEdge_def by auto

lemma del_unEdge_valid[simp]: assumes "valid_unMultigraph g"
    shows "valid_unMultigraph (del_unEdge v e v' g)"
proof -
  interpret valid_unMultigraph g by fact
  show ?thesis
    unfolding del_unEdge_def
    by unfold_locales (auto dest: E_validD)
qed

lemma set_compre_diff:"{x \<in> A - B. P x}={x \<in> A. P x} - {x \<in> B . P x}" by blast
lemma set_compre_subset: "B \<subseteq> A \<Longrightarrow> {x \<in> B. P x} \<subseteq> {x \<in> A. P x}" by blast

lemma del_edge_undirected_degree_plus: "finite (edges g) \<Longrightarrow> (v,e,v') \<in> edges g
    \<Longrightarrow> (v',e,v) \<in> edges g  \<Longrightarrow> degree v (del_unEdge v e v' g) + 1=degree v g"
proof -
  assume assms: "finite (edges g)" "(v,e,v') \<in> edges g" "(v',e,v) \<in> edges g "
  have "degree v (del_unEdge v e v' g) + 1
          = card ({ea \<in>  edges g - {(v, e, v'), (v', e, v)}. fst ea = v}) + 1"
    unfolding del_unEdge_def degree_def by simp
  also have "...=card ({ea \<in>  edges g. fst ea = v} - {ea \<in> {(v, e, v'), (v', e, v)}.
      fst ea = v})+1"
    by (metis set_compre_diff)
  also have "...=card ({ea \<in>  edges g. fst ea = v}) - card({ea \<in> {(v, e, v'), (v', e, v)}.
      fst ea = v})+1"
    proof -
      have "{(v, e, v'), (v', e, v)} \<subseteq> edges g" using \<open>(v,e,v') \<in> edges g\<close> \<open>(v',e,v) \<in> edges g\<close>
        by auto
      hence "{ea \<in> {(v, e, v'), (v', e, v)}. fst ea = v} \<subseteq> {ea \<in>  edges g. fst ea = v}" by auto
      moreover have "finite {ea \<in> {(v, e, v'), (v', e, v)}. fst ea = v}" by auto
      ultimately have "card ({ea \<in> edges g. fst ea = v} - {ea \<in> {(v, e, v'), (v', e, v)}.
          fst ea = v})=card {ea \<in> edges g. fst ea = v} - card {ea \<in> {(v, e, v'), (v', e, v)}.
          fst ea = v}"
        using card_Diff_subset by blast
      thus ?thesis by auto
    qed
  also have "...=card ({ea \<in>  edges g. fst ea = v})"
    proof -
      have "{ea \<in> {(v, e, v'), (v', e, v)}. fst ea = v}={(v,e,v')}" by auto
      hence "card {ea \<in> {(v, e, v'), (v', e, v)}. fst ea = v} = 1" by auto
      moreover have "card {ea \<in> edges g. fst ea = v}\<noteq>0"
        by (metis (lifting, mono_tags) Collect_empty_eq assms(1) assms(2)
          card_eq_0_iff fst_conv mem_Collect_eq rev_finite_subset subsetI)
      ultimately show ?thesis by arith
    qed
  finally have "degree v (del_unEdge v e v' g) + 1=card ({ea \<in>  edges g. fst ea = v})" .
  thus ?thesis unfolding degree_def .
qed

lemma del_edge_undirected_degree_plus': "finite (edges g) \<Longrightarrow> (v,e,v') \<in> edges g
    \<Longrightarrow> (v',e,v) \<in> edges g \<Longrightarrow> degree v' (del_unEdge v e v' g) + 1=degree v' g"
  by (metis del_edge_undirected_degree_plus delete_edge_sym)

lemma del_edge_undirected_degree_minus[simp]: "finite (edges g) \<Longrightarrow> (v,e,v') \<in> edges g
    \<Longrightarrow> (v',e,v) \<in> edges g \<Longrightarrow> degree v (del_unEdge v e v' g) =degree v g- (1::nat)"
  using del_edge_undirected_degree_plus by (metis add_diff_cancel_left' add.commute)

lemma del_unEdge_com: "del_unEdge v w v' (del_unEdge n e n' g)
          = del_unEdge n e n' (del_unEdge v w v' g)"
  unfolding del_unEdge_def by auto

lemma rem_unPath_com: "rem_unPath ps (del_unEdge v w v' g)
            = del_unEdge v w v' (rem_unPath ps g)"
proof (induct ps arbitrary: g)
  case Nil
  thus ?case by (metis rem_unPath.simps(1))
next
  case (Cons a ps')
  thus ?case using del_unEdge_com
    by (metis prod_cases3 rem_unPath.simps(1) rem_unPath.simps(2))
qed

lemma rem_unPath_valid[intro]:
  "valid_unMultigraph g \<Longrightarrow> valid_unMultigraph (rem_unPath ps g)"
proof (induct ps )
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  thus ?case
    proof -
    have "valid_unMultigraph (rem_unPath (x # xs) g) = valid_unMultigraph
         (del_unEdge (fst x) (fst (snd x)) (snd (snd x)) (rem_unPath xs g))"
      using rem_unPath_com by (metis prod.collapse rem_unPath.simps(2))
    also have "...=valid_unMultigraph (rem_unPath xs g)"
      by (metis Cons.hyps Cons.prems del_unEdge_valid)
    also have "...=True"
      using Cons by auto
    finally have "?case=True" .
    thus ?case by simp
    qed
qed

lemma (in valid_unMultigraph) degree_frame:
    assumes "finite (edges G)"  "x \<notin> {v, v'}"
    shows "degree x (del_unEdge v w v' G) = degree x G" (is "?L=?R")
proof (cases "(v,w,v') \<in> edges G")
  case True
  have "?L=card({e. e\<in>edges G - {(v,w,v'),(v',w,v)} \<and> fst e=x})"
    by (simp add:del_unEdge_def degree_def)
  also have "...=card({e. e\<in>edges G \<and> fst e=x}-{e. e\<in>{(v,w,v'),(v',w,v)} \<and> fst e=x})"
    by (metis  set_compre_diff)
  also have "...=card({e. e\<in>edges G \<and> fst e=x})" using \<open>x \<notin> {v, v'}\<close>
    proof -
      have "x\<noteq>v \<and> x\<noteq> v'" using \<open>x\<notin>{v,v'}\<close>by simp
      hence "{e. e\<in>{(v,w,v'),(v',w,v)} \<and> fst e=x}={}" by auto
      thus ?thesis by (metis Diff_empty)
    qed
  also have "...=?R" by (simp add:degree_def)
  finally show ?thesis .
next
  case False
  moreover hence "(v',w,v)\<notin>E" using corres by auto
  ultimately have "E- {(v,w,v'),(v',w,v)}=E" by blast
  hence "del_unEdge v w v' G=G" by (auto simp add:del_unEdge_def)
  thus ?thesis by auto
qed

lemma del_UnEdge_node[simp]: "v\<in>nodes (del_unEdge u e u' G) \<longleftrightarrow> v\<in>nodes G  "
    by (metis del_unEdge_def select_convs(1))

lemma [intro!]: "finite (edges G) \<Longrightarrow> finite (edges (del_unEdge u e u' G))"
    by (metis del_unEdge_def finite_Diff select_convs(2))

lemma [intro!]: "finite (nodes G) \<Longrightarrow> finite (nodes (del_unEdge u e u' G))"
    by (metis del_unEdge_def select_convs(1))

lemma [intro!]: "finite (edges G) \<Longrightarrow> finite (edges (rem_unPath ps G))"
proof (induct ps arbitrary:G)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  hence "finite (edges (rem_unPath (x # xs) G)) = finite (edges (del_unEdge
          (fst x) (fst (snd x)) (snd (snd x)) (rem_unPath xs G)))"
    by (metis rem_unPath.simps(2) rem_unPath_com surjective_pairing)
  also have "...=finite (edges (rem_unPath xs G))"
    using del_unEdge_def
    by (metis  finite.emptyI finite_Diff2 finite_Diff_insert select_convs(2))
  also have "...=True" using Cons by auto
  finally have "?case = True" .
  thus ?case by simp
qed

lemma del_UnEdge_frame[intro]:
  "x\<in>edges g \<Longrightarrow> x\<noteq>(v,e,v') \<Longrightarrow>x\<noteq>(v',e,v) \<Longrightarrow> x\<in>edges (del_unEdge v e v' g)"
  unfolding del_unEdge_def by auto

lemma [intro!]: "finite (nodes G) \<Longrightarrow> finite (odd_nodes_set G)"
    by (metis (lifting) mem_Collect_eq odd_nodes_set_def rev_finite_subset subsetI)

lemma [simp]: "nodes (del_unEdge u e u' G)=nodes G"
    by (metis del_unEdge_def select_convs(1))

lemma [simp]: "nodes (rem_unPath ps G) = nodes G"
proof (induct ps)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  have "nodes (rem_unPath (x # xs) G)=nodes (del_unEdge
        (fst x) (fst (snd x)) (snd (snd x)) (rem_unPath xs G))"
    by (metis rem_unPath.simps(2) rem_unPath_com surjective_pairing)
  also have "...=nodes (rem_unPath xs G)" by auto
  also have "...=nodes G" using Cons by auto
  finally show ?case .
qed

lemma [intro!]: "finite (nodes G) \<Longrightarrow> finite (nodes (rem_unPath ps G))" by auto

lemma in_set_rev_path[simp]: "(v',w,v )\<in>set (rev_path ps) \<longleftrightarrow> (v,w,v')\<in>set ps "
proof (induct ps)
  case Nil
  thus ?case unfolding rev_path_def by auto
next
  case (Cons x xs)
  obtain x1 x2 x3 where x:"x=(x1,x2,x3)" by (metis prod_cases3)
  have "set (rev_path (x # xs))=set ((rev_path xs)@[(x3,x2,x1)])"
    unfolding rev_path_def
    using x by auto
  also have "...=set (rev_path xs) \<union> {(x3,x2,x1)}" by auto
  finally have "set (rev_path (x # xs)) =set (rev_path xs) \<union> {(x3,x2,x1)}" .
  moreover have "set (x#xs)= set xs \<union> {(x1,x2,x3)}"
    by (metis List.set_simps(2) insert_is_Un sup_commute x)
  ultimately show ?case using Cons by auto
qed

lemma rem_unPath_edges:
    "edges(rem_unPath ps G) = edges G - (set ps \<union> set (rev_path ps))"
proof (induct ps)
  case Nil
  show ?case unfolding rev_path_def by auto
next
  case (Cons x xs)
  obtain x1 x2 x3 where x: "x=(x1,x2,x3)" by (metis prod_cases3)
  hence "edges(rem_unPath (x#xs) G)= edges(del_unEdge x1 x2 x3 (rem_unPath xs G))"
    by (metis rem_unPath.simps(2) rem_unPath_com)
  also have "...=edges(rem_unPath xs G)-{(x1,x2,x3),(x3,x2,x1)}"
    by (metis del_unEdge_def select_convs(2))
  also have "...= edges G - (set xs \<union> set (rev_path xs))-{(x1,x2,x3),(x3,x2,x1)}"
    by (metis Cons.hyps)
  also have "...=edges G - (set (x#xs) \<union> set (rev_path (x#xs)))"
    proof -
      have "set (rev_path xs) \<union> {(x3,x2,x1)}=set ((rev_path xs)@[(x3,x2,x1)])"
        by (metis List.set_simps(2) empty_set set_append)
      also have "...=set (rev_path (x#xs))" unfolding rev_path_def using  x by auto
      finally have "set (rev_path xs) \<union> {(x3,x2,x1)}=set (rev_path (x#xs))" .
      moreover have "set xs \<union> {(x1,x2,x3)}=set (x#xs)"
        by (metis List.set_simps(2) insert_is_Un sup_commute x)
      moreover have "edges G - (set xs \<union> set (rev_path xs))-{(x1,x2,x3),(x3,x2,x1)} =
                      edges G - ((set xs \<union> {(x1,x2,x3)}) \<union> (set (rev_path xs) \<union> {(x3,x2,x1)}))"
        by auto
      ultimately show ?thesis by auto
    qed
  finally show ?case .
qed

lemma rem_unPath_graph [simp]:
    "rem_unPath (rev_path ps) G=rem_unPath ps G"
proof -
  have "nodes(rem_unPath (rev_path ps) G)=nodes(rem_unPath ps G)"
    by auto
  moreover have "edges(rem_unPath (rev_path ps) G)=edges(rem_unPath ps G)"
    proof -
      have "set (rev_path ps) \<union> set (rev_path (rev_path ps)) = set ps \<union>  set (rev_path ps) "
        by auto
      thus ?thesis by (metis rem_unPath_edges)
    qed
  ultimately show ?thesis by auto
qed

lemma distinct_rev_path[simp]: "distinct (rev_path ps) \<longleftrightarrow>distinct ps"
proof (induct ps)
  case Nil
  show ?case by auto
next
  case (Cons x xs)
  obtain x1 x2 x3 where x: "x=(x1,x2,x3)" by (metis prod_cases3)
  hence "distinct (rev_path (x # xs))=distinct ((rev_path xs)@[(x3,x2,x1)])"
    unfolding rev_path_def by auto
  also have "...= (distinct (rev_path xs) \<and> (x3,x2,x1)\<notin>set (rev_path xs))"
    by (metis distinct.simps(2) distinct1_rotate rotate1.simps(2))
  also have "...=distinct (x#xs)"
    by (metis Cons.hyps distinct.simps(2) in_set_rev_path x)
  finally have "distinct (rev_path (x # xs))=distinct (x#xs)" .
  thus ?case .
qed

lemma (in valid_unMultigraph) is_path_rev: "is_path v' (rev_path ps) v \<longleftrightarrow> is_path v ps v'"
proof (induct ps arbitrary: v)
  case Nil
  show ?case by auto
next
  case (Cons x xs)
  obtain x1 x2 x3 where x: "x=(x1,x2,x3)" by (metis prod_cases3)
  hence "is_path v' (rev_path (x # xs)) v=is_path v' ((rev_path xs) @[(x3,x2,x1)]) v"
    unfolding rev_path_def by auto
  also have "...=(is_path v' (rev_path xs) x3 \<and> (x3,x2,x1)\<in>E \<and> is_path x1 [] v)" by auto
  also have "...=(is_path x3 xs v' \<and> (x3,x2,x1)\<in>E \<and> is_path x1 [] v)" using Cons.hyps by auto
  also have "...=is_path v (x#xs) v'"
    by (metis corres is_path.simps(1) is_path.simps(2) is_path_memb x)
  finally have "is_path v' (rev_path (x # xs)) v=is_path v (x#xs) v'" .
  thus ?case .
qed

lemma (in valid_unMultigraph) singleton_distinct_path [intro]:
   "(v,w,v')\<in>E \<Longrightarrow> is_trail v [(v,w,v')] v'"
   by (metis E_validD(2) all_not_in_conv is_trail.simps set_empty)

lemma (in valid_unMultigraph) is_trail_intro[intro]:
  "is_trail v' ps v \<Longrightarrow> is_path v' ps v" by (induct ps arbitrary:v',auto)

lemma (in valid_unMultigraph) is_trail_split:
      "is_trail v (p1@p2) v' \<Longrightarrow> (\<exists>u. is_trail v p1 u \<and> is_trail u p2 v')"
apply (induct p1 arbitrary: v,auto)
apply (metis is_trail_intro is_path_memb)
done

lemma (in valid_unMultigraph) is_trail_split':"is_trail v (p1@(u,w,u')#p2) v'
    \<Longrightarrow> is_trail v p1 u \<and> (u,w,u')\<in>E \<and> is_trail u' p2 v'"
  by (metis is_trail.simps(2) is_trail_split)

lemma (in valid_unMultigraph) distinct_elim[simp]:
  assumes "is_trail v ((v1,w,v2)#ps) v'"
  shows "(v1,w,v2)\<in>edges(rem_unPath ps G) \<longleftrightarrow> (v1,w,v2)\<in>E"
proof
  assume "(v1, w, v2) \<in> edges (rem_unPath ps G)"
  thus "(v1, w, v2) \<in> E" by (metis assms is_trail.simps(2))
next
  assume "(v1, w, v2) \<in> E"
  have "(v1,w,v2)\<notin>set ps \<and> (v2,w,v1)\<notin>set ps" by (metis assms is_trail.simps(2))
  hence "(v1,w,v2)\<notin>set ps \<and> (v1,w,v2)\<notin>set (rev_path ps)" by simp
  hence "(v1,w,v2)\<notin>set ps \<union> set (rev_path ps)" by simp
  hence "(v1,w,v2)\<in>edges G - (set ps \<union> set (rev_path ps))"
    using \<open>(v1, w, v2) \<in> E\<close> by auto
  thus "(v1,w,v2)\<in>edges(rem_unPath ps G)"
    by (metis rem_unPath_edges)
qed

lemma distinct_path_subset:
  assumes "valid_unMultigraph G1" "valid_unMultigraph G2" "edges G1 \<subseteq>edges G2" "nodes G1 \<subseteq>nodes G2"
  assumes distinct_G1:"valid_unMultigraph.is_trail G1 v ps v'"
  shows "valid_unMultigraph.is_trail G2 v ps v'" using distinct_G1
proof (induct ps arbitrary:v)
  case Nil
  hence "v=v'\<and>v'\<in>nodes G1"
    by (metis (full_types) assms(1) valid_unMultigraph.is_trail.simps(1))
  hence "v=v'\<and>v'\<in>nodes G2" using \<open>nodes G1 \<subseteq> nodes G2\<close> by auto
  thus ?case by (metis assms(2) valid_unMultigraph.is_trail.simps(1))
next
  case (Cons x xs)
  obtain x1 x2 x3 where x:"x=(x1,x2,x3)" by (metis prod_cases3)
  hence "valid_unMultigraph.is_trail G1 x3 xs v'"
    by (metis Cons.prems assms(1) valid_unMultigraph.is_trail.simps(2))
  hence "valid_unMultigraph.is_trail G2 x3 xs v'" using Cons by auto
  moreover have "x\<in>edges G1"
    by (metis Cons.prems assms(1) valid_unMultigraph.is_trail.simps(2) x)
  hence "x\<in>edges G2" using \<open>edges G1 \<subseteq> edges G2\<close> by auto
  moreover have "v=x1\<and>(x1,x2,x3)\<notin>set xs\<and>(x3,x2,x1)\<notin>set xs"
    by (metis Cons.prems assms(1) valid_unMultigraph.is_trail.simps(2) x)
  hence "v=x1" "(x1,x2,x3)\<notin>set xs" "(x3,x2,x1)\<notin>set xs" by auto
  ultimately show ?case by (metis assms(2) valid_unMultigraph.is_trail.simps(2) x)
qed

lemma (in valid_unMultigraph) distinct_path_intro':
  assumes "valid_unMultigraph.is_trail (rem_unPath p G) v ps v'"
  shows "is_trail  v ps v'"
proof -
  have valid:"valid_unMultigraph (rem_unPath p G)"
    using rem_unPath_valid[OF valid_unMultigraph_axioms,of p] by auto
  moreover have "nodes (rem_unPath p G) \<subseteq> V" by auto
  moreover have "edges (rem_unPath p G) \<subseteq> E"
    using rem_unPath_edges by auto
  ultimately show ?thesis
    using distinct_path_subset[of "rem_unPath p G" G] valid_unMultigraph_axioms assms
    by auto
qed

lemma (in valid_unMultigraph) distinct_path_intro:
  assumes "valid_unMultigraph.is_trail (del_unEdge x1 x2 x3 G) v ps v'"
  shows "is_trail  v ps v'"
by (metis (full_types) assms distinct_path_intro' rem_unPath.simps(1)
    rem_unPath.simps(2))

lemma (in valid_unMultigraph) del_UnEdge_even':
  assumes "(v,w,v') \<in> E" "finite E"
  shows "v'\<in>odd_nodes_set(del_unEdge v w v' G) \<longleftrightarrow> even (degree v' G)"
proof -
  show ?thesis by (metis (full_types) assms corres del_UnEdge_even delete_edge_sym)
qed

lemma del_UnEdge_even_odd:
    assumes "valid_unMultigraph G" "finite(edges G)" "finite(nodes G)" "(v, w, v')\<in>edges G"
    assumes parity_assms: "even (degree v G)" "odd (degree v' G)"
    shows "num_of_odd_nodes(del_unEdge v w v' G)=num_of_odd_nodes G"
proof -
  interpret G : valid_unMultigraph by fact
  have odd_v:"v\<in>odd_nodes_set(del_unEdge v w v' G)"
    by (metis G.del_UnEdge_even assms(2) assms(4) parity_assms(1))
  have  not_odd_v':"v'\<notin>odd_nodes_set(del_unEdge v w v' G)"
    by (metis G.del_UnEdge_even' assms(2) assms(4) parity_assms(2))
  have "odd_nodes_set(del_unEdge v w v' G) \<union> {v'} \<subseteq>odd_nodes_set G \<union> {v}"
    proof
      fix x
      assume x_prems:" x \<in> odd_nodes_set (del_unEdge v w v' G) \<union> {v'}"
      have "x=v' \<Longrightarrow>x\<in>odd_nodes_set G \<union> {v}"
        using parity_assms
        by (metis (lifting) G.E_validD(2) Un_def assms(4) mem_Collect_eq odd_nodes_set_def )
      moreover have "x=v \<Longrightarrow> x\<in>odd_nodes_set G \<union> {v}"
        by (metis insertI1 insert_is_Un sup_commute)
      moreover have "x\<notin>{v,v'} \<Longrightarrow> x \<in> odd_nodes_set (del_unEdge v w v' G)"
        using x_prems by auto
      hence "x\<notin>{v,v'} \<Longrightarrow> x \<in> odd_nodes_set G" unfolding odd_nodes_set_def
        using G.degree_frame \<open>finite (edges G)\<close> by auto
      hence "x\<notin>{v,v'} \<Longrightarrow> x\<in>odd_nodes_set G \<union> {v}" by simp
      ultimately show "x \<in> odd_nodes_set G \<union> {v}" by auto
    qed
  moreover have "odd_nodes_set G \<union> {v} \<subseteq> odd_nodes_set(del_unEdge v w v' G) \<union> {v'}"
    proof
      fix x
      assume x_prems: "x \<in> odd_nodes_set G \<union> {v}"
      have "x=v \<Longrightarrow> x \<in> odd_nodes_set (del_unEdge v w v' G) \<union> {v'}"
        by (metis UnI1 odd_v)
      moreover have "x=v' \<Longrightarrow> x \<in> odd_nodes_set (del_unEdge v w v' G) \<union> {v'}"
        by auto
      moreover have "x\<notin>{v,v'} \<Longrightarrow> x \<in> odd_nodes_set G \<union> {v}" using x_prems by auto
      hence "x\<notin>{v,v'} \<Longrightarrow>  x\<in>odd_nodes_set (del_unEdge v w v' G)" unfolding odd_nodes_set_def
        using G.degree_frame \<open>finite (edges G)\<close> by auto
      hence "x\<notin>{v,v'} \<Longrightarrow> x \<in> odd_nodes_set (del_unEdge v w v' G) \<union> {v'}" by simp
        ultimately show "x \<in> odd_nodes_set (del_unEdge v w v' G) \<union> {v'}" by auto
    qed
  ultimately have "odd_nodes_set(del_unEdge v w v' G) \<union> {v'} = odd_nodes_set G \<union> {v}"
    by auto
  moreover have " odd_nodes_set G \<inter> {v} = {}"
    using parity_assms unfolding odd_nodes_set_def by auto
  moreover have " odd_nodes_set(del_unEdge v w v' G) \<inter> {v'}={}"
    by (metis Int_insert_left_if0 inf_bot_left inf_commute not_odd_v')
  moreover have "finite (odd_nodes_set(del_unEdge v w v' G))"
     using \<open>finite (nodes G)\<close> by auto
  moreover have "finite (odd_nodes_set G)" using \<open>finite (nodes G)\<close> by auto
  ultimately have "card(odd_nodes_set G) + card {v} =
                   card(odd_nodes_set(del_unEdge v w v' G)) + card {v'}"
    using card_Un_disjoint[of "odd_nodes_set (del_unEdge v w v' G)" "{v'}"]
      card_Un_disjoint[of "odd_nodes_set G" "{v}"]
    by auto
  thus ?thesis unfolding num_of_odd_nodes_def by simp
qed

lemma del_UnEdge_odd_even:
    assumes "valid_unMultigraph G" "finite(edges G)" "finite(nodes G)" "(v, w, v')\<in>edges G"
    assumes parity_assms: "odd (degree v G)" "even (degree v' G)"
    shows "num_of_odd_nodes(del_unEdge v w v' G)=num_of_odd_nodes G"
by (metis assms del_UnEdge_even_odd delete_edge_sym parity_assms valid_unMultigraph.corres)

section\<open>Connectivity\<close>

definition (in valid_unMultigraph) connected::bool where
  "connected \<equiv> \<forall> v\<in>V. \<forall>v'\<in>V. v\<noteq>v' \<longrightarrow> (\<exists>ps. is_path v ps v')"

lemma (in valid_unMultigraph) "connected \<Longrightarrow> \<forall>v\<in>V. \<forall>v'\<in>V. v\<noteq>v'\<longrightarrow>(\<exists>ps. is_trail v ps v')"
proof (rule,rule,rule)
  fix v v'
  assume "v\<in>V" "v'\<in>V" "v\<noteq>v'"
  assume connected
  obtain ps where "is_path v ps v'" by (metis \<open>connected\<close> \<open>v \<in> V\<close> \<open>v' \<in> V\<close> \<open>v\<noteq>v'\<close>  connected_def)
  then obtain ps' where "is_trail v ps' v'"
    proof (induct ps arbitrary:v )
      case Nil
      thus ?case by (metis is_trail.simps(1) is_path.simps(1))
    next
      case (Cons x xs)
      obtain x1 x2 x3 where x:"x=(x1,x2,x3)" by (metis prod_cases3)
      have "is_path x3 xs v'" by (metis Cons.prems(2) is_path.simps(2) x)
      moreover have "\<And>ps'. is_trail x3 ps' v' \<Longrightarrow> thesis"
        proof -
          fix ps'
          assume "is_trail x3 ps' v'"
          hence "(x1,x2,x3)\<notin>set ps' \<and> (x3,x2,x1)\<notin>set ps' \<Longrightarrow>is_trail v (x#ps') v'"
            by (metis Cons.prems(2) is_trail.simps(2) is_path.simps(2) x)
          moreover have "(x1,x2,x3)\<in>set ps' \<Longrightarrow> \<exists>ps1. is_trail v ps1 v'"
            proof -
              assume "(x1,x2,x3)\<in>set ps'"
              then obtain ps1 ps2 where "ps'=ps1@(x1,x2,x3)#ps2" by (metis split_list)
              hence "is_trail v (x#ps2) v'"
                using \<open>is_trail x3 ps' v'\<close> x
                by (metis Cons.prems(2) is_trail.simps(2)
                    is_trail_split is_path.simps(2))
              thus ?thesis by rule
            qed
          moreover have "(x3,x2,x1)\<in>set ps' \<Longrightarrow>  \<exists>ps1. is_trail v ps1 v'"
             proof -
              assume "(x3,x2,x1)\<in>set ps'"
              then obtain ps1 ps2 where "ps'=ps1@(x3,x2,x1)#ps2" by (metis split_list)
              hence "is_trail v ps2 v'"
                using \<open>is_trail x3 ps' v'\<close> x
                by (metis Cons.prems(2) is_trail.simps(2)
                    is_trail_split is_path.simps(2))
              thus ?thesis by rule
            qed
          ultimately show thesis using Cons by auto
        qed
      ultimately show ?case using Cons by auto
    qed
  thus "\<exists>ps. is_trail v ps v'" by rule
qed

lemma (in valid_unMultigraph) no_rep_length: "is_trail v ps v'\<Longrightarrow>length ps=card(set ps)"
  by (induct ps arbitrary:v, auto)

lemma (in valid_unMultigraph) path_in_edges:"is_trail v ps v' \<Longrightarrow> set ps \<subseteq> E"
proof (induct ps arbitrary:v)
  case Nil
  show ?case by auto
next
  case (Cons x xs)
  obtain x1 x2 x3 where x:"x=(x1,x2,x3)" by (metis prod_cases3)
  hence "is_trail x3 xs v'" using Cons by auto
  hence " set xs \<subseteq> E" using Cons by auto
  moreover have "x\<in>E" using Cons by (metis is_trail_intro is_path.simps(2) x)
  ultimately show ?case by auto
qed

lemma (in valid_unMultigraph) trail_bound:
    assumes "finite E" " is_trail v ps v'"
    shows "length ps \<le>card E"
by (metis (hide_lams, no_types) assms(1) assms(2) card_mono no_rep_length path_in_edges)

definition (in valid_unMultigraph) exist_path_length:: "'v \<Rightarrow> nat \<Rightarrow>bool" where
  "exist_path_length v l\<equiv>\<exists>v' ps. is_trail v' ps v \<and> length ps=l"

lemma (in valid_unMultigraph) longest_path:
  assumes "finite E" "n \<in> V"
  shows "\<exists>v. \<exists>max_path. is_trail v max_path n \<and>
        (\<forall>v'. \<forall>e\<in>E. \<not>is_trail v' (e#max_path) n)"
proof (rule ccontr)
  assume  contro:"\<not> (\<exists>v max_path. is_trail v max_path n
           \<and> (\<forall>v'. \<forall>e\<in>E. \<not>is_trail v' (e#max_path) n))"
  hence  induct:"(\<forall>v max_path.  is_trail v max_path n
           \<longrightarrow> (\<exists>v'. \<exists>e\<in>E. is_trail v' (e#max_path) n))" by auto
  have "is_trail n [] n" using \<open>n \<in> V\<close> by auto
  hence "exist_path_length n 0" unfolding exist_path_length_def by auto
  moreover have "\<forall>y. exist_path_length n y \<longrightarrow> y \<le> card E"
    using trail_bound[OF \<open>finite E\<close>] unfolding exist_path_length_def
    by auto
  hence bound:"\<forall>y. exist_path_length n y \<longrightarrow> y \<le> card E" by auto
  ultimately have "exist_path_length n (GREATEST x. exist_path_length n x)"
    using GreatestI_nat by auto
  then obtain v max_path where
    max_path:"is_trail v max_path n" "length max_path=(GREATEST x. exist_path_length n x)"
    by (metis exist_path_length_def)
  hence "\<exists> v' e. is_trail v' (e#max_path) n" using induct by metis
  hence "exist_path_length n (length max_path +1)"
    by (metis One_nat_def exist_path_length_def list.size(4))
  hence "length max_path + 1 \<le> (GREATEST x. exist_path_length n x)"
   by (metis Greatest_le_nat bound)
  hence "length max_path + 1 \<le> length max_path" using max_path by auto
  thus False by auto
qed

lemma even_card':
  assumes "even(card A)" "x\<in>A"
  shows "\<exists>y\<in>A. y\<noteq>x"
proof (rule ccontr)
  assume "\<not> (\<exists>y\<in>A. y \<noteq> x)"
  hence "\<forall>y\<in>A. y=x" by auto
  hence "A={x}" by (metis all_not_in_conv assms(2) insertI2 mk_disjoint_insert)
  hence "card(A)=1" by auto
  thus False using \<open>even(card A)\<close> by auto
qed

lemma odd_card:
  assumes "finite A" "odd(card A)"
  shows "\<exists>x. x\<in>A"
by (metis all_not_in_conv assms(2) card_empty even_zero)

text\<open>replace an edge (or its reverse in a path) by another path (in an undirected graph)\<close>
fun replace_by_UnPath:: "('v,'w) path \<Rightarrow> 'v \<times>'w \<times>'v \<Rightarrow> ('v,'w) path \<Rightarrow>  ('v,'w) path" where
  "replace_by_UnPath [] _ _ = []" |
  "replace_by_UnPath (x#xs) (v,e,v') ps =
    (if x=(v,e,v') then ps@replace_by_UnPath xs (v,e,v') ps
     else if x=(v',e,v) then (rev_path ps)@replace_by_UnPath xs (v,e,v') ps
     else x#replace_by_UnPath xs (v,e,v') ps)"

lemma (in valid_graph) path_end:"ps\<noteq>[] \<Longrightarrow> is_path v ps v' \<Longrightarrow> v'=snd (snd(last ps))"
  by (induct ps arbitrary:v,auto)

lemma sub_graph_degree_frame:
  assumes "valid_graph G2" "edges G1 \<union> edges G2 =edges G" "nodes G1 \<inter> nodes G2={}" "n\<in>nodes G1"
  shows "degree n G=degree n G1"
proof -
  have "{e \<in> edges G. fst e = n}\<subseteq>{e \<in> edges G1. fst e = n}"
    proof
      fix e assume  "e \<in> {e \<in> edges G. fst e = n}"
      hence "e\<in>edges G" "fst e=n" by auto
      moreover have "n\<notin>nodes G2"
        using \<open>nodes G1 \<inter> nodes G2={}\<close> \<open>n\<in>nodes G1\<close>
        by auto
      hence "e\<notin>edges G2" using valid_graph.E_validD[OF \<open>valid_graph G2\<close>] \<open>fst e=n\<close>
        by (metis prod.exhaust fst_conv)
      ultimately have "e\<in>edges G1" using \<open>edges G1 \<union> edges G2 =edges G\<close> by auto
      thus "e \<in> {e \<in> edges G1. fst e = n}" using \<open>fst e=n\<close> by auto
    qed
  moreover have "{e \<in> edges G1. fst e = n}\<subseteq>{e \<in> edges G. fst e = n}"
    by (metis (lifting) Collect_mono Un_iff assms(2))
  ultimately show ?thesis unfolding degree_def by auto
qed

lemma odd_nodes_no_edge[simp]: "finite (nodes g) \<Longrightarrow> num_of_odd_nodes (g \<lparr>edges:={} \<rparr>) = 0"
  unfolding  num_of_odd_nodes_def odd_nodes_set_def degree_def by simp

section \<open>Adjacent nodes\<close>

definition (in valid_unMultigraph) adjacent:: "'v \<Rightarrow> 'v \<Rightarrow> bool" where
    "adjacent v v' \<equiv> \<exists>w. (v,w,v')\<in>E"

lemma (in valid_unMultigraph) adjacent_sym: "adjacent v v' \<longleftrightarrow> adjacent v' v"
    unfolding adjacent_def by auto

lemma (in valid_unMultigraph) adjacent_V[simp]:
    assumes "adjacent v v'"
    shows "v\<in>V" "v'\<in>V"
  using assms E_validD unfolding adjacent_def by auto

lemma (in valid_unMultigraph) adjacent_finite:
  "finite E \<Longrightarrow> finite {n. adjacent v n}"
proof -
  assume "finite E"
  { fix S v
    have "finite S \<Longrightarrow> finite {n. \<exists>w. (v,w,n)\<in>S}"
      proof (induct S rule: finite_induct)
        case empty
        thus ?case by auto
      next
        case (insert x F)
        obtain x1 x2 x3 where x: "x=(x1,x2,x3)" by (metis prod_cases3)
        have "x1=v \<Longrightarrow> ?case"
          proof -
            assume "x1=v"
            hence "{n. \<exists>w. (v, w, n) \<in> insert x F}=insert x3 {n. \<exists>w. (v, w, n) \<in> F}"
              using x by auto
            thus ?thesis using insert by auto
          qed
        moreover have "x1\<noteq>v \<Longrightarrow> ?case"
          proof -
            assume "x1\<noteq>v"
            hence "{n. \<exists>w. (v, w, n) \<in> insert x F}={n. \<exists>w. (v, w, n) \<in> F}" using x by auto
            thus ?thesis using insert by auto
          qed
        ultimately show ?case by auto
      qed }
  note aux=this
  show ?thesis using aux[OF \<open>finite E\<close>, of v]  unfolding adjacent_def by auto
qed

section\<open>Undirected simple graph\<close>

locale valid_unSimpGraph=valid_unMultigraph G for G::"('v,'w) graph"+
              assumes no_multi[simp]: "(v,w,u) \<in> edges G \<Longrightarrow> (v,w',u) \<in>edges G \<Longrightarrow> w = w'"

lemma (in valid_unSimpGraph) finV_to_finE[simp]:
  assumes "finite V"
  shows "finite E"
proof (cases "{(v1,v2). adjacent v1 v2}={}")
  case True
  hence "E={}" unfolding adjacent_def by auto
  thus "finite E" by auto
next
  case False
  have "{(v1,v2). adjacent v1 v2} \<subseteq> V \<times> V" using adjacent_V by auto
  moreover have "finite (V \<times> V)" using \<open>finite V\<close> by auto
  ultimately have "finite {(v1,v2). adjacent v1 v2}" using finite_subset by auto
  hence "card {(v1,v2). adjacent v1 v2}\<noteq>0" using False card_eq_0_iff by auto
  moreover have "card E=card {(v1,v2). adjacent v1 v2}"
    proof -
      have "(\<lambda>(v1,w,v2). (v1,v2))`E = {(v1,v2). adjacent v1 v2}"
        proof -
          have "\<And>x. x\<in>(\<lambda>(v1,w,v2). (v1,v2))`E \<Longrightarrow> x\<in> {(v1,v2). adjacent v1 v2}"
            unfolding adjacent_def by auto
          moreover have "\<And>x. x\<in>{(v1,v2). adjacent v1 v2} \<Longrightarrow> x\<in>(\<lambda>(v1,w,v2). (v1,v2))`E"
            unfolding adjacent_def by force
          ultimately show ?thesis by force
        qed
      moreover have "inj_on (\<lambda>(v1,w,v2). (v1,v2)) E" unfolding inj_on_def by auto
      ultimately show ?thesis by (metis card_image)
    qed
  ultimately show "finite E" by (metis card_infinite)
qed

lemma (in valid_unSimpGraph) del_UnEdge_non_adj:
    "(v,w,u)\<in>E \<Longrightarrow> \<not>valid_unMultigraph.adjacent (del_unEdge v w u G) v u"
proof
  assume "(v, w, u) \<in> E"
      and ccontr:"valid_unMultigraph.adjacent (del_unEdge v w u G) v u"
  have valid:"valid_unMultigraph (del_unEdge v w u G)"
    using valid_unMultigraph_axioms by auto
  then obtain w' where vw'u:"(v,w',u)\<in>edges (del_unEdge v w u G)"
    using ccontr unfolding valid_unMultigraph.adjacent_def[OF valid] by auto
  hence "(v,w',u)\<notin>{(v,w,u),(u,w,v)}" unfolding del_unEdge_def by auto
  hence "w'\<noteq>w" by auto
  moreover have "(v,w',u)\<in>E" using vw'u unfolding del_unEdge_def by auto
  ultimately show False using no_multi[of v w u w'] \<open>(v, w, u) \<in> E\<close> by auto
qed

lemma (in valid_unSimpGraph) degree_adjacent: "finite E \<Longrightarrow> degree v G=card {n. adjacent v n}"
  using valid_unSimpGraph_axioms
proof (induct "degree v G" arbitrary: G)
  case 0
  note valid3=\<open>valid_unSimpGraph G\<close>
  hence valid2: "valid_unMultigraph G" using valid_unSimpGraph_def by auto
  have "{a. valid_unMultigraph.adjacent G v a}={}"
    proof (rule ccontr)
      assume "{a. valid_unMultigraph.adjacent G v a} \<noteq> {}"
      then obtain w u where "(v,w,u)\<in>edges G"
        unfolding valid_unMultigraph.adjacent_def[OF valid2] by auto
      hence "degree v G\<noteq>0" using \<open>finite (edges G)\<close> unfolding degree_def by auto
      thus False using \<open>0 = degree v G\<close> by auto
    qed
  thus ?case by (metis "0.hyps" card_empty)
next
  case (Suc n)
  hence "{e \<in> edges G. fst e = v}\<noteq>{}" using card_empty unfolding degree_def  by force
  then obtain w u where "(v,w,u)\<in>edges G" by auto
  have valid:"valid_unMultigraph G" using \<open>valid_unSimpGraph G\<close> valid_unSimpGraph_def by auto
  hence valid':"valid_unMultigraph (del_unEdge v w u G)" by auto
  have "valid_unSimpGraph (del_unEdge v w u G)"
    using del_unEdge_valid' \<open>valid_unSimpGraph G\<close> by auto
  moreover have "n = degree v (del_unEdge v w u G)"
    using \<open>Suc n = degree v G\<close>\<open>(v, w, u) \<in> edges G\<close>  del_edge_undirected_degree_plus[of G v w u]
    by (metis Suc.prems(1) Suc_eq_plus1 diff_Suc_1 valid valid_unMultigraph.corres)
  moreover have "finite (edges (del_unEdge v w u G))"
    using \<open>finite (edges G)\<close> unfolding del_unEdge_def
    by auto
  ultimately have "degree v (del_unEdge v w u G)
      = card (Collect (valid_unMultigraph.adjacent (del_unEdge v w u G) v))"
    using Suc.hyps  by auto
  moreover have "Suc(card ({n. valid_unMultigraph.adjacent (del_unEdge v w u G)
      v n})) = card ({n. valid_unMultigraph.adjacent G v n})"
    using valid_unMultigraph.adjacent_def[OF valid']
    proof -
      have "{n. valid_unMultigraph.adjacent (del_unEdge v w u G) v n} \<subseteq>
          {n. valid_unMultigraph.adjacent G v n}"
        using del_unEdge_def[of v w u G]
        unfolding valid_unMultigraph.adjacent_def[OF valid']
          valid_unMultigraph.adjacent_def[OF valid]
        by auto
      moreover have "u\<in>{n. valid_unMultigraph.adjacent G v n}"
        using \<open>(v,w,u)\<in>edges G\<close> unfolding valid_unMultigraph.adjacent_def[OF valid] by auto
      ultimately have "{n. valid_unMultigraph.adjacent (del_unEdge v w u G) v n} \<union> {u}
          \<subseteq> {n. valid_unMultigraph.adjacent G v n}" by auto
      moreover have "{n. valid_unMultigraph.adjacent G v n} - {u}
          \<subseteq> {n. valid_unMultigraph.adjacent (del_unEdge v w u G) v n}"
        using del_unEdge_def[of v w u G]
        unfolding valid_unMultigraph.adjacent_def[OF valid']
          valid_unMultigraph.adjacent_def[OF valid]
        by auto
      ultimately have "{n. valid_unMultigraph.adjacent (del_unEdge v w u G) v n} \<union> {u}
          = {n. valid_unMultigraph.adjacent G v n}" by auto
      moreover have "u\<notin>{n. valid_unMultigraph.adjacent (del_unEdge v w u G) v n}"
        using valid_unSimpGraph.del_UnEdge_non_adj[OF \<open>valid_unSimpGraph G\<close> \<open>(v,w,u)\<in>edges G\<close>]
        by auto
      moreover have "finite {n. valid_unMultigraph.adjacent G v n}"
        using valid_unMultigraph.adjacent_finite[OF valid \<open>finite (edges G)\<close>] by simp
      ultimately show ?thesis
        by (metis Un_insert_right card_insert_disjoint finite_Un sup_bot_right)
    qed
  ultimately show ?case by (metis Suc.hyps(2) \<open>n = degree v (del_unEdge v w u G)\<close>)
qed

end


section {*\isaheader{Specification of Annotated Lists}*}
theory AnnotatedListSpec
imports ICF_Spec_Base
begin

(*@intf AnnotatedList
  @abstype ('e \<times> 'a::monoid_add) list
  Lists with annotated elements. The annotations form a monoid, and there is
  a split operation to split the list according to its annotations. This is the
  abstract concept implemented by finger trees.
*)

subsection "Introduction"
text {*
  We define lists with annotated elements. The annotations form a monoid.

  We provide standard list operations and the split-operation, that
  splits the list according to its annotations.
*}
locale al =
  --"Annotated lists are abstracted to lists of pairs of elements and annotations."
  fixes \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes invar :: "'s \<Rightarrow> bool"

locale al_no_invar = al +
  assumes invar[simp, intro!]: "\<And>l. invar l"

subsection "Basic Annotated List Operations"

subsubsection "Empty Annotated List"
locale al_empty = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes empty :: "unit \<Rightarrow> 's"
  assumes empty_correct:
    "invar (empty ())"
    "\<alpha> (empty ()) = Nil"

subsubsection "Emptiness Check"
locale al_isEmpty = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes isEmpty :: "'s \<Rightarrow> bool"
  assumes isEmpty_correct:
    "invar s \<Longrightarrow> isEmpty s \<longleftrightarrow> \<alpha> s = Nil"

subsubsection "Counting Elements"
locale al_count = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes count :: "'s \<Rightarrow> nat"
  assumes count_correct:
    "invar s \<Longrightarrow> count s = length(\<alpha> s)"

subsubsection "Appending an Element from the Left"
locale al_consl = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes consl :: "'e \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> 's"
  assumes consl_correct:
    "invar s \<Longrightarrow> invar (consl e a s)"
    "invar s \<Longrightarrow> (\<alpha> (consl e a s)) = (e,a) # (\<alpha> s)"

subsubsection "Appending an Element from the Right"
locale al_consr = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes consr :: "'s \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's"
  assumes consr_correct:
    "invar s \<Longrightarrow> invar (consr s e a)"
    "invar s \<Longrightarrow> (\<alpha> (consr s e a)) = (\<alpha> s) @ [(e,a)]"

subsubsection "Take the First Element"
locale al_head = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes head :: "'s \<Rightarrow> ('e \<times> 'a)"
  assumes head_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> head s = hd (\<alpha> s)"

subsubsection "Drop the First Element"
locale al_tail = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes tail :: "'s \<Rightarrow> 's"
  assumes tail_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> \<alpha> (tail s) = tl (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> invar (tail s)"

subsubsection "Take the Last Element"
locale al_headR = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes headR :: "'s \<Rightarrow> ('e \<times> 'a)"
  assumes headR_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> headR s = last (\<alpha> s)"

subsubsection "Drop the Last Element"
locale al_tailR = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes tailR :: "'s \<Rightarrow> 's"
  assumes tailR_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> \<alpha> (tailR s) = butlast (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> invar (tailR s)"

subsubsection "Fold a Function over the Elements from the Left"
locale al_foldl = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes foldl :: "('z \<Rightarrow> 'e \<times> 'a \<Rightarrow> 'z) \<Rightarrow> 'z \<Rightarrow> 's \<Rightarrow> 'z"
  assumes foldl_correct:
    "invar s \<Longrightarrow> foldl f \<sigma> s = List.foldl f \<sigma> (\<alpha> s)"

subsubsection "Fold a Function over the Elements from the Right"
locale al_foldr = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes foldr :: "('e \<times> 'a \<Rightarrow> 'z \<Rightarrow> 'z) \<Rightarrow> 's \<Rightarrow> 'z \<Rightarrow> 'z"
  assumes foldr_correct:
    "invar s \<Longrightarrow> foldr f s \<sigma> = List.foldr f (\<alpha> s) \<sigma>"

locale poly_al_fold = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
begin
  definition foldl where
    foldl_correct[code_unfold]: "foldl f \<sigma> s = List.foldl f \<sigma> (\<alpha> s)"
  definition foldr where
    foldr_correct[code_unfold]: "foldr f s \<sigma> = List.foldr f (\<alpha> s) \<sigma>"
end

subsubsection "Concatenation of Two Annotated Lists"
locale al_app = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes app :: "'s \<Rightarrow> 's \<Rightarrow> 's"
  assumes app_correct:
    "\<lbrakk>invar s;invar s'\<rbrakk> \<Longrightarrow> \<alpha> (app s s') = (\<alpha> s) @ (\<alpha> s')"
    "\<lbrakk>invar s;invar s'\<rbrakk> \<Longrightarrow> invar (app s s')"

subsubsection "Readout the Summed up Annotations"
locale al_annot = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes annot :: "'s \<Rightarrow> 'a"
  assumes annot_correct:
    "invar s \<Longrightarrow> (annot s) = (listsum (map snd (\<alpha> s)))"

subsubsection "Split by Monotone Predicate"
locale al_splits = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes splits :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow>
                                ('s \<times> ('e \<times> 'a) \<times> 's)"
  assumes splits_correct:
    "\<lbrakk>invar s;
       \<forall>a b. p a \<longrightarrow> p (a + b);
       \<not> p i;
       p (i + listsum (map snd (\<alpha> s)));
       (splits p i s) = (l, (e,a), r)\<rbrakk>
      \<Longrightarrow>
        (\<alpha> s) = (\<alpha> l) @ (e,a) # (\<alpha> r)  \<and>
        \<not> p (i + listsum (map snd (\<alpha> l)))  \<and>
        p (i + listsum (map snd (\<alpha> l)) + a)  \<and>
        invar l  \<and>
        invar r
    "
begin
  lemma splitsE:
    assumes
    invar: "invar s" and
    mono: "\<forall>a b. p a \<longrightarrow> p (a + b)" and
    init_ff: "\<not> p i" and
    sum_tt: "p (i + listsum (map snd (\<alpha> s)))"
    obtains l e a r where
    "(splits p i s) = (l, (e,a), r)"
    "(\<alpha> s) = (\<alpha> l) @ (e,a) # (\<alpha> r)"
    "\<not> p (i + listsum (map snd (\<alpha> l)))"
    "p (i + listsum (map snd (\<alpha> l)) + a)"
    "invar l"
    "invar r"
    using assms
    apply (cases "splits p i s")
    apply (case_tac b)
    apply (drule_tac i = i and p = p
      and l = a and r = c and e = aa and a = ba in  splits_correct)
    apply (simp_all)
    done
end

subsection "Record Based Interface"
record ('e,'a,'s) alist_ops =
  alist_op_\<alpha> ::"'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  alist_op_invar :: "'s \<Rightarrow> bool"
  alist_op_empty :: "unit \<Rightarrow> 's"
  alist_op_isEmpty :: "'s \<Rightarrow> bool"
  alist_op_count :: "'s \<Rightarrow> nat"
  alist_op_consl :: "'e \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> 's"
  alist_op_consr :: "'s \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's"
  alist_op_head :: "'s \<Rightarrow> ('e \<times> 'a)"
  alist_op_tail :: "'s \<Rightarrow> 's"
  alist_op_headR :: "'s \<Rightarrow> ('e \<times> 'a)"
  alist_op_tailR :: "'s \<Rightarrow> 's"
  alist_op_app :: "'s \<Rightarrow> 's \<Rightarrow> 's"
  alist_op_annot :: "'s \<Rightarrow> 'a"
  alist_op_splits :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> ('s \<times> ('e \<times> 'a) \<times> 's)"

locale StdALDefs = poly_al_fold "alist_op_\<alpha> ops" "alist_op_invar ops"
  for ops :: "('e,'a::monoid_add,'s,'more) alist_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> == alist_op_\<alpha> ops"
  abbreviation invar where "invar == alist_op_invar ops "
  abbreviation empty where "empty == alist_op_empty ops "
  abbreviation isEmpty where "isEmpty == alist_op_isEmpty ops "
  abbreviation count where "count == alist_op_count ops"
  abbreviation consl where "consl == alist_op_consl ops "
  abbreviation consr where "consr == alist_op_consr ops "
  abbreviation head where "head == alist_op_head ops "
  abbreviation tail where "tail == alist_op_tail ops "
  abbreviation headR where "headR == alist_op_headR ops "
  abbreviation tailR where "tailR == alist_op_tailR ops "
  abbreviation app where "app == alist_op_app ops "
  abbreviation annot where "annot == alist_op_annot ops "
  abbreviation splits where "splits == alist_op_splits ops "
end

locale StdAL = StdALDefs ops +
  al \<alpha> invar +
  al_empty \<alpha> invar empty +
  al_isEmpty \<alpha> invar isEmpty +
  al_count \<alpha> invar count +
  al_consl \<alpha> invar consl +
  al_consr \<alpha> invar consr +
  al_head \<alpha> invar head +
  al_tail \<alpha> invar tail +
  al_headR \<alpha> invar headR +
  al_tailR \<alpha> invar tailR +
  al_app \<alpha> invar app +
  al_annot \<alpha> invar annot +
  al_splits \<alpha> invar splits
  for ops
begin
  lemmas correct =
    empty_correct
    isEmpty_correct
    count_correct
    consl_correct
    consr_correct
    head_correct
    tail_correct
    headR_correct
    tailR_correct
    app_correct
    annot_correct
    foldl_correct
    foldr_correct
end

locale StdAL_no_invar = StdAL + al_no_invar \<alpha> invar

end


(*  Title:       Real Euclidean space and Tarski's axioms
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

section "Real Euclidean space and Tarski's axioms"

theory Euclid_Tarski
imports Tarski
begin

subsection "Real Euclidean space satisfies the first five axioms"

abbreviation
  real_euclid_C :: "[real^('n::finite), real^('n), real^('n), real^('n)] \<Rightarrow> bool"
  ("_ _ \<congruent>\<^sub>\<real> _ _" [99,99,99,99] 50) where
    "real_euclid_C \<equiv> norm_metric.smC"

definition real_euclid_B :: "[real^('n::finite), real^('n), real^('n)] \<Rightarrow> bool"
  ("B\<^sub>\<real> _ _ _" [99,99,99] 50) where
    "B\<^sub>\<real> a b c \<equiv> \<exists>l. 0 \<le> l \<and> l \<le> 1 \<and> b - a = l *\<^sub>R (c - a)"

interpretation real_euclid: tarski_first5 real_euclid_C real_euclid_B
proof
  txt \<open>By virtue of being a semimetric space,
    real Euclidean space is already known to satisfy the first three axioms.\<close>
  { fix q a b c
    have "\<exists>x. B\<^sub>\<real> q a x \<and> a x \<congruent>\<^sub>\<real> b c"
    proof cases
      assume "q = a"
      let ?x = "a + c - b"
      have "B\<^sub>\<real> q a ?x"
      proof -
        let ?l = "0 :: real"
        note real_euclid_B_def [of q a ?x]
        moreover
          have "?l \<ge> 0" and "?l \<le> 1" by auto
        moreover
          from \<open>q = a\<close> have "a - q = 0" by simp
          hence "a - q = ?l *\<^sub>R (?x - q)" by simp
        ultimately show ?thesis by auto
      qed
      moreover
        have "a - ?x = b - c" by simp
        hence "a ?x \<congruent>\<^sub>\<real> b c" by (simp add: field_simps)
      ultimately show ?thesis by blast
    next
      assume "q \<noteq> a"
      hence "norm_dist q a > 0" by simp
      let ?k = "norm_dist b c / norm_dist q a"
      let ?x = "a + ?k *\<^sub>R (a - q)"
      have "B\<^sub>\<real> q a ?x"
      proof -
        let ?l = "1 / (1 + ?k)"
        have "?l > 0" by (simp add: add_pos_nonneg)
        note real_euclid_B_def [of q a ?x]
        moreover
          have "?l \<ge> 0" and "?l \<le> 1" by (auto simp add: add_pos_nonneg)
        moreover
          from scaleR_left_distrib [of 1 ?k "a - q"]
            have "(1 + ?k) *\<^sub>R (a - q) = ?x - q" by simp
          hence "?l *\<^sub>R ((1 + ?k) *\<^sub>R (a - q)) = ?l *\<^sub>R (?x - q)" by simp
          with \<open>?l > 0\<close> and scaleR_right_diff_distrib [of ?l ?x q]
            have "a - q = ?l *\<^sub>R (?x - q)" by simp
        ultimately show "B\<^sub>\<real> q a ?x" by blast
      qed
      moreover
        have "a ?x \<congruent>\<^sub>\<real> b c"
        proof -
          from norm_scaleR [of ?k "a - q"] have
            "norm_dist a ?x = \<bar>?k\<bar> * norm (a - q)" by simp
          also have
            "\<dots> = ?k * norm (a - q)" by simp
          also from norm_metric.symm [of q a] have
            "\<dots> = ?k * norm_dist q a" by simp
          finally have
            "norm_dist a ?x = norm_dist b c / norm_dist q a * norm_dist q a" .
          with \<open>norm_dist q a > 0\<close> show "a ?x \<congruent>\<^sub>\<real> b c" by auto
        qed
      ultimately show ?thesis by blast
    qed }
  thus "\<forall>q a b c. \<exists>x. B\<^sub>\<real> q a x \<and> a x \<congruent>\<^sub>\<real> b c" by auto
  { fix a b c d a' b' c' d'
    assume "a \<noteq> b" and
      "B\<^sub>\<real> a b c" and
      "B\<^sub>\<real> a' b' c'" and
      "a b \<congruent>\<^sub>\<real> a' b'" and
      "b c \<congruent>\<^sub>\<real> b' c'" and
      "a d \<congruent>\<^sub>\<real> a' d'" and
      "b d \<congruent>\<^sub>\<real> b' d'"
    have "c d \<congruent>\<^sub>\<real> c' d'"
    proof -
      { fix m
        fix p q r :: "real^('n::finite)"
        assume "0 \<le> m" and
          "m \<le> 1" and
          "p \<noteq> q" and
          "q - p = m *\<^sub>R (r - p)"
        from \<open>p \<noteq> q\<close> and \<open>q - p = m *\<^sub>R (r - p)\<close> have "m \<noteq> 0"
        proof -
          { assume "m = 0"
            with \<open>q - p = m *\<^sub>R (r - p)\<close> have "q - p = 0" by simp
            with \<open>p \<noteq> q\<close> have False by simp }
          thus ?thesis ..
        qed
        with \<open>m \<ge> 0\<close> have "m > 0" by simp
        from \<open>q - p = m *\<^sub>R (r - p)\<close> and
            scaleR_right_diff_distrib [of m r p]
          have "q - p = m *\<^sub>R r - m *\<^sub>R p" by simp
        hence "q - p - q + p - m *\<^sub>R r =
            m *\<^sub>R r - m *\<^sub>R p - q + p - m *\<^sub>R r"
          by simp
        with scaleR_left_diff_distrib [of 1 m p] and
            scaleR_left_diff_distrib [of 1 m q]
          have "(1 - m) *\<^sub>R p - (1 - m) *\<^sub>R q = m *\<^sub>R q - m *\<^sub>R r" by auto
        with scaleR_right_diff_distrib [of "1 - m" p q] and
            scaleR_right_diff_distrib [of m q r]
          have "(1 - m) *\<^sub>R (p - q) = m *\<^sub>R (q - r)" by simp
        with norm_scaleR [of "1 - m" "p - q"] and norm_scaleR [of m "q - r"]
          have "\<bar>1 - m\<bar> * norm (p - q) = \<bar>m\<bar> * norm (q - r)" by simp
        with \<open>m > 0\<close> and \<open>m \<le> 1\<close>
          have "norm (q - r) = (1 - m) / m * norm (p - q)" by simp
        moreover from \<open>p \<noteq> q\<close> have "norm (p - q) \<noteq> 0" by simp
        ultimately
          have "norm (q - r) / norm (p - q) = (1 - m) / m" by simp
        with \<open>m \<noteq> 0\<close> have
          "norm_dist q r / norm_dist p q = (1 - m) / m" and "m \<noteq> 0" by auto }
      note linelemma = this
      from real_euclid_B_def [of a b c] and \<open>B\<^sub>\<real> a b c\<close>
        obtain l where "0 \<le> l" and "l \<le> 1" and  "b - a = l *\<^sub>R (c - a)" by auto
      from real_euclid_B_def [of a' b' c'] and \<open>B\<^sub>\<real> a' b' c'\<close>
        obtain l' where"0 \<le> l'" and "l' \<le> 1" and  "b' - a' = l' *\<^sub>R (c' - a')" by auto
      from \<open>a \<noteq> b\<close> and \<open>a b \<congruent>\<^sub>\<real> a' b'\<close> have "a' \<noteq> b'" by auto
      from linelemma [of l a b c] and
          \<open>l \<ge> 0\<close> and
          \<open>l \<le> 1\<close> and
          \<open>a \<noteq> b\<close> and
          \<open>b - a = l *\<^sub>R (c - a)\<close>
        have "l \<noteq> 0" and "(1 - l) / l = norm_dist b c / norm_dist a b" by auto
      from \<open>(1 - l) / l = norm_dist b c / norm_dist a b\<close> and
          \<open>a b \<congruent>\<^sub>\<real> a' b'\<close> and
          \<open>b c \<congruent>\<^sub>\<real> b' c'\<close>
        have "(1 - l) / l = norm_dist b' c' / norm_dist a' b'" by simp
      with linelemma [of l' a' b' c'] and
          \<open>l' \<ge> 0\<close> and
          \<open>l' \<le> 1\<close> and
          \<open>a' \<noteq> b'\<close> and
          \<open>b' - a' = l' *\<^sub>R (c' - a')\<close>
        have "l' \<noteq> 0" and "(1 - l) / l = (1 - l') / l'" by auto
      from \<open>(1 - l) / l = (1 - l') / l'\<close>
        have "(1 - l) / l * l * l' = (1 - l') / l' * l * l'" by simp
      with \<open>l \<noteq> 0\<close> and \<open>l' \<noteq> 0\<close> have "(1 - l) * l' = (1 - l') * l" by simp
      with left_diff_distrib [of 1 l l'] and left_diff_distrib [of 1 l' l]
        have "l = l'" by simp
      { fix m
        fix p q r s :: "real^('n::finite)"
        assume "m \<noteq> 0" and
          "q - p = m *\<^sub>R (r - p)"
        with scaleR_scaleR have "r - p = (1/m) *\<^sub>R (q - p)" by simp
        with cosine_rule [of r s p]
          have "(norm_dist r s)\<^sup>2 = (norm_dist r p)\<^sup>2 + (norm_dist p s)\<^sup>2 +
              2 * (((1/m) *\<^sub>R (q - p)) \<bullet> (p - s))"
            by simp
        also from inner_scaleR_left [of "1/m" "q - p" "p - s"]
          have "\<dots> =
              (norm_dist r p)\<^sup>2 + (norm_dist p s)\<^sup>2 + 2/m * ((q - p) \<bullet> (p - s))"
            by simp
        also from \<open>m \<noteq> 0\<close> and cosine_rule [of q s p]
          have "\<dots> = (norm_dist r p)\<^sup>2 + (norm_dist p s)\<^sup>2 +
              1/m * ((norm_dist q s)\<^sup>2 - (norm_dist q p)\<^sup>2 - (norm_dist p s)\<^sup>2)"
            by simp
        finally have "(norm_dist r s)\<^sup>2 = (norm_dist r p)\<^sup>2 + (norm_dist p s)\<^sup>2 +
          1/m * ((norm_dist q s)\<^sup>2 - (norm_dist q p)\<^sup>2 - (norm_dist p s)\<^sup>2)" .
        moreover
        { from norm_dist_dot [of r p] and \<open>r - p = (1/m) *\<^sub>R (q - p)\<close>
            have "(norm_dist r p)\<^sup>2 = ((1/m) *\<^sub>R (q - p)) \<bullet> ((1/m) *\<^sub>R (q - p))"
              by simp
          also from inner_scaleR_left [of "1/m" "q - p"] and
              inner_scaleR_right [of _ "1/m" "q - p"]
            have "\<dots> = 1/m\<^sup>2 * ((q - p) \<bullet> (q - p))"
              by (simp add: power2_eq_square)
          also from norm_dist_dot [of q p] have "\<dots> = 1/m\<^sup>2 * (norm_dist q p)\<^sup>2"
            by simp
          finally have "(norm_dist r p)\<^sup>2 = 1/m\<^sup>2 * (norm_dist q p)\<^sup>2" . }
        ultimately have
          "(norm_dist r s)\<^sup>2 = 1/m\<^sup>2 * (norm_dist q p)\<^sup>2 + (norm_dist p s)\<^sup>2 +
            1/m * ((norm_dist q s)\<^sup>2 - (norm_dist q p)\<^sup>2 - (norm_dist p s)\<^sup>2)"
          by simp
        with norm_metric.symm [of q p]
          have "(norm_dist r s)\<^sup>2 = 1/m\<^sup>2 * (norm_dist p q)\<^sup>2 + (norm_dist p s)\<^sup>2 +
              1/m * ((norm_dist q s)\<^sup>2 - (norm_dist p q)\<^sup>2 - (norm_dist p s)\<^sup>2)"
            by simp }
      note fiveseglemma = this
      from fiveseglemma [of l b a c d] and \<open>l \<noteq> 0\<close> and \<open>b - a = l *\<^sub>R (c - a)\<close>
        have "(norm_dist c d)\<^sup>2 = 1/l\<^sup>2 * (norm_dist a b)\<^sup>2 + (norm_dist a d)\<^sup>2 +
            1/l * ((norm_dist b d)\<^sup>2 - (norm_dist a b)\<^sup>2 - (norm_dist a d)\<^sup>2)"
          by simp
      also from \<open>l = l'\<close> and
          \<open>a b \<congruent>\<^sub>\<real> a' b'\<close> and
          \<open>a d \<congruent>\<^sub>\<real> a' d'\<close> and
          \<open>b d \<congruent>\<^sub>\<real> b' d'\<close>
        have "\<dots> = 1/l'\<^sup>2 * (norm_dist a' b')\<^sup>2 + (norm_dist a' d')\<^sup>2 +
            1/l' * ((norm_dist b' d')\<^sup>2 - (norm_dist a' b')\<^sup>2 - (norm_dist a' d')\<^sup>2)"
          by simp
      also from fiveseglemma [of l' b' a' c' d'] and
          \<open>l' \<noteq> 0\<close> and
          \<open>b' - a' = l' *\<^sub>R (c' - a')\<close>
        have "\<dots> = (norm_dist c' d')\<^sup>2" by simp
      finally have "(norm_dist c d)\<^sup>2 = (norm_dist c' d')\<^sup>2" .
      hence "sqrt ((norm_dist c d)\<^sup>2) = sqrt ((norm_dist c' d')\<^sup>2)" by simp
      with real_sqrt_abs show "c d \<congruent>\<^sub>\<real> c' d'" by simp
    qed }
  thus "\<forall>a b c d a' b' c' d'.
          a \<noteq> b \<and> B\<^sub>\<real> a b c \<and> B\<^sub>\<real> a' b' c' \<and>
          a b \<congruent>\<^sub>\<real> a' b' \<and> b c \<congruent>\<^sub>\<real> b' c' \<and> a d \<congruent>\<^sub>\<real> a' d' \<and> b d \<congruent>\<^sub>\<real> b' d' \<longrightarrow>
            c d \<congruent>\<^sub>\<real> c' d'"
    by blast
qed

subsection "Real Euclidean space also satisfies axioms 6, 7, and 11"

lemma rearrange_real_euclid_B:
  fixes w y z :: "real^('n)" and h
  shows "y - w = h *\<^sub>R (z - w) \<longleftrightarrow> y = h *\<^sub>R z + (1 - h) *\<^sub>R w"
proof
  assume "y - w = h *\<^sub>R (z - w)"
  hence "y - w + w = h *\<^sub>R (z - w) + w" by simp
  hence "y = h *\<^sub>R (z - w) + w" by simp
  with scaleR_right_diff_distrib [of h z w]
    have "y = h *\<^sub>R z + w - h *\<^sub>R w" by simp
  with scaleR_left_diff_distrib [of 1 h w]
    show "y = h *\<^sub>R z + (1 - h) *\<^sub>R w" by simp
next
  assume "y = h *\<^sub>R z + (1 - h) *\<^sub>R w"
  with scaleR_left_diff_distrib [of 1 h w]
    have "y = h *\<^sub>R z + w - h *\<^sub>R w" by simp
  with scaleR_right_diff_distrib [of h z w]
    have "y = h *\<^sub>R (z - w) + w" by simp
  hence "y - w + w = h *\<^sub>R (z - w) + w" by simp
  thus "y - w = h *\<^sub>R (z - w)" by simp
qed

interpretation real_euclid: tarski_absolute_space real_euclid_C real_euclid_B
proof
  { fix a b
    assume "B\<^sub>\<real> a b a"
    with real_euclid_B_def [of a b a]
      obtain l where "b - a = l *\<^sub>R (a - a)" by auto
    hence "a = b" by simp }
  thus "\<forall>a b. B\<^sub>\<real> a b a \<longrightarrow> a = b" by auto
  { fix a b c p q
    assume "B\<^sub>\<real> a p c" and "B\<^sub>\<real> b q c"
    from real_euclid_B_def [of a p c] and \<open>B\<^sub>\<real> a p c\<close>
      obtain i where "i \<ge> 0" and "i \<le> 1" and "p - a = i *\<^sub>R (c - a)" by auto
    have "\<exists>x. B\<^sub>\<real> p x b \<and> B\<^sub>\<real> q x a"
    proof cases
      assume "i = 0"
      with \<open>p - a = i *\<^sub>R (c - a)\<close> have "p = a" by simp
      hence "p - a = 0 *\<^sub>R (b - p)" by simp
      moreover have "(0::real) \<ge> 0" and "(0::real) \<le> 1" by auto
      moreover note real_euclid_B_def [of p a b]
      ultimately have "B\<^sub>\<real> p a b" by auto
      moreover
      { have "a - q = 1 *\<^sub>R (a - q)" by simp
        moreover have "(1::real) \<ge> 0" and "(1::real) \<le> 1" by auto
        moreover note real_euclid_B_def [of q a a]
        ultimately have "B\<^sub>\<real> q a a" by blast }
      ultimately have "B\<^sub>\<real> p a b \<and> B\<^sub>\<real> q a a" by simp
      thus "\<exists>x. B\<^sub>\<real> p x b \<and> B\<^sub>\<real> q x a" by auto
    next
      assume "i \<noteq> 0"
      from real_euclid_B_def [of b q c] and \<open>B\<^sub>\<real> b q c\<close>
        obtain j where "j \<ge> 0" and "j \<le> 1" and "q - b = j *\<^sub>R (c - b)" by auto
      from \<open>i \<ge> 0\<close> and \<open>i \<le> 1\<close>
        have "1 - i \<ge> 0" and "1 - i \<le> 1" by auto
      from \<open>j \<ge> 0\<close> and \<open>1 - i \<ge> 0\<close>
        have "j * (1 - i) \<ge> 0" by auto
      with \<open>i \<ge> 0\<close> and \<open>i \<noteq> 0\<close> have "i + j * (1 - i) > 0" by simp
      hence "i + j * (1 - i) \<noteq> 0" by simp
      let ?l = "j * (1 - i) / (i + j * (1 - i))"
      from diff_divide_distrib [of "i + j * (1 - i)" "j * (1 - i)" "i + j * (1 - i)"] and
          \<open>i + j * (1 - i) \<noteq> 0\<close>
        have "1 - ?l = i / (i + j * (1 - i))" by simp
      let ?k = "i * (1 - j) / (j + i * (1 - j))"
      from right_diff_distrib [of i 1 j] and
          right_diff_distrib [of j 1 i] and
          mult.commute [of i j] and
          add.commute [of i j]
        have "j + i * (1 - j) = i + j * (1 - i)" by simp
      with \<open>i + j * (1 - i) \<noteq> 0\<close> have "j + i * (1 - j) \<noteq> 0" by simp
      with diff_divide_distrib [of "j + i * (1 - j)" "i * (1 - j)" "j + i * (1 - j)"]
        have "1 - ?k = j / (j + i * (1 - j))" by simp
      with \<open>1 - ?l = i / (i + j * (1 - i))\<close> and
          \<open>j + i * (1 - j) = i + j * (1 - i)\<close> and
          times_divide_eq_left [of _ "i + j * (1 - i)"] and
          mult.commute [of i j]
        have "(1 - ?l) * j = (1 - ?k) * i" by simp
      moreover
      { from \<open>1 - ?k = j / (j + i * (1 - j))\<close> and
            \<open>j + i * (1 - j) = i + j * (1 - i)\<close>
          have "?l = (1 - ?k) * (1 - i)" by simp }
      moreover
      { from \<open>1 - ?l = i / (i + j * (1 - i))\<close> and
            \<open>j + i * (1 - j) = i + j * (1 - i)\<close>
          have "(1 - ?l) * (1 - j) = ?k" by simp }
      ultimately
        have "?l *\<^sub>R a + ((1 - ?l) * j) *\<^sub>R c + ((1 - ?l) * (1 - j)) *\<^sub>R b =
            ?k *\<^sub>R b + ((1 - ?k) * i) *\<^sub>R c + ((1 - ?k) * (1 - i)) *\<^sub>R a"
          by simp
      with scaleR_scaleR
        have "?l *\<^sub>R a + (1 - ?l) *\<^sub>R j *\<^sub>R c + (1 - ?l) *\<^sub>R (1 - j) *\<^sub>R b =
            ?k *\<^sub>R b + (1 - ?k) *\<^sub>R i *\<^sub>R c + (1 - ?k) *\<^sub>R (1 - i) *\<^sub>R a"
          by simp
      with scaleR_right_distrib [of "(1 - ?l)" "j *\<^sub>R c" "(1 - j) *\<^sub>R b"] and
          scaleR_right_distrib [of "(1 - ?k)" "i *\<^sub>R c" "(1 - i) *\<^sub>R a"] and
          add.assoc [of "?l *\<^sub>R a" "(1 - ?l) *\<^sub>R j *\<^sub>R c" "(1 - ?l) *\<^sub>R (1 - j) *\<^sub>R b"] and
          add.assoc [of "?k *\<^sub>R b" "(1 - ?k) *\<^sub>R i *\<^sub>R c" "(1 - ?k) *\<^sub>R (1 - i) *\<^sub>R a"]
        have "?l *\<^sub>R a + (1 - ?l) *\<^sub>R (j *\<^sub>R c + (1 - j) *\<^sub>R b) =
            ?k *\<^sub>R b + (1 - ?k) *\<^sub>R (i *\<^sub>R c + (1 - i) *\<^sub>R a)"
          by arith
      from \<open>?l *\<^sub>R a + (1 - ?l) *\<^sub>R (j *\<^sub>R c + (1 - j) *\<^sub>R b) =
            ?k *\<^sub>R b + (1 - ?k) *\<^sub>R (i *\<^sub>R c + (1 - i) *\<^sub>R a)\<close> and
          \<open>p - a = i *\<^sub>R (c - a)\<close> and
          \<open>q - b = j *\<^sub>R (c - b)\<close> and
          rearrange_real_euclid_B [of p a i c] and
          rearrange_real_euclid_B [of q b j c]
        have "?l *\<^sub>R a + (1 - ?l) *\<^sub>R q = ?k *\<^sub>R b + (1 - ?k) *\<^sub>R p" by simp
      let ?x = "?l *\<^sub>R a + (1 - ?l) *\<^sub>R q"
      from rearrange_real_euclid_B [of ?x q ?l a]
        have "?x - q = ?l *\<^sub>R (a - q)" by simp
      from \<open>?x = ?k *\<^sub>R b + (1 - ?k) *\<^sub>R p\<close> and
          rearrange_real_euclid_B [of ?x p ?k b]
        have "?x - p = ?k *\<^sub>R (b - p)" by simp
      from \<open>i + j * (1 - i) > 0\<close> and
          \<open>j * (1 - i) \<ge> 0\<close> and
          zero_le_divide_iff [of "j * (1 - i)" "i + j * (1 - i)"]
        have "?l \<ge> 0" by simp
      from \<open>i + j * (1 - i) > 0\<close> and
          \<open>i \<ge> 0\<close> and
          zero_le_divide_iff [of i "i + j * (1 - i)"] and
          \<open>1 - ?l = i / (i + j * (1 - i))\<close>
        have "1 - ?l \<ge> 0" by simp
      hence "?l \<le> 1" by simp
      with \<open>?l \<ge> 0\<close> and
          \<open>?x - q = ?l *\<^sub>R (a - q)\<close> and
          real_euclid_B_def [of q ?x a]
        have "B\<^sub>\<real> q ?x a" by auto
      from \<open>j \<le> 1\<close> have "1 - j \<ge> 0" by simp
      with \<open>1 - ?l \<ge> 0\<close> and
          \<open>(1 - ?l) * (1 - j) = ?k\<close> and
          zero_le_mult_iff [of "1 - ?l" "1 - j"]
        have "?k \<ge> 0" by simp
      from \<open>j \<ge> 0\<close> have "1 - j \<le> 1" by simp
      from \<open>?l \<ge> 0\<close> have "1 - ?l \<le> 1" by simp
      with \<open>1 - j \<le> 1\<close> and
          \<open>1 - j \<ge> 0\<close> and
          mult_mono [of "1 - ?l" 1 "1 - j" 1] and
          \<open>(1 - ?l) * (1 - j) = ?k\<close>
        have "?k \<le> 1" by simp
      with \<open>?k \<ge> 0\<close> and
          \<open>?x - p = ?k *\<^sub>R (b - p)\<close> and
          real_euclid_B_def [of p ?x b]
        have "B\<^sub>\<real> p ?x b" by auto
      with \<open>B\<^sub>\<real> q ?x a\<close> show ?thesis by auto
    qed }
  thus "\<forall>a b c p q. B\<^sub>\<real> a p c \<and> B\<^sub>\<real> b q c \<longrightarrow> (\<exists>x. B\<^sub>\<real> p x b \<and> B\<^sub>\<real> q x a)" by auto
  { fix X Y
    assume "\<exists>a. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y"
    then obtain a where "\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y" by auto
    have "\<exists>b. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> x b y"
    proof cases
      assume "X \<subseteq> {a} \<or> Y = {}"
      let ?b = a
      { fix x y
        assume "x \<in> X" and "y \<in> Y"
        with \<open>X \<subseteq> {a} \<or> Y = {}\<close> have "x = a" by auto
        from \<open>\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y\<close> and \<open>x \<in> X\<close> and \<open>y \<in> Y\<close>
          have "B\<^sub>\<real> a x y" by simp
        with \<open>x = a\<close> have "B\<^sub>\<real> x ?b y" by simp }
      hence "\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> x ?b y" by simp
      thus ?thesis by auto
    next
      assume "\<not>(X \<subseteq> {a} \<or> Y = {})"
      hence "X - {a} \<noteq> {}" and "Y \<noteq> {}" by auto
      from \<open>X - {a} \<noteq> {}\<close> obtain c where "c \<in> X" and "c \<noteq> a" by auto
      from \<open>c \<noteq> a\<close> have "c - a \<noteq> 0" by simp
      { fix y
        assume "y \<in> Y"
        with \<open>\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y\<close> and \<open>c \<in> X\<close>
          have "B\<^sub>\<real> a c y" by simp
        with real_euclid_B_def [of a c y]
          obtain l where "l \<ge> 0" and "l \<le> 1" and "c - a = l *\<^sub>R (y - a)" by auto
        from \<open>c - a = l *\<^sub>R (y - a)\<close> and \<open>c - a \<noteq> 0\<close> have "l \<noteq> 0" by simp
        with \<open>l \<ge> 0\<close> have "l > 0" by simp
        with \<open>c - a = l *\<^sub>R (y - a)\<close> have "y - a = (1/l) *\<^sub>R (c - a)" by simp
        from \<open>l > 0\<close> and \<open>l \<le> 1\<close> have "1/l \<ge> 1" by simp
        with \<open>y - a = (1/l) *\<^sub>R (c - a)\<close>
          have "\<exists>j\<ge>1. y - a = j *\<^sub>R (c - a)" by auto }
      note ylemma = this
      from \<open>Y \<noteq> {}\<close> obtain d where "d \<in> Y" by auto
      with ylemma [of d]
        obtain "jd" where "jd \<ge> 1" and "d - a = jd *\<^sub>R (c - a)" by auto
      { fix x
        assume "x \<in> X"
        with \<open>\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y\<close> and \<open>d \<in> Y\<close>
          have "B\<^sub>\<real> a x d" by simp
        with real_euclid_B_def [of a x d]
          obtain l where "l \<ge> 0" and "x - a = l *\<^sub>R (d - a)" by auto
        from \<open>x - a = l *\<^sub>R (d - a)\<close> and
            \<open>d - a = jd *\<^sub>R (c - a)\<close> and
            scaleR_scaleR
          have "x - a = (l * jd) *\<^sub>R (c - a)" by simp
        hence "\<exists>i. x - a = i *\<^sub>R (c - a)" by auto }
      note xlemma = this
      let ?S = "{j. j \<ge> 1 \<and> (\<exists>y\<in>Y. y - a = j *\<^sub>R (c - a))}"
      from \<open>d \<in> Y\<close> and \<open>jd \<ge> 1\<close> and \<open>d - a = jd *\<^sub>R (c - a)\<close>
        have "?S \<noteq> {}" by auto
      let ?k = "Inf ?S"
      let ?b = "?k *\<^sub>R c + (1 - ?k) *\<^sub>R a"
      from rearrange_real_euclid_B [of ?b a ?k c]
        have "?b - a = ?k *\<^sub>R (c - a)" by simp
      { fix x y
        assume "x \<in> X" and "y \<in> Y"
        from xlemma [of x] and \<open>x \<in> X\<close>
          obtain i where "x - a = i *\<^sub>R (c - a)" by auto
        from ylemma [of y] and \<open>y \<in> Y\<close>
          obtain j where "j \<ge> 1" and "y - a = j *\<^sub>R (c - a)" by auto
        with \<open>y \<in> Y\<close> have "j \<in> ?S" by auto
        then have "?k \<le> j" by (auto intro: cInf_lower)
        { fix h
          assume "h \<in> ?S"
          hence "h \<ge> 1" by simp
          from \<open>h \<in> ?S\<close>
            obtain z where "z \<in> Y" and "z - a = h *\<^sub>R (c - a)" by auto
          from \<open>\<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y\<close> and \<open>x \<in> X\<close> and \<open>z \<in> Y\<close>
            have "B\<^sub>\<real> a x z" by simp
          with real_euclid_B_def [of a x z]
            obtain l where "l \<le> 1" and "x - a = l *\<^sub>R (z - a)" by auto
          with \<open>z - a = h *\<^sub>R (c - a)\<close> and scaleR_scaleR
            have "x - a = (l * h) *\<^sub>R (c - a)" by simp
          with \<open>x - a = i *\<^sub>R (c - a)\<close>
            have "i *\<^sub>R (c - a) = (l * h) *\<^sub>R (c - a)" by auto
          with scaleR_cancel_right and \<open>c - a \<noteq> 0\<close> have "i = l * h" by blast
          with \<open>l \<le> 1\<close> and \<open>h \<ge> 1\<close> have "i \<le> h" by simp }
        with \<open>?S \<noteq> {}\<close> and cInf_greatest [of ?S] have "i \<le> ?k" by simp
        have "y - x = (y - a) - (x - a)" by simp
        with \<open>y - a = j *\<^sub>R (c - a)\<close> and \<open>x - a = i *\<^sub>R (c - a)\<close>
          have "y - x = j *\<^sub>R (c - a) - i *\<^sub>R (c - a)" by simp
        with scaleR_left_diff_distrib [of j i "c - a"]
          have "y - x = (j - i) *\<^sub>R (c - a)" by simp
        have "?b - x = (?b - a) - (x - a)" by simp
        with \<open>?b - a = ?k *\<^sub>R (c - a)\<close> and \<open>x - a = i *\<^sub>R (c - a)\<close>
          have "?b - x = ?k *\<^sub>R (c - a) - i *\<^sub>R (c - a)" by simp
        with scaleR_left_diff_distrib [of ?k i "c - a"]
          have "?b - x = (?k - i) *\<^sub>R (c - a)" by simp
        have "B\<^sub>\<real> x ?b y"
        proof cases
          assume "i = j"
          with \<open>i \<le> ?k\<close> and \<open>?k \<le> j\<close> have "?k = i" by simp
          with \<open>?b - x = (?k - i) *\<^sub>R (c - a)\<close> have "?b - x = 0" by simp
          hence "?b - x = 0 *\<^sub>R (y - x)" by simp
          with real_euclid_B_def [of x ?b y] show "B\<^sub>\<real> x ?b y" by auto
        next
          assume "i \<noteq> j"
          with \<open>i \<le> ?k\<close> and \<open>?k \<le> j\<close> have "j - i > 0" by simp
          with \<open>y - x = (j - i) *\<^sub>R (c - a)\<close> and scaleR_scaleR
            have "c - a = (1 / (j - i)) *\<^sub>R (y - x)" by simp
          with \<open>?b - x = (?k - i) *\<^sub>R (c - a)\<close> and scaleR_scaleR
            have "?b - x = ((?k - i) / (j - i)) *\<^sub>R (y - x)" by simp
          let ?l = "(?k - i) / (j - i)"
          from \<open>?k \<le> j\<close> have "?k - i \<le> j - i" by simp
          with \<open>j - i > 0\<close> have "?l \<le> 1" by simp
          from \<open>i \<le> ?k\<close> and \<open>j - i > 0\<close> and pos_le_divide_eq [of "j - i" 0 "?k - i"]
            have "?l \<ge> 0" by simp
          with real_euclid_B_def [of x ?b y] and
              \<open>?l \<le> 1\<close> and
              \<open>?b - x = ?l *\<^sub>R (y - x)\<close>
            show "B\<^sub>\<real> x ?b y" by auto
        qed }
      thus "\<exists>b. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> x b y" by auto
    qed }
  thus "\<forall>X Y. (\<exists>a. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> a x y) \<longrightarrow>
          (\<exists>b. \<forall>x y. x \<in> X \<and> y \<in> Y \<longrightarrow> B\<^sub>\<real> x b y)"
    by auto
qed

subsection "Real Euclidean space satisfies the Euclidean axiom"

lemma rearrange_real_euclid_B_2:
  fixes a b c :: "real^('n::finite)"
  assumes "l \<noteq> 0"
  shows "b - a = l *\<^sub>R (c - a) \<longleftrightarrow> c = (1/l) *\<^sub>R b + (1 - 1/l) *\<^sub>R a"
proof
  from scaleR_right_diff_distrib [of "1/l" b a]
    have "(1/l) *\<^sub>R (b - a) = c - a \<longleftrightarrow> (1/l) *\<^sub>R b - (1/l) *\<^sub>R a + a = c" by auto
  also with scaleR_left_diff_distrib [of 1 "1/l" a]
    have "\<dots> \<longleftrightarrow> c = (1/l) *\<^sub>R b + (1 - 1/l) *\<^sub>R a" by auto
  finally have eq:
    "(1/l) *\<^sub>R (b - a) = c - a \<longleftrightarrow> c = (1/l) *\<^sub>R b + (1 - 1/l) *\<^sub>R a" .
  { assume "b - a = l *\<^sub>R (c - a)"
    with \<open>l \<noteq> 0\<close> have "(1/l) *\<^sub>R (b - a) = c - a" by simp
    with eq show "c = (1/l) *\<^sub>R b + (1 - 1/l) *\<^sub>R a" .. }
  { assume "c = (1/l) *\<^sub>R b + (1 - 1/l) *\<^sub>R a"
    with eq have "(1/l) *\<^sub>R (b - a) = c - a" ..
    hence "l *\<^sub>R (1/l) *\<^sub>R (b - a) = l *\<^sub>R (c - a)" by simp
    with \<open>l \<noteq> 0\<close> show "b - a = l *\<^sub>R (c - a)" by simp }
qed

interpretation real_euclid: tarski_space real_euclid_C real_euclid_B
proof
  { fix a b c d t
    assume "B\<^sub>\<real> a d t" and "B\<^sub>\<real> b d c" and "a \<noteq> d"
    from real_euclid_B_def [of a d t] and \<open>B\<^sub>\<real> a d t\<close>
      obtain j where "j \<ge> 0" and "j \<le> 1" and "d - a = j *\<^sub>R (t - a)" by auto
    from \<open>d - a = j *\<^sub>R (t - a)\<close> and \<open>a \<noteq> d\<close> have "j \<noteq> 0" by auto
    with \<open>d - a = j *\<^sub>R (t - a)\<close> and rearrange_real_euclid_B_2
      have "t = (1/j) *\<^sub>R d + (1 - 1/j) *\<^sub>R a" by auto
    let ?x = "(1/j) *\<^sub>R b + (1 - 1/j) *\<^sub>R a"
    let ?y = "(1/j) *\<^sub>R c + (1 - 1/j) *\<^sub>R a"
    from \<open>j \<noteq> 0\<close> and rearrange_real_euclid_B_2 have
      "b - a = j *\<^sub>R (?x - a)" and "c - a = j *\<^sub>R (?y - a)" by auto
    with real_euclid_B_def and \<open>j \<ge> 0\<close> and \<open>j \<le> 1\<close> have
      "B\<^sub>\<real> a b ?x" and "B\<^sub>\<real> a c ?y" by auto
    from real_euclid_B_def and \<open>B\<^sub>\<real> b d c\<close> obtain k where
      "k \<ge> 0" and "k \<le> 1" and "d - b = k *\<^sub>R (c - b)" by blast
    from \<open>t = (1/j) *\<^sub>R d + (1 - 1/j) *\<^sub>R a\<close> have
      "t - ?x = (1/j) *\<^sub>R d - (1/j) *\<^sub>R b" by simp
    also from scaleR_right_diff_distrib [of "1/j" d b] have
      "\<dots> = (1/j) *\<^sub>R (d - b)" by simp
    also from \<open>d - b = k *\<^sub>R (c - b)\<close> have
      "\<dots> = k *\<^sub>R (1/j) *\<^sub>R (c - b)" by simp
    also from scaleR_right_diff_distrib [of "1/j" c b] have
      "\<dots> = k *\<^sub>R (?y - ?x)" by simp
    finally have "t - ?x = k *\<^sub>R (?y - ?x)" .
    with real_euclid_B_def and \<open>k \<ge> 0\<close> and \<open>k \<le> 1\<close> have "B\<^sub>\<real> ?x t ?y" by blast
    with \<open>B\<^sub>\<real> a b ?x\<close> and \<open>B\<^sub>\<real> a c ?y\<close> have
      "\<exists>x y. B\<^sub>\<real> a b x \<and> B\<^sub>\<real> a c y \<and> B\<^sub>\<real> x t y" by auto }
  thus "\<forall>a b c d t. B\<^sub>\<real> a d t \<and> B\<^sub>\<real> b d c \<and> a \<noteq> d \<longrightarrow>
            (\<exists>x y. B\<^sub>\<real> a b x \<and> B\<^sub>\<real> a c y \<and> B\<^sub>\<real> x t y)"
    by auto
qed

subsection "The real Euclidean plane"

lemma Col_dep2:
  "real_euclid.Col a b c \<longleftrightarrow> dep2 (b - a) (c - a)"
proof -
  from real_euclid.Col_def have
    "real_euclid.Col a b c \<longleftrightarrow> B\<^sub>\<real> a b c \<or> B\<^sub>\<real> b c a \<or> B\<^sub>\<real> c a b" by auto
  moreover from dep2_def have
    "dep2 (b - a) (c - a) \<longleftrightarrow> (\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w)"
    by auto
  moreover
  { assume "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> b c a \<or> B\<^sub>\<real> c a b"
    moreover
    { assume "B\<^sub>\<real> a b c"
      with real_euclid_B_def obtain l where "b - a = l *\<^sub>R (c - a)" by blast
      moreover have "c - a = 1 *\<^sub>R (c - a)" by simp
      ultimately have "\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w" by blast }
    moreover
    { assume "B\<^sub>\<real> b c a"
      with real_euclid_B_def obtain l where "c - b = l *\<^sub>R (a - b)" by blast
      moreover have "c - a = (c - b) - (a - b)" by simp
      ultimately have "c - a = l *\<^sub>R (a - b) - (a - b)" by simp
      with scaleR_left_diff_distrib [of l 1 "a - b"] have
        "c - a = (l - 1) *\<^sub>R (a - b)" by simp
      moreover from scaleR_minus_left [of 1 "a - b"] have
        "b - a = (-1) *\<^sub>R (a - b)" by simp
      ultimately have "\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w" by blast }
    moreover
    { assume "B\<^sub>\<real> c a b"
      with real_euclid_B_def obtain l where "a - c = l *\<^sub>R (b - c)" by blast
      moreover have "c - a = -(a - c)" by simp
      ultimately have "c - a = -(l *\<^sub>R (b - c))" by simp
      with scaleR_minus_left have "c - a = (-l) *\<^sub>R (b - c)" by simp
      moreover have "b - a = (b - c) + (c - a)" by simp
      ultimately have "b - a = 1 *\<^sub>R (b - c) + (-l) *\<^sub>R (b - c)" by simp
      with scaleR_left_distrib [of 1 "-l" "b - c"] have
        "b - a = (1 + (-l)) *\<^sub>R (b - c)" by simp
      with \<open>c - a = (-l) *\<^sub>R (b - c)\<close> have
        "\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w" by blast }
    ultimately have "\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w" by auto }
  moreover
  { assume "\<exists>w r s. b - a = r *\<^sub>R w \<and> c - a = s *\<^sub>R w"
    then obtain w r s where "b - a = r *\<^sub>R w" and "c - a = s *\<^sub>R w" by auto
    have "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> b c a \<or> B\<^sub>\<real> c a b"
    proof cases
      assume "s = 0"
      with \<open>c - a = s *\<^sub>R w\<close> have "a = c" by simp
      with real_euclid.th3_1 have "B\<^sub>\<real> b c a" by simp
      thus ?thesis by simp
    next
      assume "s \<noteq> 0"
      with \<open>c - a = s *\<^sub>R w\<close> have "w = (1/s) *\<^sub>R (c - a)" by simp
      with \<open>b - a = r *\<^sub>R w\<close> have "b - a = (r/s) *\<^sub>R (c - a)" by simp
      have "r/s < 0 \<or> (r/s \<ge> 0 \<and> r/s \<le> 1) \<or> r/s > 1" by arith
      moreover
      { assume "r/s \<ge> 0 \<and> r/s \<le> 1"
        with real_euclid_B_def and \<open>b - a = (r/s) *\<^sub>R (c - a)\<close> have "B\<^sub>\<real> a b c"
          by auto
        hence ?thesis by simp }
      moreover
      { assume "r/s > 1"
        with \<open>b - a = (r/s) *\<^sub>R (c - a)\<close> have "c - a = (s/r) *\<^sub>R (b - a)" by auto
        from \<open>r/s > 1\<close> and le_imp_inverse_le [of 1 "r/s"] have
          "s/r \<le> 1" by simp
        from \<open>r/s > 1\<close> and inverse_positive_iff_positive [of "r/s"] have
          "s/r \<ge> 0" by simp
        with real_euclid_B_def
          and \<open>c - a = (s/r) *\<^sub>R (b - a)\<close>
          and \<open>s/r \<le> 1\<close>
        have "B\<^sub>\<real> a c b" by auto
        with real_euclid.th3_2 have "B\<^sub>\<real> b c a" by auto
        hence ?thesis by simp }
      moreover
      { assume "r/s < 0"
        have "b - c = (b - a) + (a - c)" by simp
        with \<open>b - a = (r/s) *\<^sub>R (c - a)\<close> have
          "b - c = (r/s) *\<^sub>R (c - a) + (a - c)" by simp
        have "c - a = -(a - c)" by simp
        with scaleR_minus_right [of "r/s" "a - c"] have
          "(r/s) *\<^sub>R (c - a) = -((r/s) *\<^sub>R (a - c))" by arith
        with \<open>b - c = (r/s) *\<^sub>R (c - a) + (a - c)\<close> have
          "b - c = -(r/s) *\<^sub>R (a - c) + (a - c)" by simp
        with scaleR_left_distrib [of "-(r/s)" 1 "a - c"] have
          "b - c = (-(r/s) + 1) *\<^sub>R (a - c)" by simp
        moreover from \<open>r/s < 0\<close> have "-(r/s) + 1 > 1" by simp
        ultimately have "a - c = (1 / (-(r/s) + 1)) *\<^sub>R (b - c)" by auto
        let ?l = "1 / (-(r/s) + 1)"
        from \<open>-(r/s) + 1 > 1\<close> and le_imp_inverse_le [of 1 "-(r/s) + 1"] have
          "?l \<le> 1" by simp
        from \<open>-(r/s) + 1 > 1\<close>
          and inverse_positive_iff_positive [of "-(r/s) + 1"]
        have
          "?l \<ge> 0" by simp
        with real_euclid_B_def and \<open>?l \<le> 1\<close> and \<open>a - c = ?l *\<^sub>R (b - c)\<close> have
          "B\<^sub>\<real> c a b" by blast
        hence ?thesis by simp }
      ultimately show ?thesis by auto
    qed }
  ultimately show ?thesis by blast
qed

lemma non_Col_example:
  "\<not>(real_euclid.Col 0 (vector [1/2,0] :: real^2) (vector [0,1/2]))"
  (is "\<not> (real_euclid.Col ?a ?b ?c)")
proof -
  { assume "dep2 (?b - ?a) (?c - ?a)"
    with dep2_def [of "?b - ?a" "?c - ?a"] obtain w r s where
      "?b - ?a = r *\<^sub>R w" and "?c - ?a = s *\<^sub>R w" by auto
    have "?b$1 = 1/2" by simp
    with \<open>?b - ?a = r *\<^sub>R w\<close> have "r * (w$1) = 1/2" by simp
    hence "w$1 \<noteq> 0" by auto
    have "?c$1 = 0" by simp
    with \<open>?c - ?a = s *\<^sub>R w\<close> have "s * (w$1) = 0" by simp
    with \<open>w$1 \<noteq> 0\<close> have "s = 0" by simp
    have "?c$2 = 1/2" by simp
    with \<open>?c - ?a = s *\<^sub>R w\<close> have "s * (w$2) = 1/2" by simp
    with \<open>s = 0\<close> have False by simp }
  hence "\<not>(dep2 (?b - ?a) (?c - ?a))" by auto
  with Col_dep2 show "\<not>(real_euclid.Col ?a ?b ?c)" by blast
qed

interpretation real_euclid:
  tarski "real_euclid_C::([real^2, real^2, real^2, real^2] \<Rightarrow> bool)" real_euclid_B
proof
  { let ?a = "0 :: real^2"
    let ?b = "vector [1/2, 0] :: real^2"
    let ?c = "vector [0, 1/2] :: real^2"
    from non_Col_example and real_euclid.Col_def have
      "\<not> B\<^sub>\<real> ?a ?b ?c \<and> \<not> B\<^sub>\<real> ?b ?c ?a \<and> \<not> B\<^sub>\<real> ?c ?a ?b" by auto }
  thus "\<exists>a b c :: real^2. \<not> B\<^sub>\<real> a b c \<and> \<not> B\<^sub>\<real> b c a \<and> \<not> B\<^sub>\<real> c a b"
    by auto
  { fix p q a b c :: "real^2"
    assume "p \<noteq> q" and "a p \<congruent>\<^sub>\<real>  a q" and "b p \<congruent>\<^sub>\<real> b q" and "c p \<congruent>\<^sub>\<real> c q"
    let ?m = "(1/2) *\<^sub>R (p + q)"
    from scaleR_right_distrib [of "1/2" p q] and
      scaleR_right_diff_distrib [of "1/2" q p] and
      scaleR_left_diff_distrib [of "1/2" 1 p]
    have "?m - p = (1/2) *\<^sub>R (q - p)" by simp
    with \<open>p \<noteq> q\<close> have "?m - p \<noteq> 0" by simp
    from scaleR_right_distrib [of "1/2" p q] and
      scaleR_right_diff_distrib [of "1/2" p q] and
      scaleR_left_diff_distrib [of "1/2" 1 q]
    have "?m - q = (1/2) *\<^sub>R (p - q)" by simp
    with \<open>?m - p = (1/2) *\<^sub>R (q - p)\<close>
      and scaleR_minus_right [of "1/2" "q - p"]
    have "?m - q = -(?m - p)" by simp
    with norm_minus_cancel [of "?m - p"] have
      "(norm (?m - q))\<^sup>2 = (norm (?m - p))\<^sup>2" by (simp only: norm_minus_cancel)
    { fix d
      assume "d p \<congruent>\<^sub>\<real> d q"
      hence "(norm (d - p))\<^sup>2 = (norm (d - q))\<^sup>2" by simp
      have "(d - ?m) \<bullet> (?m - p) = 0"
      proof -
        have "d + (-q) = d - q" by simp
        have "d + (-p) = d - p" by simp
        with dot_norm [of "d - ?m" "?m - p"] have
          "(d - ?m) \<bullet> (?m - p) =
          ((norm (d - p))\<^sup>2 - (norm (d - ?m))\<^sup>2 - (norm(?m - p))\<^sup>2) / 2"
          by simp
        also from \<open>(norm (d - p))\<^sup>2 = (norm (d - q))\<^sup>2\<close>
          and \<open>(norm (?m - q))\<^sup>2 = (norm (?m - p))\<^sup>2\<close>
        have
          "\<dots> = ((norm (d - q))\<^sup>2 - (norm (d - ?m))\<^sup>2 - (norm(?m - q))\<^sup>2) / 2"
          by simp
        also from dot_norm [of "d - ?m" "?m - q"]
          and \<open>d + (-q) = d - q\<close>
        have
          "\<dots> = (d - ?m) \<bullet> (?m - q)" by simp
        also from inner_minus_right [of "d - ?m" "?m - p"]
          and \<open>?m - q = -(?m - p)\<close>
        have
          "\<dots> = -((d - ?m) \<bullet> (?m - p))" by (simp only: inner_minus_left)
        finally have "(d - ?m) \<bullet> (?m - p) = -((d - ?m) \<bullet> (?m - p))" .
        thus "(d - ?m) \<bullet> (?m - p) = 0" by arith
      qed }
    note m_lemma = this
    with \<open>a p \<congruent>\<^sub>\<real> a q\<close> have "(a - ?m) \<bullet> (?m - p) = 0" by simp
    { fix d
      assume "d p \<congruent>\<^sub>\<real> d q"
      with m_lemma have "(d - ?m) \<bullet> (?m - p) = 0" by simp
      with dot_left_diff_distrib [of "d - ?m" "a - ?m" "?m - p"]
        and \<open>(a - ?m) \<bullet> (?m - p) = 0\<close>
      have "(d - a) \<bullet> (?m - p) = 0" by (simp add: inner_diff_left inner_diff_right) }
    with \<open>b p \<congruent>\<^sub>\<real> b q\<close> and \<open>c p \<congruent>\<^sub>\<real> c q\<close> have
      "(b - a) \<bullet> (?m - p) = 0" and "(c - a) \<bullet> (?m - p) = 0" by simp+
    with real2_orthogonal_dep2 and \<open>?m - p \<noteq> 0\<close> have "dep2 (b - a) (c - a)"
      by blast
    with Col_dep2 have "real_euclid.Col a b c" by auto
    with real_euclid.Col_def have "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> b c a \<or> B\<^sub>\<real> c a b" by auto }
  thus "\<forall>p q a b c :: real^2.
          p \<noteq> q \<and> a p \<congruent>\<^sub>\<real> a q \<and> b p \<congruent>\<^sub>\<real> b q \<and> c p \<congruent>\<^sub>\<real> c q \<longrightarrow>
            B\<^sub>\<real> a b c \<or> B\<^sub>\<real> b c a \<or> B\<^sub>\<real> c a b"
    by blast
qed

subsection \<open>Special cases of theorems of Tarski's geometry\<close>

lemma real_euclid_B_disjunction:
  assumes "l \<ge> 0" and "b - a = l *\<^sub>R (c - a)"
  shows "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b"
proof cases
  assume "l \<le> 1"
  with \<open>l \<ge> 0\<close> and \<open>b - a = l *\<^sub>R (c - a)\<close>
  have "B\<^sub>\<real> a b c" by (unfold real_euclid_B_def) (simp add: exI [of _ l])
  thus "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b" ..
next
  assume "\<not> (l \<le> 1)"
  hence "1/l \<le> 1" by simp

  from \<open>l \<ge> 0\<close> have "1/l \<ge> 0" by simp

  from \<open>b - a = l *\<^sub>R (c - a)\<close>
  have "(1/l) *\<^sub>R (b - a) = (1/l) *\<^sub>R (l *\<^sub>R (c - a))" by simp
  with \<open>\<not> (l \<le> 1)\<close> have "c - a = (1/l) *\<^sub>R (b - a)" by simp
  with \<open>1/l \<ge> 0\<close> and \<open>1/l \<le> 1\<close>
  have "B\<^sub>\<real> a c b" by (unfold real_euclid_B_def) (simp add: exI [of _ "1/l"])
  thus "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b" ..
qed

text \<open>The following are true in Tarski's geometry,
  but to prove this would require much more development of it,
  so only the Euclidean case is proven here.\<close>

theorem real_euclid_th5_1:
  assumes "a \<noteq> b" and "B\<^sub>\<real> a b c" and "B\<^sub>\<real> a b d"
  shows "B\<^sub>\<real> a c d \<or> B\<^sub>\<real> a d c"
proof -
  from \<open>B\<^sub>\<real> a b c\<close> and \<open>B\<^sub>\<real> a b d\<close>
  obtain l and m where "l \<ge> 0" and "b - a = l *\<^sub>R (c - a)"
    and "m \<ge> 0" and "b - a = m *\<^sub>R (d - a)"
    by (unfold real_euclid_B_def) auto
  from \<open>b - a = m *\<^sub>R (d - a)\<close> and \<open>a \<noteq> b\<close> have "m \<noteq> 0" by auto

  from \<open>l \<ge> 0\<close> and \<open>m \<ge> 0\<close> have "l/m \<ge> 0" by (simp add: zero_le_divide_iff)

  from \<open>b - a = l *\<^sub>R (c - a)\<close> and \<open>b - a = m *\<^sub>R (d - a)\<close>
  have "m *\<^sub>R (d - a) = l *\<^sub>R (c - a)" by simp
  hence "(1/m) *\<^sub>R (m *\<^sub>R (d - a)) = (1/m) *\<^sub>R (l *\<^sub>R (c - a))" by simp
  with \<open>m \<noteq> 0\<close> have "d - a = (l/m) *\<^sub>R (c - a)" by simp
  with \<open>l/m \<ge> 0\<close> and real_euclid_B_disjunction
  show "B\<^sub>\<real> a c d \<or> B\<^sub>\<real> a d c" by auto
qed

theorem real_euclid_th5_3:
  assumes "B\<^sub>\<real> a b d" and "B\<^sub>\<real> a c d"
  shows "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b"
proof -
  from \<open>B\<^sub>\<real> a b d\<close> and \<open>B\<^sub>\<real> a c d\<close>
  obtain l and m where "l \<ge> 0" and "b - a = l *\<^sub>R (d - a)"
    and "m \<ge> 0" and "c - a = m *\<^sub>R (d - a)"
    by (unfold real_euclid_B_def) auto

  show "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b"
  proof cases
    assume "l = 0"
    with \<open>b - a = l *\<^sub>R (d - a)\<close> have "b - a = l *\<^sub>R (c - a)" by simp
    with \<open>l = 0\<close>
    have "B\<^sub>\<real> a b c" by (unfold real_euclid_B_def) (simp add: exI [of _ l])
    thus "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b" ..
  next
    assume "l \<noteq> 0"

    from \<open>l \<ge> 0\<close> and \<open>m \<ge> 0\<close> have "m/l \<ge> 0" by (simp add: zero_le_divide_iff)

    from \<open>b - a = l *\<^sub>R (d - a)\<close>
    have "(1/l) *\<^sub>R (b - a) = (1/l) *\<^sub>R (l *\<^sub>R (d - a))" by simp
    with \<open>l \<noteq> 0\<close> have "d - a = (1/l) *\<^sub>R (b - a)" by simp
    with \<open>c - a = m *\<^sub>R (d - a)\<close> have "c - a = (m/l) *\<^sub>R (b - a)" by simp
    with \<open>m/l \<ge> 0\<close> and real_euclid_B_disjunction
    show "B\<^sub>\<real> a b c \<or> B\<^sub>\<real> a c b" by auto
  qed
qed

end