(*  Title:      HOL/Hahn_Banach/Linearform.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Linearforms\<close>

theory Linearform
imports Vector_Space
begin

text \<open>
  A \<^emph>\<open>linear form\<close> is a function on a vector space into the reals that is
  additive and multiplicative.
\<close>

locale linearform =
  fixes V :: "'a::{minus, plus, zero, uminus} set" and f
  assumes add [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> f (x + y) = f x + f y"
    and mult [iff]: "x \<in> V \<Longrightarrow> f (a \<cdot> x) = a * f x"

declare linearform.intro [intro?]

lemma (in linearform) neg [iff]:
  assumes "vectorspace V"
  shows "x \<in> V \<Longrightarrow> f (- x) = - f x"
proof -
  interpret vectorspace V by fact
  assume x: "x \<in> V"
  then have "f (- x) = f ((- 1) \<cdot> x)" by (simp add: negate_eq1)
  also from x have "\<dots> = (- 1) * (f x)" by (rule mult)
  also from x have "\<dots> = - (f x)" by simp
  finally show ?thesis .
qed

lemma (in linearform) diff [iff]:
  assumes "vectorspace V"
  shows "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> f (x - y) = f x - f y"
proof -
  interpret vectorspace V by fact
  assume x: "x \<in> V" and y: "y \<in> V"
  then have "x - y = x + - y" by (rule diff_eq1)
  also have "f \<dots> = f x + f (- y)" by (rule add) (simp_all add: x y)
  also have "f (- y) = - f y" using \<open>vectorspace V\<close> y by (rule neg)
  finally show ?thesis by simp
qed

text \<open>Every linear form yields \<open>0\<close> for the \<open>0\<close> vector.\<close>

lemma (in linearform) zero [iff]:
  assumes "vectorspace V"
  shows "f 0 = 0"
proof -
  interpret vectorspace V by fact
  have "f 0 = f (0 - 0)" by simp
  also have "\<dots> = f 0 - f 0" using \<open>vectorspace V\<close> by (rule diff) simp_all
  also have "\<dots> = 0" by simp
  finally show ?thesis .
qed

end


theory Graph_Genus
imports
  "HOL-Combinatorics.Permutations"
  Graph_Theory.Graph_Theory
begin

lemma nat_diff_mod_right:
  fixes a b c :: nat
  assumes "b < a"
  shows "(a - b) mod c = (a - b mod c) mod c"
proof -
  from assms have b_mod: "b mod c \<le> a"
    by (metis mod_less_eq_dividend linear not_le order_trans)
  have "int ((a - b) mod c) = (int a - int b mod int c) mod int c"
    using assms by (simp add: zmod_int of_nat_diff mod_simps)
  also have "\<dots> = int ((a - b mod c) mod c)"
    using assms b_mod
    by (simp add: zmod_int [symmetric] of_nat_diff [symmetric])
  finally show ?thesis by simp
qed

lemma inj_on_f_imageI:
  assumes "inj_on f S" "\<And>t. t \<in> T \<Longrightarrow> t \<subseteq> S"
  shows "inj_on ((`) f) T"
  using assms by (auto simp: inj_on_image_eq_iff intro: inj_onI)

section \<open>Combinatorial Maps\<close>

lemma (in bidirected_digraph) has_dom_arev:
  "has_dom arev (arcs G)"
  using arev_dom by (auto simp: has_dom_def)

record 'b pre_map =
  edge_rev :: "'b \<Rightarrow> 'b"
  edge_succ :: "'b \<Rightarrow> 'b"

definition edge_pred :: "'b pre_map \<Rightarrow> 'b \<Rightarrow> 'b" where
  "edge_pred M = inv (edge_succ M)"

locale pre_digraph_map = pre_digraph + fixes M :: "'b pre_map"

locale digraph_map = fin_digraph G
  + pre_digraph_map G M
  + bidirected_digraph G "edge_rev M" for G M +
  assumes edge_succ_permutes: "edge_succ M permutes arcs G"
  assumes edge_succ_cyclic: "\<And>v. v \<in> verts G \<Longrightarrow> out_arcs G v \<noteq> {} \<Longrightarrow> cyclic_on (edge_succ M) (out_arcs G v)"

lemma (in fin_digraph) digraph_mapI:
  assumes bidi: "\<And>a. a \<notin> arcs G \<Longrightarrow> edge_rev M a = a"
    "\<And>a. a \<in> arcs G \<Longrightarrow> edge_rev M a \<noteq> a"
    "\<And>a. a \<in> arcs G \<Longrightarrow> edge_rev M (edge_rev M a) = a"
    "\<And>a. a \<in> arcs G \<Longrightarrow> tail G (edge_rev M a) = head G a"
  assumes edge_succ_permutes: "edge_succ M permutes arcs G"
  assumes edge_succ_cyclic: "\<And>v. v \<in> verts G \<Longrightarrow> out_arcs G v \<noteq> {} \<Longrightarrow> cyclic_on (edge_succ M) (out_arcs G v)"
  shows "digraph_map G M"
  using assms by unfold_locales auto

lemma (in fin_digraph) digraph_mapI_permutes:
  assumes bidi: "edge_rev M permutes arcs G"
    "\<And>a. a \<in> arcs G \<Longrightarrow> edge_rev M a \<noteq> a"
    "\<And>a. a \<in> arcs G \<Longrightarrow> edge_rev M (edge_rev M a) = a"
    "\<And>a. a \<in> arcs G \<Longrightarrow> tail G (edge_rev M a) = head G a"
  assumes edge_succ_permutes: "edge_succ M permutes arcs G"
  assumes edge_succ_cyclic: "\<And>v. v \<in> verts G \<Longrightarrow> out_arcs G v \<noteq> {} \<Longrightarrow> cyclic_on (edge_succ M) (out_arcs G v)"
  shows "digraph_map G M"
proof -
  interpret bidirected_digraph G "edge_rev M" using bidi by unfold_locales (auto simp: permutes_def)
  show ?thesis
    using edge_succ_permutes edge_succ_cyclic by unfold_locales
qed

context digraph_map
begin

  lemma digraph_map[intro]: "digraph_map G M" by unfold_locales

  lemma permutation_edge_succ: "permutation (edge_succ M)"
    by (metis edge_succ_permutes finite_arcs permutation_permutes)

  lemma edge_pred_succ[simp]: "edge_pred M (edge_succ M a) = a"
    by (metis edge_pred_def edge_succ_permutes permutes_inverses(2))

  lemma edge_succ_pred[simp]: "edge_succ M (edge_pred M a) = a"
    by (metis edge_pred_def edge_succ_permutes permutes_inverses(1))

  lemma edge_pred_permutes: "edge_pred M permutes arcs G"
    unfolding edge_pred_def using edge_succ_permutes by (rule permutes_inv)

  lemma permutation_edge_pred: "permutation (edge_pred M)"
    by (metis edge_pred_permutes finite_arcs permutation_permutes)

  lemma edge_succ_eq_iff[simp]: "\<And>x y. edge_succ M x = edge_succ M y \<longleftrightarrow> x = y"
    by (metis edge_pred_succ)

  lemma edge_rev_in_arcs[simp]: "edge_rev M a \<in> arcs G \<longleftrightarrow> a \<in> arcs G"
    by (metis arev_arev arev_permutes_arcs permutes_not_in)

  lemma edge_succ_in_arcs[simp]: "edge_succ M a \<in> arcs G \<longleftrightarrow> a \<in> arcs G"
    by (metis edge_pred_succ edge_succ_permutes permutes_not_in)

  lemma edge_pred_in_arcs[simp]: "edge_pred M a \<in> arcs G \<longleftrightarrow> a \<in> arcs G"
    by (metis edge_succ_pred edge_pred_permutes permutes_not_in)

  lemma tail_edge_pred[simp]: "tail G (edge_pred M a) = tail G a"
  by (metis edge_succ_pred tail_edge_succ)

  lemma bij_edge_succ[intro]: "bij (edge_succ M)"
    using edge_succ_permutes by (simp add: permutes_conv_has_dom)

  lemma edge_pred_cyclic:
    assumes "v \<in> verts G" "out_arcs G v \<noteq> {}"
    shows "cyclic_on (edge_pred M) (out_arcs G v)"
  proof -
    obtain a where orb_a_eq: "orbit (edge_succ M) a = out_arcs G v"
      using edge_succ_cyclic[OF assms] by (auto simp: cyclic_on_def)
    have "cyclic_on (edge_pred M) (orbit (edge_pred M) a)"
      using permutation_edge_pred by (rule cyclic_on_orbit')
    also have "orbit (edge_pred M) a = orbit (edge_succ M) a"
      unfolding edge_pred_def using permutation_edge_succ by (rule orbit_inv_eq)
    finally show "cyclic_on (edge_pred M) (out_arcs G v)" by (simp add: orb_a_eq)
  qed

  definition (in pre_digraph_map) face_cycle_succ :: "'b \<Rightarrow> 'b" where
    "face_cycle_succ \<equiv> edge_succ M o edge_rev M"

  definition (in pre_digraph_map) face_cycle_pred :: "'b \<Rightarrow> 'b" where
    "face_cycle_pred \<equiv> edge_rev M o edge_pred M"

  lemma face_cycle_pred_succ[simp]:
    shows "face_cycle_pred (face_cycle_succ a) = a"
    unfolding face_cycle_pred_def face_cycle_succ_def by simp

  lemma face_cycle_succ_pred[simp]:
    shows "face_cycle_succ (face_cycle_pred a) = a"
    unfolding face_cycle_pred_def face_cycle_succ_def by simp

  lemma tail_face_cycle_succ: "a \<in> arcs G \<Longrightarrow> tail G (face_cycle_succ a) = head G a"
    by (auto simp: face_cycle_succ_def)

  lemma funpow_prop:
    assumes "\<And>x. P (f x) \<longleftrightarrow> P x"
    shows "P ((f ^^ n) x) \<longleftrightarrow> P x"
    using assms by (induct n) auto

  lemma face_cycle_succ_no_arc[simp]: "a \<notin> arcs G \<Longrightarrow> face_cycle_succ a = a"
    by (auto simp: face_cycle_succ_def permutes_not_in[OF arev_permutes_arcs]
      permutes_not_in[OF edge_succ_permutes])

  lemma funpow_face_cycle_succ_no_arc[simp]:
    assumes "a \<notin> arcs G" shows "(face_cycle_succ ^^ n) a = a"
    using assms by (induct n) auto

  lemma funpow_face_cycle_pred_no_arc[simp]:
    assumes "a \<notin> arcs G" shows "(face_cycle_pred ^^ n) a = a"
    using assms
    by (induct n) (auto simp: face_cycle_pred_def permutes_not_in[OF arev_permutes_arcs]
      permutes_not_in[OF edge_pred_permutes])

  lemma face_cycle_succ_closed[simp]:
    "face_cycle_succ a \<in> arcs G \<longleftrightarrow> a \<in> arcs G"
    by (metis comp_apply edge_rev_in_arcs edge_succ_in_arcs face_cycle_succ_def)

  lemma face_cycle_succ_permutes:
    "face_cycle_succ permutes arcs G"
    unfolding face_cycle_succ_def
    using arev_permutes_arcs edge_succ_permutes by (rule permutes_compose)

  lemma permutation_face_cycle_succ: "permutation face_cycle_succ"
    using face_cycle_succ_permutes finite_arcs by (metis permutation_permutes)

  lemma face_cycle_pred_permutes:
    "face_cycle_pred permutes arcs G"
    unfolding face_cycle_pred_def
    using edge_pred_permutes arev_permutes_arcs by (rule permutes_compose)

  definition (in pre_digraph_map) face_cycle_set :: "'b \<Rightarrow> 'b set" where
    "face_cycle_set a = orbit face_cycle_succ a"

  definition (in pre_digraph_map) face_cycle_sets :: "'b set set" where
    "face_cycle_sets = face_cycle_set ` arcs G"

  lemma face_cycle_set_altdef: "face_cycle_set a = {(face_cycle_succ ^^ n) a | n. True}"
    unfolding face_cycle_set_def
    by (intro orbit_altdef_self_in permutation_self_in_orbit permutation_face_cycle_succ)

  lemma face_cycle_set_self[simp, intro]: "a \<in> face_cycle_set a"
    unfolding face_cycle_set_def using permutation_face_cycle_succ by (rule permutation_self_in_orbit)

  lemma empty_not_in_face_cycle_sets: "{} \<notin> face_cycle_sets"
      by (auto simp: face_cycle_sets_def)

  lemma finite_face_cycle_set[simp, intro]: "finite (face_cycle_set a)"
    using face_cycle_set_self unfolding face_cycle_set_def by (simp add: finite_orbit)

  lemma finite_face_cycle_sets[simp, intro]: "finite face_cycle_sets"
    by (auto simp: face_cycle_sets_def)

  lemma face_cycle_set_induct[case_names base step, induct set: face_cycle_set]:
    assumes consume: "a \<in> face_cycle_set x"
      and ih_base: "P x"
      and ih_step: "\<And>y. y \<in> face_cycle_set x \<Longrightarrow> P y \<Longrightarrow> P (face_cycle_succ y)"
    shows "P a"
    using consume unfolding face_cycle_set_def
    by induct (auto simp: ih_step face_cycle_set_def[symmetric] ih_base )

  lemma face_cycle_succ_cyclic:
    "cyclic_on face_cycle_succ (face_cycle_set a)"
    unfolding face_cycle_set_def using permutation_face_cycle_succ by (rule cyclic_on_orbit')

  lemma face_cycle_eq:
    assumes "b \<in> face_cycle_set a" shows "face_cycle_set b = face_cycle_set a"
    using assms unfolding face_cycle_set_def
    by (auto intro: orbit_swap orbit_trans permutation_face_cycle_succ permutation_self_in_orbit)

  lemma face_cycle_succ_in_arcsI: "\<And>a. a \<in> arcs G \<Longrightarrow> face_cycle_succ a \<in> arcs G"
    by (auto simp: face_cycle_succ_def)

  lemma face_cycle_succ_inI: "\<And>x y. x \<in> face_cycle_set y \<Longrightarrow> face_cycle_succ x \<in> face_cycle_set y"
    by (metis face_cycle_succ_cyclic cyclic_on_inI)

  lemma face_cycle_succ_inD: "\<And>x y. face_cycle_succ x \<in> face_cycle_set y \<Longrightarrow> x \<in> face_cycle_set y"
    by (metis face_cycle_eq face_cycle_set_self face_cycle_succ_inI)

  lemma face_cycle_set_parts:
    "face_cycle_set a = face_cycle_set b \<or> face_cycle_set a \<inter> face_cycle_set b = {}"
    by (metis disjoint_iff_not_equal face_cycle_eq)

  definition fc_equiv :: "'b \<Rightarrow> 'b \<Rightarrow> bool" where
    "fc_equiv a b \<equiv> a \<in> face_cycle_set b"

  lemma reflp_fc_equiv: "reflp fc_equiv"
    by (rule reflpI) (simp add: fc_equiv_def)

  lemma transp_fc_equiv: "transp fc_equiv"
    using face_cycle_set_parts
    by (intro transpI) (auto simp: fc_equiv_def)

  lemma "equivp fc_equiv"
    by (intro equivpI reflp_fc_equiv symp_fc_equiv transp_fc_equiv)

  lemma in_face_cycle_setD:
    assumes "y \<in> face_cycle_set x" "x \<in> arcs G" shows "y \<in> arcs G"
    using assms
    by (auto simp: face_cycle_set_def dest: permutes_orbit_subset[OF face_cycle_succ_permutes])

  lemma in_face_cycle_setsD:
    assumes "x \<in> face_cycle_sets" shows "x \<subseteq> arcs G"
    using assms by (auto simp: face_cycle_sets_def dest: in_face_cycle_setD)

end

definition (in pre_digraph) isolated_verts :: "'a set" where
  "isolated_verts \<equiv> {v \<in> verts G. out_arcs G v = {}}"

definition (in pre_digraph_map) euler_char :: int where
  "euler_char \<equiv> int (card (verts G)) - int (card (arcs G) div 2) + int (card face_cycle_sets)"

definition (in pre_digraph_map) euler_genus :: int where
  "euler_genus \<equiv> (int (2 * card sccs) - int (card isolated_verts) - euler_char) div 2"

definition comb_planar :: "('a,'b) pre_digraph \<Rightarrow> bool" where
  "comb_planar G \<equiv> \<exists>M. digraph_map G M \<and> pre_digraph_map.euler_genus G M = 0"

text \<open>Number of isolated vertices is a graph invariant\<close>
context
  fixes G hom assumes hom: "pre_digraph.digraph_isomorphism G hom"
begin

  interpretation wf_digraph G using hom by (auto simp: pre_digraph.digraph_isomorphism_def)

  lemma isolated_verts_app_iso[simp]:
    "pre_digraph.isolated_verts (app_iso hom G) = iso_verts hom ` isolated_verts"
    using hom
    by (auto simp: pre_digraph.isolated_verts_def iso_verts_tail inj_image_mem_iff out_arcs_app_iso_eq)

  lemma card_isolated_verts_iso[simp]:
    "card (iso_verts hom ` pre_digraph.isolated_verts G) = card isolated_verts"
    apply (rule card_image)
    using hom apply (rule digraph_isomorphism_inj_on_verts[THEN subset_inj_on])
    apply (auto simp: isolated_verts_def)
    done

end

context digraph_map begin

  lemma face_cycle_succ_neq:
    assumes "a \<in> arcs G" "tail G a \<noteq> head G a" shows "face_cycle_succ a \<noteq> a "
  proof -
    from assms have "edge_rev M a \<in> arcs G"
      by (subst edge_rev_in_arcs) simp
    then have "cyclic_on (edge_succ M) (out_arcs G (tail G (edge_rev M a)))"
      by (intro edge_succ_cyclic) (auto dest: tail_in_verts simp: out_arcs_def intro: exI[where x="edge_rev M a"])
    then have "edge_succ M (edge_rev M a) \<in> (out_arcs G (tail G (edge_rev M a)))"
      by (rule cyclic_on_inI) (auto simp: \<open>edge_rev M a \<in> _\<close>[simplified])
    moreover have "tail G (edge_succ M (edge_rev M a)) = head G a"
      using assms by auto
    then have "edge_succ M (edge_rev M a) \<noteq> a" using assms by metis
    ultimately show ?thesis
      using assms by (auto simp: face_cycle_succ_def)
  qed

end

section \<open>Maps and Isomorphism\<close>

definition (in pre_digraph)
  "wrap_iso_arcs hom f = perm_restrict (iso_arcs hom o f o iso_arcs (inv_iso hom)) (arcs (app_iso hom G))"

definition (in pre_digraph_map) map_iso :: "('a,'b,'a2,'b2) digraph_isomorphism \<Rightarrow> 'b2 pre_map" where
  "map_iso f \<equiv>
  \<lparr> edge_rev = wrap_iso_arcs f (edge_rev M)
  , edge_succ = wrap_iso_arcs f (edge_succ M)
  \<rparr>"

lemma funcsetI_permutes:
  assumes "f permutes S" shows "f \<in> S \<rightarrow> S"
  by (metis assms funcsetI permutes_in_image)

context
  fixes G hom assumes hom: "pre_digraph.digraph_isomorphism G hom"
begin

  interpretation wf_digraph G using hom by (auto simp: pre_digraph.digraph_isomorphism_def)

  lemma wrap_iso_arcs_iso_arcs[simp]:
    assumes "x \<in> arcs G"
    shows "wrap_iso_arcs hom f (iso_arcs hom x) = iso_arcs hom (f x)"
    using assms hom by (auto simp: wrap_iso_arcs_def perm_restrict_def)

  lemma inj_on_wrap_iso_arcs:
    assumes dom: "\<And>f. f \<in> F \<Longrightarrow> has_dom f (arcs G)"
    assumes funcset: "F \<subseteq> arcs G \<rightarrow> arcs G"
    shows "inj_on (wrap_iso_arcs hom) F"
  proof (rule inj_onI)
    fix f g assume F: "f \<in> F" "g \<in> F" and eq: "wrap_iso_arcs hom f = wrap_iso_arcs hom g"
    { fix x assume "x \<notin> arcs G"
      then have "f x = x" "g x = x" using F dom by (auto simp: has_dom_def)
      then have "f x = g x" by simp
    }
    moreover
    { fix x assume "x \<in> arcs G"
      then have "f x \<in> arcs G" "g x \<in> arcs G" using F funcset by auto
      with digraph_isomorphism_inj_on_arcs[OF hom] _
      have "iso_arcs hom (f x) = iso_arcs hom (g x) \<Longrightarrow> f x = g x"
        by (rule inj_onD)
      then have "f x = g x"
        using assms hom  \<open>x \<in> arcs G\<close> eq
        by (auto simp: wrap_iso_arcs_def fun_eq_iff perm_restrict_def split: if_splits)
    }
    ultimately show "f = g" by auto
  qed

  lemma inj_on_wrap_iso_arcs_f:
    assumes "A \<subseteq> arcs G" "f \<in> A \<rightarrow> A" "B = iso_arcs hom ` A"
    assumes "inj_on f A" shows "inj_on (wrap_iso_arcs hom f) B"
  proof (rule inj_onI)
    fix x y
    assume in_hom_A: "x \<in> B" "y \<in> B"
      and wia_eq: "wrap_iso_arcs hom f x = wrap_iso_arcs hom f y"
    from in_hom_A \<open>B = _\<close> obtain x0 where x0: "x = iso_arcs hom x0" "x0 \<in> A" by auto
    from in_hom_A \<open>B = _\<close> obtain y0 where y0: "y = iso_arcs hom y0" "y0 \<in> A" by auto
    have arcs_0: "x0 \<in> arcs G" "y0 \<in> arcs G" "f x0 \<in> arcs G" "f y0 \<in> arcs G"
      using x0 y0 \<open>A \<subseteq> _\<close> \<open>f \<in> _\<close> by auto

    have "(iso_arcs hom o f o iso_arcs (inv_iso hom)) x = (iso_arcs hom o f o iso_arcs (inv_iso hom)) y"
      using in_hom_A wia_eq assms(1) \<open>B = _\<close> by (auto simp: wrap_iso_arcs_def perm_restrict_def split: if_splits)
    then show "x = y"
      using hom assms digraph_isomorphism_inj_on_arcs[OF hom] x0 y0 arcs_0 \<open>inj_on f A\<close> \<open>A \<subseteq> _\<close>
      by (auto dest!:  inj_onD)
  qed

  lemma wrap_iso_arcs_in_funcsetI:
    assumes "A \<subseteq> arcs G" "f \<in> A \<rightarrow> A"
    shows "wrap_iso_arcs hom f \<in> iso_arcs hom ` A  \<rightarrow> iso_arcs hom ` A"
  proof
    fix x assume "x \<in> iso_arcs hom ` A"
    then obtain x0 where "x = iso_arcs hom x0" "x0 \<in> A" by blast
    then have "f x0 \<in> A" using \<open>f \<in> _\<close> by auto
    then show "wrap_iso_arcs hom f x \<in> iso_arcs hom ` A"
      unfolding \<open>x = _\<close> using \<open>x0 \<in> A\<close> assms hom by (auto simp: wrap_iso_arcs_def perm_restrict_def)
  qed

  lemma wrap_iso_arcs_permutes:
    assumes "A \<subseteq> arcs G" "f permutes A"
    shows "wrap_iso_arcs hom f permutes (iso_arcs hom ` A)"
  proof -
    { fix x assume A: "x \<notin> iso_arcs hom ` A"
      have "wrap_iso_arcs hom f x = x"
      proof cases
        assume "x \<in> iso_arcs hom ` arcs G"
        then have "iso_arcs (inv_iso hom) x \<notin> A" "x \<in> arcs (app_iso hom G)"
          using A hom by (metis arcs_app_iso image_eqI pre_digraph.iso_arcs_iso_inv, simp)
        then have "f (iso_arcs (inv_iso hom) x) = (iso_arcs (inv_iso hom) x)"
          using \<open>f permutes A\<close> by (simp add: permutes_not_in)
        then show ?thesis using hom assms \<open>x \<in> arcs _\<close>
          by (simp add: wrap_iso_arcs_def perm_restrict_def)
      next
        assume "x \<notin> iso_arcs hom ` arcs G"
        then show ?thesis
          by (simp add: wrap_iso_arcs_def perm_restrict_def)
      qed
    } note not_in_id = this

    have "f \<in> A \<rightarrow> A" using assms by (intro funcsetI_permutes)
    have inj_on_wrap: "inj_on (wrap_iso_arcs hom f) (iso_arcs hom ` A)"
      using assms \<open>f \<in> A \<rightarrow> A\<close> by (intro inj_on_wrap_iso_arcs_f) (auto intro: subset_inj_on permutes_inj)
    have woa_in_fs: "wrap_iso_arcs hom f \<in> iso_arcs hom ` A \<rightarrow> iso_arcs hom ` A"
      using assms \<open>f \<in> A \<rightarrow> A\<close> by (intro wrap_iso_arcs_in_funcsetI)

    { fix x y assume "wrap_iso_arcs hom f x = wrap_iso_arcs hom f y"
      then have "x = y"
        apply (cases "x \<in> iso_arcs hom ` A"; cases "y \<in> iso_arcs hom ` A")
        using woa_in_fs inj_on_wrap by (auto dest: inj_onD simp: not_in_id)
    } note uniqueD = this

    note \<open>f permutes A\<close>
    moreover
    note not_in_id
    moreover
    { fix y have "\<exists>x. wrap_iso_arcs hom f x = y"
      proof cases
        assume "y \<in> iso_arcs hom ` A"
        then obtain y0 where "y0 \<in> A" "iso_arcs hom y0 = y" by blast
        with \<open>f permutes A\<close> obtain x0 where "x0 \<in> A" "f x0 = y0" unfolding permutes_def by metis
        moreover
        then have "\<And>x. x \<in> arcs G \<Longrightarrow> iso_arcs hom x0 = iso_arcs hom x \<Longrightarrow> x0 = x"
          using assms hom by (auto simp: digraph_isomorphism_def dest: inj_onD)
        ultimately
        have "wrap_iso_arcs hom f (iso_arcs hom x0) = y"
          using \<open>_ = y\<close> assms hom by (auto simp: wrap_iso_arcs_def perm_restrict_def)
        then show ?thesis ..
      qed (metis not_in_id)
    }
    ultimately
    show ?thesis unfolding permutes_def by (auto simp: dest: uniqueD)
  qed

end

lemma (in digraph_map) digraph_map_isoI:
  assumes "digraph_isomorphism hom" shows "digraph_map (app_iso hom G) (map_iso hom)"
proof -
  interpret iG: fin_digraph "app_iso hom G" using assms by (rule fin_digraphI_app_iso)
  show ?thesis
  proof (rule iG.digraph_mapI_permutes)
    show "edge_rev (map_iso hom) permutes arcs (app_iso hom G)"
      using assms unfolding map_iso_def by (simp add: wrap_iso_arcs_permutes arev_permutes_arcs)
  next
    show "edge_succ (map_iso hom) permutes arcs (app_iso hom G)"
      using assms unfolding map_iso_def by (simp add: wrap_iso_arcs_permutes edge_succ_permutes)
  next
    fix a assume A: "a \<in> arcs (app_iso hom G)"
    show "tail (app_iso hom G) (edge_rev (map_iso hom) a) = head (app_iso hom G) a"
      using A assms
      by (cases rule: in_arcs_app_iso_cases) (auto simp: map_iso_def iso_verts_tail iso_verts_head)
    show "edge_rev (map_iso hom) (edge_rev (map_iso hom) a) = a"
      using A assms by (cases rule: in_arcs_app_iso_cases) (auto simp: map_iso_def)
    show "edge_rev (map_iso hom) a \<noteq> a"
      using A assms by (auto simp: map_iso_def arev_neq)
  next
    fix v assume "v \<in> verts (app_iso hom G)" and oa_hom: "out_arcs (app_iso hom G) v \<noteq> {}"
    then obtain v0 where "v0 \<in> verts G" "v = iso_verts hom v0" by auto
    moreover
    then have oa: "out_arcs G v0 \<noteq> {}"
      using assms oa_hom by (auto simp: out_arcs_def iso_verts_tail)
    ultimately
    have cyclic_on_v0: "cyclic_on (edge_succ M) (out_arcs G v0)"
      by (intro edge_succ_cyclic)

    from oa_hom obtain a where "a \<in> out_arcs (app_iso hom G) v" by blast
    then obtain a0 where "a0 \<in> arcs G" "a = iso_arcs hom a0" by auto
    then have "a0 \<in> out_arcs G v0"
      using \<open>v = _\<close> \<open>v0 \<in> _\<close> \<open>a \<in> _\<close> assms by (simp add: iso_verts_tail)

    show "cyclic_on (edge_succ (map_iso hom)) (out_arcs (app_iso hom G) v)"
    proof (rule cyclic_on_singleI)
      show "a \<in> out_arcs (app_iso hom G) v" by fact
    next
      have "out_arcs (app_iso hom G) v = iso_arcs hom ` out_arcs G v0"
        unfolding \<open>v = _\<close> by (rule out_arcs_app_iso_eq) fact+
      also have "out_arcs G v0 = orbit (edge_succ M) a0"
        using cyclic_on_v0 \<open>a0 \<in> out_arcs G v0\<close> unfolding cyclic_on_alldef by simp
      also have "iso_arcs hom ` \<dots> = orbit (edge_succ (map_iso hom)) a"
      proof -
        have "\<And>x. x \<in> orbit (edge_succ M) a0 \<Longrightarrow> x \<in> arcs G"
          using \<open>out_arcs G v0 = _\<close> by auto
        then show ?thesis using \<open>out_arcs G v0 = _\<close>
          unfolding \<open>a = _\<close> using \<open>a0 \<in> out_arcs G v0\<close> assms
          by (intro orbit_inverse) (auto simp: map_iso_def)
      qed
      finally show "out_arcs (app_iso hom G) v = orbit (edge_succ (map_iso hom)) a" .
    qed
  qed
qed

end


section \<open>Address Graph\<close>

theory Graph
imports Main
begin

text \<open>
This theory introduces the graph to be marked as a relation next on
nodes (addresses). We assume that we have a special node nil (the
null address). We have a node root from which we start marking the graph.
We also assume that nil is not related by next to any node and any node is
not related by next to nil.
\<close>

locale node =
  fixes nil    :: "'node"
  fixes root   :: "'node"

locale graph = node +
  fixes "next" :: "('node \<times> 'node) set"
  assumes next_not_nil_left: "(!! x . (nil, x) \<notin> next)"
  assumes next_not_nil_right: "(!! x . (x, nil) \<notin> next)"
begin

text \<open>
On lists of nodes we introduce two operations similar to
existing hd and tl for getting the head and the tail of
a list. The new function head applied to a nonempty list
returns the head of the list, and it reurns nil when
applied to the empty list. The function tail returns the
tail of the list when applied to a non-empty list, and
it returns the empty list otherwise.
\<close>
  definition
    "head S \<equiv> (if S = [] then nil else (hd S))"

  definition
    "tail (S::'a list) \<equiv> (if S = [] then [] else (tl S))"

  theorem head_not_nil [simp]:
    "(head S \<noteq> nil) = (head S = hd S \<and> tail S = tl S \<and> hd S \<noteq> nil \<and> S \<noteq> [])"
    by (simp add: head_def tail_def)

  theorem nonempty_head [simp]:
    "head (x # S) = x"
    by (simp add: head_def)

  theorem nonempty_tail [simp]:
    "tail (x # S) = S"
    by (simp add: tail_def)

  definition (in graph)
    "reach x \<equiv> {y . (x, y) \<in> next\<^sup>* \<and> y \<noteq> nil}"

  theorem (in graph) reach_nil [simp]: "reach nil = {}"
    apply (simp add: reach_def, safe)
    apply (drule rtrancl_induct)
    by auto

  theorem (in graph)  reach_next: "b \<in> reach a \<Longrightarrow> (b, c) \<in> next \<Longrightarrow> c \<in> reach a"
    apply (simp add: reach_def)
    by auto

  definition (in graph)
    "path S mrk \<equiv> {x . (\<exists> s . s \<in> S \<and> (s, x) \<in> next O (next \<inter> ((-mrk)\<times>(-mrk)))\<^sup>* )}"
  end

end


(*  Title:      HOL/Hahn_Banach/Linearform.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Linearforms\<close>

theory Linearform
imports Vector_Space
begin

text \<open>
  A \emph{linear form} is a function on a vector space into the reals
  that is additive and multiplicative.
\<close>

locale linearform =
  fixes V :: "'a\<Colon>{minus, plus, zero, uminus} set" and f
  assumes add [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> f (x + y) = f x + f y"
    and mult [iff]: "x \<in> V \<Longrightarrow> f (a \<cdot> x) = a * f x"

declare linearform.intro [intro?]

lemma (in linearform) neg [iff]:
  assumes "vectorspace V"
  shows "x \<in> V \<Longrightarrow> f (- x) = - f x"
proof -
  interpret vectorspace V by fact
  assume x: "x \<in> V"
  then have "f (- x) = f ((- 1) \<cdot> x)" by (simp add: negate_eq1)
  also from x have "\<dots> = (- 1) * (f x)" by (rule mult)
  also from x have "\<dots> = - (f x)" by simp
  finally show ?thesis .
qed

lemma (in linearform) diff [iff]:
  assumes "vectorspace V"
  shows "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> f (x - y) = f x - f y"
proof -
  interpret vectorspace V by fact
  assume x: "x \<in> V" and y: "y \<in> V"
  then have "x - y = x + - y" by (rule diff_eq1)
  also have "f \<dots> = f x + f (- y)" by (rule add) (simp_all add: x y)
  also have "f (- y) = - f y" using \<open>vectorspace V\<close> y by (rule neg)
  finally show ?thesis by simp
qed

text \<open>Every linear form yields @{text 0} for the @{text 0} vector.\<close>

lemma (in linearform) zero [iff]:
  assumes "vectorspace V"
  shows "f 0 = 0"
proof -
  interpret vectorspace V by fact
  have "f 0 = f (0 - 0)" by simp
  also have "\<dots> = f 0 - f 0" using \<open>vectorspace V\<close> by (rule diff) simp_all
  also have "\<dots> = 0" by simp
  finally show ?thesis .
qed

end


\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
section \<open>Final Hoare Triples for heapsort and introsort\<close>
theory Sorting_Results
imports Sorting_Introsort
begin

paragraph \<open>Summary\<close>
text \<open>This theory collects the final Hoare Triples for heapsort and introsort.
  They do not involve the NREST monad any more. For inspecting their validity, only the
  LLVM semantics and the definitions of Hoare triples must be checked.
  By summing over all currencies, we project the fine-grained cost functions used in the
  Hoare Triples down to functions in @{typ "nat \<Rightarrow> nat"} and examine their asymptotic complexity.\<close>

subsection \<open>Heapsort\<close>

context sort_impl_context begin

lemma "slice_sort_aux xs\<^sub>0 xs l h \<equiv> (length xs = length xs\<^sub>0 \<and> take l xs = take l xs\<^sub>0
                    \<and> drop h xs = drop h xs\<^sub>0 \<and> sort_spec (\<^bold><) (slice l h xs\<^sub>0) (slice l h xs))"
  by simp

text \<open>Final correctness lemma:\<close>
lemma
  assumes "l \<le> h \<and> h \<le> length xs\<^sub>0"
  shows "llvm_htriple ($heapsort_impl_cost l h \<and>* arr_assn xs\<^sub>0 p
           \<and>* pure snat_rel l l' \<and>* pure snat_rel h h')
        (heapsort_impl p l' h')
      (\<lambda>r. (\<lambda>s. \<exists>xs. (\<up>(slice_sort_aux xs\<^sub>0 xs l h) \<and>* arr_assn xs r) s)
           \<and>* invalid_assn arr_assn xs\<^sub>0 p \<and>* pure snat_rel l l' \<and>* pure snat_rel h h')"
  using assms
  apply(rule heapsort_final_hoare_triple[unfolded hn_ctxt_def])
  done

text \<open>@{term heapsort_impl_cost} projected to a function @{typ "nat \<Rightarrow> nat"} \<close>
lemma "heapsort3_allcost (h-l) = project_all (heapsort_impl_cost l h)"
  by (simp add: heapsort3_allcost_is_heapsort3_allcost' heapsort3_allcost'_Sum_any)

end

lemma "heapsort3_allcost n = 12 + 187 * n  + 82 * (n * Discrete.log n)"
  unfolding heapsort3_allcost_def by simp

lemma "(\<lambda>x. real (heapsort3_allcost x)) \<in> \<Theta>(\<lambda>n. (real n)*(ln (real n)))"
  by (fact heapsort3_allcost_nlogn)

subsection \<open>Introsort\<close>

context sort_impl_context begin

lemma "slice_sort_aux xs\<^sub>0 xs l h \<equiv> (length xs = length xs\<^sub>0 \<and> take l xs = take l xs\<^sub>0
                    \<and> drop h xs = drop h xs\<^sub>0 \<and> sort_spec (\<^bold><) (slice l h xs\<^sub>0) (slice l h xs))"
  by simp

text \<open>Final correctness lemma:\<close>
lemma
  assumes "l \<le> h \<and> h \<le> length xs\<^sub>0"
  shows "llvm_htriple ($introsort_impl_cost (h-l) \<and>* arr_assn xs\<^sub>0 p
           \<and>* pure snat_rel l l' \<and>* pure snat_rel h h')
        (introsort_impl p l' h')
      (\<lambda>r. (\<lambda>s. \<exists>xs. (\<up>(slice_sort_aux xs\<^sub>0 xs l h) \<and>* arr_assn xs r) s)
           \<and>* invalid_assn arr_assn xs\<^sub>0 p \<and>* pure snat_rel l l' \<and>* pure snat_rel h h')"
  by (rule introsort_final_hoare_triple[OF assms, unfolded hn_ctxt_def])

text \<open>introsort_impl_cost projected to a function @{typ "nat \<Rightarrow> nat"} \<close>
lemma "introsort3_allcost n = project_all (introsort_impl_cost n)"
  by (rule introsort3_allcost_is_projected_introsort_impl_cost)

end

lemma "introsort3_allcost n = 4693 + 5 *  Discrete.log n + 231 * n + 455 * (n * Discrete.log n)"
  by(fact introsort3_allcost_simplified)

lemma "(\<lambda>x. real (introsort3_allcost x)) \<in> \<Theta>(\<lambda>n. (real n)*(ln (real n)))"
  by (fact introsort3_allcost_nlogn)

end


section \<open>Underlying FSM Representation\<close>

text \<open>This theory contains the underlying datatype for (possibly not well-formed) finite state machines.\<close>

theory FSM_Impl
  imports Util Datatype_Order_Generator.Order_Generator "HOL-Library.FSet"
begin

text \<open>A finite state machine (FSM) is represented using its classical definition:\<close>

datatype ('state, 'input, 'output) fsm_impl = FSMI (initial : 'state)
                                                  (states  : "'state set")
                                                  (inputs  : "'input set")
                                                  (outputs : "'output set")
                                                  (transitions : "('state \<times> 'input \<times> 'output \<times> 'state) set")

subsection \<open>Types for Transitions and Paths\<close>

type_synonym ('a,'b,'c) transition = "('a \<times> 'b \<times> 'c \<times> 'a)"
type_synonym ('a,'b,'c) path = "('a,'b,'c) transition list"

abbreviation "t_source (a :: ('a,'b,'c) transition) \<equiv> fst a"
abbreviation "t_input  (a :: ('a,'b,'c) transition) \<equiv> fst (snd a)"
abbreviation "t_output (a :: ('a,'b,'c) transition) \<equiv> fst (snd (snd a))"
abbreviation "t_target (a :: ('a,'b,'c) transition) \<equiv> snd (snd (snd a))"

subsection \<open>Basic Algorithms on FSM\<close>

subsubsection \<open>Reading FSMs from Lists\<close>

fun fsm_impl_from_list :: "'a \<Rightarrow>
                           ('a,'b,'c) transition list \<Rightarrow>
                           ('a, 'b, 'c) fsm_impl"
  where
  "fsm_impl_from_list q [] = FSMI q {q} {} {} {}" |
  "fsm_impl_from_list q (t#ts) =
    (let ts' = set (t#ts)
     in FSMI (t_source t)
             ((image t_source ts') \<union> (image t_target ts'))
             (image t_input ts')
             (image t_output ts')
             (ts'))"

fun fsm_impl_from_list' :: "'a \<Rightarrow> ('a,'b,'c) transition list \<Rightarrow> ('a, 'b, 'c) fsm_impl" where
  "fsm_impl_from_list' q [] = FSMI q {q} {} {} {}" |
  "fsm_impl_from_list' q (t#ts) = (let tsr = (remdups (t#ts))
                                   in FSMI (t_source t)
                                      (set (remdups ((map t_source tsr) @ (map t_target tsr))))
                                      (set (remdups (map t_input tsr)))
                                      (set (remdups (map t_output tsr)))
                                      (set tsr))"

lemma fsm_impl_from_list_code[code] :
  "fsm_impl_from_list q ts = fsm_impl_from_list' q ts"
  by (cases ts; auto)

subsubsection \<open>Changing the initial State\<close>

fun from_FSMI :: "('a,'b,'c) fsm_impl \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "from_FSMI M q = (if q \<in> states M then FSMI q (states M) (inputs M) (outputs M) (transitions M) else M)"

subsubsection \<open>Product Construction\<close>

fun product :: "('a,'b,'c) fsm_impl \<Rightarrow> ('d,'b,'c) fsm_impl \<Rightarrow> ('a \<times> 'd,'b,'c) fsm_impl" where
  "product A B = FSMI ((initial A, initial B))
                     ((states A) \<times> (states B))
                     (inputs A \<union> inputs B)
                     (outputs A \<union> outputs B)
                     {((qA,qB),x,y,(qA',qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B}"

lemma product_code_naive[code] :
  "product A B = FSMI ((initial A, initial B))
                     ((states A) \<times> (states B))
                     (inputs A \<union> inputs B)
                     (outputs A \<union> outputs B)
                     (image (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . ((qA,qB),x,y,(qA',qB'))) (Set.filter (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . x = x' \<and> y = y') (\<Union>(image (\<lambda> tA . image (\<lambda> tB . (tA,tB)) (transitions B)) (transitions A)))))"
  (is "?P1 = ?P2")
proof -
  have "(\<Union>(image (\<lambda> tA . image (\<lambda> tB . (tA,tB)) (transitions B)) (transitions A))) = {(tA,tB) | tA tB . tA \<in> transitions A \<and> tB \<in> transitions B}"
    by auto
  then have "(Set.filter (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . x = x' \<and> y = y') (\<Union>(image (\<lambda> tA . image (\<lambda> tB . (tA,tB)) (transitions B)) (transitions A)))) = {((qA,x,y,qA'),(qB,x,y,qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B}"
    by auto
  then have "image (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . ((qA,qB),x,y,(qA',qB'))) (Set.filter (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . x = x' \<and> y = y') (\<Union>(image (\<lambda> tA . image (\<lambda> tB . (tA,tB)) (transitions B)) (transitions A))))
              = image (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . ((qA,qB),x,y,(qA',qB'))) {((qA,x,y,qA'),(qB,x,y,qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B}"
    by auto
  moreover have "image (\<lambda>((qA,x,y,qA'), (qB,x',y',qB')) . ((qA,qB),x,y,(qA',qB'))) {((qA,x,y,qA'),(qB,x,y,qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B} =  {((qA,qB),x,y,(qA',qB')) | qA qB x y qA' qB' . (qA,x,y,qA') \<in> transitions A \<and> (qB,x,y,qB') \<in> transitions B}"
    by force
  ultimately have "transitions ?P1 = transitions ?P2"
    unfolding product.simps by auto
  moreover have "initial ?P1 = initial ?P2" by auto
  moreover have "states ?P1 = states ?P2" by auto
  moreover have "inputs ?P1 = inputs ?P2" by auto
  moreover have "outputs ?P1 = outputs ?P2" by auto
  ultimately show ?thesis by auto
qed

subsubsection \<open>Filtering Transitions\<close>

fun filter_transitions :: "('a,'b,'c) fsm_impl \<Rightarrow> (('a,'b,'c) transition \<Rightarrow> bool) \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "filter_transitions M P = FSMI (initial M)
                                (states M)
                                (inputs M)
                                (outputs M)
                                (Set.filter P (transitions M))"

subsubsection \<open>Filtering States\<close>

fun filter_states :: "('a,'b,'c) fsm_impl \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "filter_states M P = (if P (initial M) then FSMI (initial M)
                                                  (Set.filter P (states M))
                                                  (inputs M)
                                                  (outputs M)
                                                  (Set.filter (\<lambda> t . P (t_source t) \<and> P (t_target t)) (transitions M))
                                         else M)"

subsubsection \<open>Initial Singleton FSMI (For Trivial Preamble)\<close>

fun initial_singleton :: "('a,'b,'c) fsm_impl \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "initial_singleton M = FSMI (initial M)
                             {initial M}
                             (inputs M)
                             (outputs M)
                             {}"

subsubsection \<open>Canonical Separator\<close>

abbreviation "shift_Inl t \<equiv> (Inl (t_source t),t_input t, t_output t, Inl (t_target t))"

definition shifted_transitions :: "(('a \<times> 'a) \<times> 'b \<times> 'c \<times> ('a \<times> 'a)) set \<Rightarrow> ((('a \<times> 'a) + 'd) \<times> 'b \<times> 'c \<times> (('a \<times> 'a) + 'd)) set" where
  "shifted_transitions ts = image shift_Inl ts"

definition distinguishing_transitions :: "(('a \<times> 'b) \<Rightarrow> 'c set) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'b set \<Rightarrow> ((('a \<times> 'a) + 'a) \<times> 'b \<times> 'c \<times> (('a \<times> 'a) + 'a)) set" where
  "distinguishing_transitions f q1 q2 stateSet inputSet = \<Union> (Set.image (\<lambda>((q1',q2'),x) .
                                                                (image (\<lambda>y . (Inl (q1',q2'),x,y,Inr q1)) (f (q1',x) - f (q2',x)))
                                                                \<union> (image (\<lambda>y . (Inl (q1',q2'),x,y,Inr q2)) (f (q2',x) - f (q1',x))))
                                                            (stateSet \<times> inputSet))"

(* Note: parameter P is added to allow usage of different restricted versions of the product machine *)
fun canonical_separator' :: "('a,'b,'c) fsm_impl \<Rightarrow> (('a \<times> 'a),'b,'c) fsm_impl \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> (('a \<times> 'a) + 'a,'b,'c) fsm_impl" where
  "canonical_separator' M P q1 q2 = (if initial P = (q1,q2)
  then
    (let f'  = set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (transitions M));
         f   = (\<lambda>qx . (case f' qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}));
         shifted_transitions' = shifted_transitions (transitions P);
         distinguishing_transitions_lr = distinguishing_transitions f q1 q2 (states P) (inputs P);
         ts = shifted_transitions' \<union> distinguishing_transitions_lr
     in

      FSMI (Inl (q1,q2))
      ((image Inl (states P)) \<union> {Inr q1, Inr q2})
      (inputs M \<union> inputs P)
      (outputs M \<union> outputs P)
      (ts))
  else FSMI (Inl (q1,q2)) {Inl (q1,q2)} {} {} {})"

lemma h_out_impl_helper: "(\<lambda> (q,x) . {y . \<exists> q' . (q,x,y,q') \<in> A}) = (\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) A)) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}))"
proof
  fix qx
  show "(\<lambda> (q,x) . {y . \<exists> q' . (q,x,y,q') \<in> A}) qx = (\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) A)) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {})) qx"
  proof -
    obtain q x where "qx = (q,x)" using prod.exhaust by metis
    have **: "\<And> z .  ((q, x), z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` A = (z \<in> {y . \<exists> q' . (q,x,y,q') \<in> A})"
      by force
    show ?thesis unfolding \<open>qx = (q,x)\<close> case_prod_conv set_as_map_def
      unfolding ** by auto
  qed
qed

lemma canonical_separator'_simps :
        "initial (canonical_separator' M P q1 q2) = Inl (q1,q2)"
        "states (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then (image Inl (states P)) \<union> {Inr q1, Inr q2} else {Inl (q1,q2)})"
        "inputs (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then inputs M \<union> inputs P else {})"
        "outputs (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then outputs M \<union> outputs P else {})"
        "transitions (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then shifted_transitions (transitions P) \<union> distinguishing_transitions (\<lambda> (q,x) . {y . \<exists> q' . (q,x,y,q') \<in> transitions M}) q1 q2 (states P) (inputs P) else {})"
  unfolding h_out_impl_helper by (simp add: Let_def)+

subsubsection \<open>Generalised Canonical Separator\<close>

text \<open>A variation on the state separator that uses states @{text "L"} and @{text "R"} instead of
      @{text "Inr q1"} and @{text "Inr q2"} to indicate targets of transitions in the
      canonical separator that are available only for the left or right component of a state pair\<close>

text \<open>Note: this definition of a canonical separator might serve as a way to avoid recalculation
            of state separators for different pairs of states, but is currently not fully
            implemented\<close>

datatype LR = Left | Right
derive linorder LR

definition distinguishing_transitions_LR :: "(('a \<times> 'b) \<Rightarrow> 'c set) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'b set \<Rightarrow> ((('a \<times> 'a) + LR) \<times> 'b \<times> 'c \<times> (('a \<times> 'a) + LR)) set" where
  "distinguishing_transitions_LR f stateSet inputSet = \<Union> (Set.image (\<lambda>((q1',q2'),x) .
                                                                (image (\<lambda>y . (Inl (q1',q2'),x,y,Inr Left)) (f (q1',x) - f (q2',x)))
                                                                \<union> (image (\<lambda>y . (Inl (q1',q2'),x,y,Inr Right)) (f (q2',x) - f (q1',x))))
                                                            (stateSet \<times> inputSet))"

fun canonical_separator_complete' :: "('a,'b,'c) fsm_impl \<Rightarrow> (('a \<times> 'a) + LR,'b,'c) fsm_impl" where
  "canonical_separator_complete' M =
    (let P = product M M;
         f'  = set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (transitions M));
         f   = (\<lambda>qx . (case f' qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}));
         shifted_transitions' = shifted_transitions (transitions P);
         distinguishing_transitions_lr = distinguishing_transitions_LR f (states P) (inputs P);
         ts = shifted_transitions' \<union> distinguishing_transitions_lr
     in
      FSMI (Inl (initial P))
          ((image Inl (states P)) \<union> {Inr Left, Inr Right})
          (inputs M \<union> inputs P)
          (outputs M \<union> outputs P)
          ts )"

subsubsection \<open>Adding Transitions\<close>

fun add_transitions :: "('a,'b,'c) fsm_impl \<Rightarrow> ('a,'b,'c) transition set \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "add_transitions M ts = (if (\<forall> t \<in> ts . t_source t \<in> states M \<and> t_input t \<in> inputs M \<and> t_output t \<in> outputs M \<and> t_target t \<in> states M)
    then FSMI (initial M)
             (states M)
             (inputs M)
             (outputs M)
             ((transitions M) \<union> ts)
    else M)"

subsubsection \<open>Creating an FSMI without transitions\<close>

fun create_unconnected_FSMI :: "'a \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'c set \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "create_unconnected_FSMI q ns ins outs = (if (finite ns \<and> finite ins \<and> finite outs)
    then FSMI q (insert q ns) ins outs {}
    else FSMI q {q} {} {} {})"

fun create_unconnected_fsm_from_lists :: "'a \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "create_unconnected_fsm_from_lists q ns ins outs = FSMI q (insert q (set ns)) (set ins) (set outs) {}"

fun create_unconnected_fsm_from_fsets :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'b fset \<Rightarrow> 'c fset \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "create_unconnected_fsm_from_fsets q ns ins outs = FSMI q (insert q (fset ns)) (fset ins) (fset outs) {}"

fun create_fsm_from_sets :: "'a \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'c set \<Rightarrow> ('a,'b,'c) transition set \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "create_fsm_from_sets q qs ins outs ts = (if q \<in> qs \<and> finite qs \<and> finite ins \<and> finite outs
    then add_transitions (FSMI q qs ins outs {}) ts
    else FSMI q {q} {} {} {})"

subsection \<open>Transition Function h\<close>

text \<open>Function @{text "h"} represents the classical view of the transition relation of an FSM @{text "M"} as a
      function: given a state @{text "q"} and an input @{text "x"}, @{text "(h M) (q,x)"} returns all
      possibly reactions @{text "(y,q')"} of @{text "M"} in state @{text "q"} to @{text "x"}, where
      @{text "y"} is the produced output and @{text "q'"} the target state of the reaction transition.\<close>

fun h :: "('state, 'input, 'output) fsm_impl \<Rightarrow> ('state \<times> 'input) \<Rightarrow> ('output \<times> 'state) set" where
  "h M (q,x) = { (y,q') . (q,x,y,q') \<in> transitions M }"

fun h_obs :: "('a,'b,'c) fsm_impl \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'a option" where
  "h_obs M q x y = (let
      tgts = snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))
    in if card tgts = 1
      then Some (the_elem tgts)
      else None)"

lemma h_code[code] :
  "h M (q,x) = (let m = set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y,q')) (transitions M))
                 in (case m (q,x) of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}))"
  unfolding set_as_map_def by force

subsection \<open>Extending FSMs by single elements\<close>

fun add_transition :: "('a,'b,'c) fsm_impl \<Rightarrow>
                       ('a,'b,'c) transition \<Rightarrow>
                       ('a,'b,'c) fsm_impl"
  where
  "add_transition M t =
    (if t_source t \<in> states M \<and> t_input t \<in> inputs M \<and>
        t_output t \<in> outputs M \<and> t_target t \<in> states M
     then FSMI (initial M)
               (states M)
               (inputs M)
               (outputs M)
               (insert t (transitions M))
     else M)"

fun add_state :: "('a,'b,'c) fsm_impl \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "add_state M q = FSMI (initial M) (insert q (states M)) (inputs M) (outputs M) (transitions M)"

fun add_input :: "('a,'b,'c) fsm_impl \<Rightarrow> 'b \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "add_input M x = FSMI (initial M) (states M) (insert x (inputs M)) (outputs M) (transitions M)"

fun add_output :: "('a,'b,'c) fsm_impl \<Rightarrow> 'c \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "add_output M y = FSMI (initial M) (states M) (inputs M) (insert y (outputs M)) (transitions M)"

fun add_transition_with_components :: "('a,'b,'c) fsm_impl \<Rightarrow> ('a,'b,'c) transition \<Rightarrow> ('a,'b,'c) fsm_impl" where
  "add_transition_with_components M t = add_transition (add_state (add_state (add_input (add_output M (t_output t)) (t_input t)) (t_source t)) (t_target t)) t"

subsection \<open>Renaming elements\<close>

fun rename_states :: "('a,'b,'c) fsm_impl \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> ('d,'b,'c) fsm_impl" where
  "rename_states M f = FSMI (f (initial M))
                            (f ` states M)
                            (inputs M)
                            (outputs M)
                            ((\<lambda>t . (f (t_source t), t_input t, t_output t, f (t_target t))) ` transitions M)"

end


theory T74
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T102
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end