theory Graph_Genus
imports
  Graph_Theory.Graph_Theory
  "HOL-Library.Permutations"
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 simp: )

  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> assms using \<open>a0 \<in> out_arcs G v0\<close>
          by (intro orbit_FOO) (insert assms, 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


theory T96
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(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. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun altmul :: "Nat => Nat => Nat" where
"altmul (Z) y = Z"
| "altmul (S z) (Z) = Z"
| "altmul (S z) (S x2) =
     plus (plus (plus (S Z) (altmul z x2)) z) x2"

theorem property0 :
  "((altmul x (altmul y z)) = (altmul (altmul x y) z))"
  oops

end


theory List_Refine_Complete
  imports Ballot_Refinement

begin

lemma fintarg:
  assumes fina: "finite A" and
          lobar: "linear_order_on A bar"
  shows "finite {b . (x, b) \<in> bar}"
  proof -
    from fina have finbound: "finite (A \<times> A)"
      by blast
    from lobar fina have barbound: " bar \<subseteq> (A \<times> A)"
      unfolding  linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
      by simp
    from barbound have conssub: "{b . (x, b) \<in> bar} \<subseteq> (A)"
    by blast
    from lobar fina have finbar: "finite bar"
      unfolding  linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
      by (metis finite_SigmaI finite_subset)
    from conssub fina show ?thesis
      using finite_subset by fastforce
  qed

lemma ref_imp_ranksame:
  fixes A :: "'a set" and
        l :: "'a Preference_List" and
        r :: "'a Preference_Relation"
  assumes fina : "finite A"
  assumes wf: "well_formed_pl l"
  assumes lol: "linear_order_on_l A l"
  assumes ref: "r = pl_\<alpha> l"
  shows "\<forall> a \<in> A. rank_l l a = rank r a"
using assms rankeq
  by metis

lemma rankeq_imp_ref:
  fixes A :: "'a set" and
        l :: "'a Preference_List" and
        r :: "'a Preference_Relation"
  assumes fina : "finite A"
  assumes wf: "well_formed_pl l"
  assumes lol: "linear_order_on_l A l" and
          lor: "linear_order_on A r"
  assumes ranksame: "\<forall> a \<in> A. rank_l l a = rank r a"
  shows "r = pl_\<alpha> l"
proof (unfold pl_\<alpha>_def, safe, clarsimp_all, safe)
  fix a b :: 'a
  assume tupler: "(a, b) \<in> r"
  from tupler lor have aA: "a \<in> A"
    unfolding linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
    by blast
  from lol have "set l = A" unfolding losimp by simp
  from aA this show "a \<in> set l" by simp
next
  fix a b :: 'a
  assume tupler: "(a, b) \<in> r"
  from tupler lor have aA: "b \<in> A"
    unfolding linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
    by blast
  from lol have "set l = A" unfolding losimp by simp
  from aA this show "b \<in> set l" by simp
next
  fix a b :: 'a
  assume tupler: "(a, b) \<in> r"
  from lol have Al: "set l = A" unfolding losimp by simp
  from tupler lor have aA: "a \<in> A"
    unfolding linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
    by blast
  from tupler lor have bA: "b \<in> A"
    unfolding linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
    by blast
  from fina lor have "finite r"
    unfolding linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
    using finite_subset
    by blast
  have finbs: "finite {b. (a, b) \<in> r}" using fina lor fintarg
    by fastforce
  from tupler lor have "{ba. (b, ba) \<in> r} \<subseteq> {b. (a, b) \<in> r}"
    unfolding rank.simps above_def
    unfolding linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
              trans_def antisym_def total_on_def
    by blast
  from this have rc: "rank r b \<le> rank r a"
    unfolding rank.simps above_def using card_mono finbs
    by blast
  from ranksame aA have rsa: "rank r a = rank_l l a"
    by simp
  from ranksame bA have rsb: "rank r b = rank_l l b"
    by simp
  from rc aA bA show "index l b \<le> index l a" unfolding rsa rsb
    rank_l.simps Al by auto
next
  fix a b :: 'a
  assume al: "a \<in> set l"
  assume bl: "b \<in> set l"
  assume icmp: "index l b \<le> index l a"
  from lol have Al: "set l = A" unfolding losimp by simp
  from al bl have eitheror: "(a,b) \<in> r \<or> (b,a) \<in> r"
    using lor
    unfolding Al linear_order_on_def total_on_def
    by (metis partial_order_onD(1) refl_onD)
  from al bl icmp have "rank_l l b \<le> rank_l l a"
    unfolding rank_l.simps by auto
  from this al bl ranksame have rankcomp: "rank r b \<le> rank r a"
    unfolding Al by auto
  from this show "(a,b) \<in> r"
  proof (unfold rank.simps above_def)
    assume cardcomp: "card {ba. (b, ba) \<in> r} \<le> card {b. (a, b) \<in> r}"
    have fin1: "finite {ba. (b, ba) \<in> r}" using fintarg
        lor fina
      by metis
    have fin2: "finite {b. (a, b) \<in> r}" using fintarg
        lor fina
      by metis
    from fin1 fin2 cardcomp eitheror show ?thesis
    using lor unfolding linear_order_on_def partial_order_on_def antisym_def
    preorder_on_def trans_def
    by (smt (verit, del_insts) Collect_mono card_seteq mem_Collect_eq refl_onD refl_on_domain)
  qed
qed

lemma ballot_refinement_complete:
  fixes A :: "'a set"
  and bar:: "'a Preference_Relation"
assumes fina: "finite A"
  and lo: "linear_order_on A bar"
  shows "\<exists> bal :: 'a Preference_List. (bal, bar) \<in> ballot_rel"
  unfolding in_br_conv well_formed_pl_def pl_\<alpha>_def
  using assms
proof (induction arbitrary: bar)
  case empty
  then have "bar = {}"
    using lin_ord_not_empty by blast
  then show ?case
    apply (rule_tac x = "[]" in exI)
    by simp
next
  case ih: (insert x F)
  obtain baro where defbaro: "baro = limit F bar"
    by auto
  from ih(4) have lobaro: "linear_order_on F baro"
    unfolding defbaro using limit_presv_lin_ord  by blast
  from this ih(3)[where bar = baro] obtain balo where balrel: "(balo, baro) \<in> ballot_rel"
    unfolding in_br_conv well_formed_pl_def pl_\<alpha>_def
    by blast
  from this have diso: "distinct balo"
    unfolding in_br_conv well_formed_pl_def by simp
  from balrel have absto: "baro = pl_\<alpha> balo"
    unfolding in_br_conv by simp
  from lobaro have lobalo: "linear_order_on_l F balo"
    using balrel linearorder_ref[THEN fun_relD, THEN fun_relD]
    by auto
  then have seteqo: "set balo = F" unfolding losimp by simp
  from ih(1) have finxF: "finite (insert x F)"
    by simp
  from ih.prems have nempcons: "{b. (x, b) \<in> bar} \<noteq> {}"
      unfolding  linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
      by (metis empty_iff insertI1  mem_Collect_eq)
  from ih.prems have barbound: "bar \<subseteq>  ((insert x F) \<times> (insert x F))"
      unfolding  linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
      by simp
  from barbound have conssub: "{b . (x, b) \<in> bar} \<subseteq> (insert x F)"
    by blast
  have  finitecons: "finite {b . (x, b) \<in> bar}"
  proof -
    from finxF have finbound: "finite ((insert x F) \<times> (insert x F))"
      by blast
    from ih.prems finxF have finbar: "finite bar"
      unfolding  linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
      by (metis finite_SigmaI finite_subset)
    from conssub finxF show ?thesis
      using finite_subset by fastforce
  qed
  have rankxgt0: "(rank bar x) > 0"
  proof (unfold rank.simps above_def)
    from nempcons finitecons show "0 < card {b. (x, b) \<in> bar}"
      using card_gt_0_iff by blast
  qed

  obtain constabs where ca: "constabs = baro \<union> {(a, b) \<in> bar. b = x} \<union> {(x,x)} \<union> {(a, b) \<in> bar. a = x}"
    by auto

  have "constabs = bar" unfolding ca defbaro limit.simps using ih(4)
    unfolding linear_order_on_def partial_order_on_def preorder_on_def refl_on_def
    by auto

  obtain newbal where defnb: "newbal = take ((rank bar x) - 1) balo @ [x] @ drop ((rank bar x) - 1) balo"
    by auto
  from seteqo diso ih(2) have disnb: "distinct newbal"
    unfolding defnb
    by (metis distinct_insert_nth insert_nth_take_drop)
  have insx: "set newbal = set balo \<union> {x}"
    unfolding defnb
    by (metis inf_sup_aci(5) insert_is_Un insert_nth_take_drop set_insert_nth)
  then have seteqnb: "set newbal = insert x F"
    using seteqo
    by blast
  from this ih(2) have fdx: "filter (\<lambda>x. x \<in> F) (take ((rank bar x) - 1) balo @ [x] @ drop ((rank bar x) - 1) balo)
      = filter (\<lambda>x. x \<in> F) (take ((rank bar x) - 1) balo @ drop ((rank bar x) - 1) balo)"
    by (metis append_Nil filter.simps(2) filter_append)
  from seteqo have balolim: "balo = limit_l F newbal"
    unfolding limit_l.simps defnb fdx append_take_drop_id
    by simp
  have lonb: "linear_order_on (insert x F) (pl_\<alpha> newbal)"
    using seteqnb[symmetric] unfolding losimp[symmetric]
   linord_eq .
  have barolim: "baro = limit F (pl_\<alpha> newbal)"
    using limit_eq[where bal=newbal and A = F] disnb
    unfolding well_formed_pl_def balolim[symmetric] absto[symmetric] by simp
  from ih(1) ih(2) have cardxinc: "card F = card (insert x F) - 1"
    by simp
  have rankib: "(rank bar x) - 1 \<le> length balo"
  proof -
    have ranklt: "(rank bar x) \<le> card (insert x F)"
      unfolding rank.simps above_def
      using conssub finxF card_mono by blast
    from this cardxinc rankxgt0 have "(rank bar x) - 1 \<le> card (F)"
      by linarith
    from this seteqo show ?thesis
      using card_length order_trans by blast
  qed
  have onFeq: "limit F (pl_\<alpha> newbal) = limit F (bar)"
    using barolim defbaro by fastforce
  from this have fprefs: "\<forall> a \<in> F. \<forall> b \<in> F. (a \<preceq>\<^sub>(pl_\<alpha> newbal) b) = (a \<preceq>\<^sub>(bar) b)"
    using limit_presv_prefs2
    by auto
  (* TODO: assert that x is inserted at the right position *)
  from rankxgt0 rankib have "((take ((rank bar x) - 1) (balo)) @ [x])!((rank bar x)-1) = x"
    by (metis add_diff_cancel_right' append_take_drop_id diff_diff_cancel length_append length_drop nth_append_length)
  from this have "newbal!((rank bar x)-1) = x"
    unfolding defnb
    by (metis add_diff_cancel_right' append_Cons append_take_drop_id diff_diff_cancel length_append length_drop nth_append_length rankib)
  from ih this rankib rankxgt0 seteqnb seteqo disnb diso
  have posxl: "rank_l newbal x = (rank bar x)"
    unfolding rank_l.simps
    by (metis One_nat_def Suc_eq_plus1 Suc_pred card.insert distinct_card index_nth_id insertCI
              less_Suc_eq_le )
  from fprefs this have rankxabs: "rank (pl_\<alpha> newbal) x = (rank bar x)"
    using rankeq disnb unfolding well_formed_pl_def
    by metis
  from onFeq[symmetric] ih(4) finxF this have "bar = (pl_\<alpha> newbal)"
  unfolding rank.simps above_def pl_\<alpha>_def
  using finitecons unfolding is_less_preferred_than.simps
  linear_order_on_def partial_order_on_def preorder_on_def refl_on_def antisym_def trans_def
total_on_def is_less_preferred_than_l.simps seteqnb insert_def apply safe
  apply blast
  apply blast
   unfolding  limit.simps defnb
    sorry
  from this show ?case
    apply (rule_tac x = newbal in exI)
    unfolding pl_\<alpha>_def using disnb by auto
qed

end


(*  Title:      HOL/UNITY/FP.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

From Misra, "A Logic for Concurrent Programming", 1994
*)

section{*Fixed Point of a Program*}

theory FP imports UNITY begin

definition FP_Orig :: "'a program => 'a set" where
    "FP_Orig F == Union{A. ALL B. F : stable (A Int B)}"

definition FP :: "'a program => 'a set" where
    "FP F == {s. F : stable {s}}"

lemma stable_FP_Orig_Int: "F : stable (FP_Orig F Int B)"
apply (simp only: FP_Orig_def stable_def Int_Union2)
apply (blast intro: constrains_UN)
done

lemma FP_Orig_weakest:
    "(!!B. F : stable (A Int B)) ==> A <= FP_Orig F"
by (simp add: FP_Orig_def stable_def, blast)

lemma stable_FP_Int: "F : stable (FP F Int B)"
apply (subgoal_tac "FP F Int B = (UN x:B. FP F Int {x}) ")
prefer 2 apply blast
apply (simp (no_asm_simp) add: Int_insert_right)
apply (simp add: FP_def stable_def)
apply (rule constrains_UN)
apply (simp (no_asm))
done

lemma FP_equivalence: "FP F = FP_Orig F"
apply (rule equalityI)
 apply (rule stable_FP_Int [THEN FP_Orig_weakest])
apply (simp add: FP_Orig_def FP_def, clarify)
apply (drule_tac x = "{x}" in spec)
apply (simp add: Int_insert_right)
done

lemma FP_weakest:
    "(!!B. F : stable (A Int B)) ==> A <= FP F"
by (simp add: FP_equivalence FP_Orig_weakest)

lemma Compl_FP:
    "-(FP F) = (UN act: Acts F. -{s. act``{s} <= {s}})"
by (simp add: FP_def stable_def constrains_def, blast)

lemma Diff_FP: "A - (FP F) = (UN act: Acts F. A - {s. act``{s} <= {s}})"
by (simp add: Diff_eq Compl_FP)

lemma totalize_FP [simp]: "FP (totalize F) = FP F"
by (simp add: FP_def)

end


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

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

definition(*fun*) zero :: "Integer" where
"zero = P Z"

fun pred :: "Nat => Nat" where
"pred (S y) = y"

fun plus2 :: "Nat => Nat => Nat" where
"plus2 (Z) y = y"
| "plus2 (S z) y = S (plus2 z y)"

fun t2 :: "Nat => Nat => Integer" where
"t2 x y =
   (let fail :: Integer =
     (case y of
        Z => P x
        | S z =>
            (case x of
               Z => N y
               | S x2 => t2 x2 z))
   in (case x of
         Z =>
           (case y of
              Z => P Z
              | S x4 => fail)
         | S x3 => fail))"

fun plus :: "Integer => Integer => Integer" where
"plus (P m) (P n) = P (plus2 m n)"
| "plus (P m) (N o2) = t2 m (plus2 (S Z) o2)"
| "plus (N m2) (P n2) = t2 n2 (plus2 (S Z) m2)"
| "plus (N m2) (N n3) = N (plus2 (plus2 (S Z) m2) n3)"

theorem property0 :
  "(x = (plus x zero))"
  oops

end


(*=========================================================================*)
(* Properties about Rounding Errors.                                       *)
(*=========================================================================*)

(* Author: Lei Yu, University of Cambridge *)

theory RoundError imports IEEE FloatProperty begin

subsection {*Properties about Rounding Errors *}

definition error :: "real \<Rightarrow> real" where
"error x = Val(Abs_float(round float_format To_nearest x)) - x"

lemma bound_at_worst_lemma:
  assumes threshold: "\<bar>x\<bar> < threshold float_format"
  assumes finite: "is_finite float_format a"
  shows "abs (valof float_format (round float_format To_nearest x) - x) \<le>
         \<bar>valof float_format a - x\<bar>"
proof -
  have "round float_format To_nearest x =
        closest (valof float_format)  (\<lambda>a. even (fraction a)) {a. is_finite float_format a} x"
    using threshold by (metis abs_less_iff le_minus_iff not_less round.simps(1))
  then have "is_closest (valof float_format) {a. is_finite float_format a} x
            (round float_format To_nearest x)" using closest_is_closest
    by (metis is_finite_finite is_finite_nonempty)
  then show ?thesis
    using finite is_closest_def by (metis mem_Collect_eq)
qed

lemma defloat_float_round: "Rep_float (Abs_float (round float_format To_nearest x)) =
                            round (float_format) To_nearest x"
  by (metis mem_Collect_eq Abs_float_inverse is_valid_round)

lemma error_at_worst_lemma:
  assumes "\<bar>x\<bar> < threshold float_format"  "Finite a"
  shows "\<bar>error x\<bar> \<le> \<bar>Val a - x\<bar> "
proof -
  have "Finite a = is_finite float_format (Rep_float a)" using is_valid_defloat
    by (metis Finite_def Isdenormal_def Isnormal_def Iszero_def is_finite_def)
  then have "\<bar>Val(Abs_float(round float_format To_nearest x)) - x\<bar> \<le> \<bar>Val a - x\<bar>"
    using bound_at_worst_lemma assms
    by (metis Val_def defloat_float_round)
  then show ?thesis by (metis error_def)
qed

lemma error_is_zero [simp]:
  assumes "Finite a"
  shows "error (Val a) = 0"
proof -
  have "\<bar>Val a\<bar> < threshold float_format"
    by (metis abs_less_iff minus_less_iff float_val_gt_threshold float_val_lt_threshold assms)
  then show ?thesis
    by (metis abs_le_zero_iff abs_zero diff_self error_at_worst_lemma assms)
qed

lemma valof_scale_up:
  assumes "e \<noteq> 0"
  shows "valof float_format (s::nat, e + k, f) = 2^k * valof float_format (s, e, f)"
using assms
by auto (metis add.commute power_add)

lemma is_finite_zerosign:
  assumes "is_finite float_format a"
  shows "is_finite float_format (zerosign float_format s a)"
using assms
by (metis (full_types) exponent.simps fraction.simps is_finite_def is_zero_def
    minus_zero_def plus_zero_def zerosign_def zerosign_valid)

lemma defloat_float_zerosign_round_finite:
  assumes threshold: "\<bar>x\<bar> < threshold float_format"
  shows "is_finite float_format
         (zerosign float_format s (round float_format To_nearest x))"
proof -
  have "round float_format To_nearest x =
        (closest (valof float_format) (\<lambda>a. even (fraction a)) {a. is_finite float_format a} x)"
    using threshold by (metis (full_types) abs_less_iff leD le_minus_iff round.simps(1))
  then have "is_finite float_format (round float_format To_nearest x) "
    by (metis is_finite_closest)
  then show ?thesis
    using is_finite_zerosign by auto
qed

lemma signzero_zero: "is_zero float_format a \<Longrightarrow>
      valof float_format (zerosign float_format s a) = 0"
  by (auto simp add: zerosign_def)

lemma val_zero: "is_zero float_format a \<Longrightarrow>
      valof float_format a = 0"
  by (cases a) (auto simp add: is_zero_def)

lemma float_add:
  assumes "Finite a" "Finite b"
  assumes threshold: "\<bar>Val a + Val b\<bar> < threshold float_format"
  shows finite_float_add: "Finite (a + b)"
    and error_float_add:  "Val (a + b) = Val a + Val b + error (Val a + Val b)"
proof -
  have "\<not>(Isnan a)"  "\<not>(Isnan b)"  "\<not>(Infinity a)" "\<not>(Infinity b)"
    using assms float_distinct_finite by auto
  then have ab: "(a + b) = Abs_float (zerosign float_format
                          (if Iszero a \<and> Iszero b \<and> Sign a = Sign b then (Sign a) else 0)
                          (round float_format To_nearest (Val a + Val b)))"
    using assms
    by (auto simp add: float_defs fadd_def plus_float_def)
  then have "is_finite float_format (Rep_float(a + b))"
    by (metis threshold defloat_float_zerosign_round defloat_float_zerosign_round_finite)
  then show "Finite (a + b)"
    by (metis Finite_def Isdenormal_def Isnormal_def Iszero_def is_finite_def)
  have val_ab: "Val (a + b) =
        valof float_format (zerosign float_format
              (if Iszero a \<and> Iszero b \<and> Sign a = Sign b then (Sign a) else 0)
              (round float_format To_nearest (Val a + Val b)))"
    using defloat_float_zerosign_round
    by (auto simp: ab Infinity_def Isnan_def Val_def)
  show "(Val (a + b) = Val a + Val b + error (Val a + Val b))"
  proof (cases "is_zero float_format (round float_format To_nearest (Val a + Val b))")
    case True
    have "Val a + Val b + error (Val a + Val b) =
          valof float_format (round float_format To_nearest (Val a + Val b))"
      unfolding error_def Val_def
      by (metis add_diff_cancel_left add_0_right defloat_float_round diff_add_cancel)
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma float_sub:
  assumes "Finite a" "Finite b"
  assumes threshold: "\<bar>Val a - Val b\<bar> < threshold float_format"
  shows finite_float_sub: "Finite (a - b)"
    and error_float_sub:  "Val (a - b) = Val a - Val b + error (Val a - Val b)"
proof -
  have "\<not>(Isnan a)"  "\<not>(Isnan b)"  "\<not>(Infinity a)" "\<not>(Infinity b)"
    using assms by (auto simp: finite_nan finite_infinity)
  then have ab: "(a - b) = Abs_float (zerosign float_format
                    (if Iszero a \<and> Iszero b \<and> Sign a \<noteq> Sign b then (Sign a) else 0)
                        (round float_format To_nearest (Val a - Val b)))"
    using assms
    by (auto simp add: float_defs fsub_def minus_float_def)
  then have "is_finite float_format (Rep_float(a - b))"
   by (metis threshold defloat_float_zerosign_round_finite defloat_float_zerosign_round)
  then show "Finite (a - b)"
    by (metis Finite_def Isdenormal_def Isnormal_def Iszero_def is_finite_def)
  have val_ab: "Val (a - b) =
                valof float_format (zerosign float_format
                (if Iszero a \<and> Iszero b \<and> Sign a \<noteq> Sign b then (Sign a) else 0)
                    (round float_format To_nearest (Val a - Val b)))"
    using defloat_float_zerosign_round
    by (auto simp: ab Infinity_def Isnan_def Val_def)
  show "(Val (a - b) = Val a - Val b + error (Val a - Val b))"
  proof (cases "is_zero float_format (round float_format To_nearest (Val a - Val b))")
    case True
    have "Val a - Val b + error (Val a - Val b) =
          valof float_format (round float_format To_nearest (Val a - Val b))"
      unfolding error_def Val_def
      by (metis add_diff_cancel_left add_0_right defloat_float_round diff_add_cancel)
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma float_mul:
  assumes "Finite a" "Finite b"
  assumes threshold: "\<bar>Val a * Val b\<bar> < threshold float_format"
  shows finite_float_mul: "Finite (a * b)"
    and error_float_mul:  "Val (a * b) = Val a * Val b + error (Val a * Val b)"
proof -
  have non: "\<not> Isnan a" "\<not> Isnan b"  "\<not> Infinity a"  "\<not> Infinity b"
    using assms float_distinct_finite by auto
  then have ab: "(a * b) = Abs_float (zerosign float_format (of_bool (Sign a \<noteq> Sign b))
                     (round float_format To_nearest (Val a * Val b)))"
    using assms
    by (auto simp: float_defs fmul_def times_float_def)
  then have "is_finite float_format (Rep_float(a * b))"
    by (metis threshold defloat_float_zerosign_round_finite defloat_float_zerosign_round)
  then show "Finite (a * b)"
    by (metis Finite_def Isdenormal_def Isnormal_def Iszero_def is_finite_def)
  have val_ab: "Val (a * b) =
                   valof float_format (zerosign float_format (of_bool (Sign a \<noteq> Sign b))
                         (round float_format To_nearest (Val a * Val b)))"
    using defloat_float_zerosign_round
    by (auto simp: ab float_defs of_bool_def)
  show "(Val (a * b) = Val a * Val b + error (Val a * Val b))"
  proof (cases "is_zero float_format (round float_format To_nearest (Val a * Val b))")
    case True
    have "Val a * Val b + error (Val a * Val b) =
          valof float_format (round float_format To_nearest (Val a * Val b))"
      unfolding error_def Val_def
      by (metis add_diff_cancel_left add_0_right defloat_float_round diff_add_cancel)
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

lemma float_div:
  assumes "Finite a" "Finite b"
  assumes not_zero: "\<not>Iszero b"
  assumes threshold: "\<bar>Val a / Val b\<bar> < threshold float_format"
  shows finite_float_div: "Finite (a / b)"
    and error_float_div:  "Val (a / b) = Val a / Val b + error (Val a / Val b)"
proof -
  have ab: "a / b = Abs_float (zerosign float_format (of_bool (Sign a \<noteq> Sign b))
                               (round float_format To_nearest (Val a / Val b)))"
     using assms
     by (simp add: divide_float_def fdiv_def finite_infinity finite_nan not_zero float_defs [symmetric])
  then have "is_finite float_format (Rep_float(a / b))"
    by (metis threshold defloat_float_zerosign_round_finite defloat_float_zerosign_round)
  then show "Finite (a / b)"
    by (metis Finite_def Isdenormal_def Isnormal_def Iszero_def is_finite_def)
  have val_ab: "Val (a / b) =
                valof float_format (zerosign float_format (of_bool (Sign a \<noteq> Sign b))
                                     (round float_format To_nearest (Val a / Val b)))"
    using defloat_float_zerosign_round
    by (auto simp: ab float_defs of_bool_def)
  show "(Val (a / b) = Val a / Val b + error (Val a / Val b))"
  proof (cases "is_zero float_format (round float_format To_nearest (Val a / Val b))")
    case True
    have "Val a / Val b + error (Val a / Val b) =
          valof float_format (round float_format To_nearest (Val a / Val b))"
      unfolding error_def Val_def
      by (metis add_diff_cancel_left add_0_right defloat_float_round diff_add_cancel)
    then show ?thesis
      by (metis True signzero_zero val_zero val_ab)
  next
    case False then show ?thesis
      by (metis ab add.commute eq_diff_eq' error_def zerosign_def)
  qed
qed

end


theory T151
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(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<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. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, 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(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


theory Chapter04
imports DeBruijnEnvironment
begin

datatype type = NumType | StrType

datatype expr =
  Var var
| Num int
| Str string
| Plus expr expr
| Times expr expr
| Cat expr expr
| Len expr
| Let expr expr

primrec insert :: "var => expr => expr"
where "insert n (Var v) = Var (incr n v)"
    | "insert n (Num x) = Num x"
    | "insert n (Str s) = Str s"
    | "insert n (Plus e1 e2) = Plus (insert n e1) (insert n e2)"
    | "insert n (Times e1 e2) = Times (insert n e1) (insert n e2)"
    | "insert n (Cat e1 e2) = Cat (insert n e1) (insert n e2)"
    | "insert n (Len e) = Len (insert n e)"
    | "insert n (Let e1 e2) = Let (insert n e1) (insert (next n) e2)"

primrec subst :: "expr => var => expr => expr"
where "subst e' n (Var x) = (if x = n then e' else Var (subr n x))"
    | "subst e' n (Num x) = Num x"
    | "subst e' n (Str s) = Str s"
    | "subst e' n (Plus e1 e2) = Plus (subst e' n e1) (subst e' n e2)"
    | "subst e' n (Times e1 e2) = Times (subst e' n e1) (subst e' n e2)"
    | "subst e' n (Cat e1 e2) = Cat (subst e' n e1) (subst e' n e2)"
    | "subst e' n (Len e) = Len (subst e' n e)"
    | "subst e' n (Let e1 e2) = Let (subst e' n e1) (subst (insert first e') (next n) e2)"

inductive typecheck :: "type env => expr => type => bool"
where tc_var [simp]: "lookup gam x = Some t ==> typecheck gam (Var x) t"
    | tc_str [simp]: "typecheck gam (Str s) StrType"
    | tc_num [simp]: "typecheck gam (Num n) NumType"
    | tc_plus [simp]: "typecheck gam e1 NumType ==> typecheck gam e2 NumType ==>
                    typecheck gam (Plus e1 e2) NumType"
    | tc_times [simp]: "typecheck gam e1 NumType ==> typecheck gam e2 NumType ==>
                    typecheck gam (Times e1 e2) NumType"
    | tc_cat [simp]: "typecheck gam e1 StrType ==> typecheck gam e2 StrType ==>
                    typecheck gam (Cat e1 e2) StrType"
    | tc_len [simp]: "typecheck gam e StrType ==> typecheck gam (Len e) NumType"
    | tc_let [simp]: "typecheck gam e1 t1 ==> typecheck (extend gam t1) e2 t2 ==>
                    typecheck gam (Let e1 e2) t2"

inductive_cases [elim!]: "typecheck gam (Var x) t"
inductive_cases [elim!]: "typecheck gam (Str s) t"
inductive_cases [elim!]: "typecheck gam (Num n) t"
inductive_cases [elim!]: "typecheck gam (Plus e1 e2) t"
inductive_cases [elim!]: "typecheck gam (Times e1 e2) t"
inductive_cases [elim!]: "typecheck gam (Cat e1 e2) t"
inductive_cases [elim!]: "typecheck gam (Len e) t"
inductive_cases [elim!]: "typecheck gam (Let e1 e2) t"

lemma [simp]: "typecheck (extend_at n gam t') e t ==> n in gam ==> typecheck gam e' t' ==>
                          typecheck gam (subst e' n e) t"
by (induction "extend_at n gam t'" e t arbitrary: gam e' n rule: typecheck.induct, fastforce+)

end


(* ********************************************************************************

    Theory Preliminaries.thy is part of a package providing supplementary material
    to 'Synthesis of Implementations for Divide-and-conquer Specifications'.
    Copyright (c) 2023  M. Bortin

    The package is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    For more details see the license agreement (LICENSE) you should have
    received along with the package.

   ******************************************************************************* *)

theory Preliminaries
imports Main
begin

text "Arrows in this setting are relations between
      sets of values classified by the source and target types."
type_synonym ('a, 'b) arrow = "('a \<times> 'b) set" ("_ \<rightarrow> _" [50, 50] 51)

abbreviation relcomp'  :: "'a \<rightarrow> 'b \<Rightarrow> 'b \<rightarrow> 'c \<Rightarrow> 'a \<rightarrow> 'c"  (infixr "\<diamondop>" 75)
  where "r \<diamondop> s \<equiv> r O s"

abbreviation converse' :: "'a \<rightarrow> 'b \<Rightarrow> 'b \<rightarrow> 'a"  ("(_\<^sup>\<circ>)" [1000] 999)
  where "r\<^sup>\<circ> \<equiv> r\<inverse>"

section "Arrow divisions"

definition ldiv :: "'a \<rightarrow> 'c \<Rightarrow> 'b \<rightarrow> 'c \<Rightarrow> 'a \<rightarrow> 'b" (infixl "ldiv" 55)
  where "s ldiv r = \<Union>{x. x \<diamondop> r \<subseteq> s}"

lemma ldiv_univ :
"(x \<diamondop> r \<subseteq> s) = (x \<subseteq> s ldiv r)"
  by(simp add: ldiv_def, rule iffI, blast+)

lemma ldiv_mono :
"r \<subseteq> r' \<Longrightarrow> r ldiv s \<subseteq> r' ldiv s"
  by (meson dual_order.trans ldiv_univ subset_refl)

lemma ldiv_mono2 :
"r \<subseteq> r' \<Longrightarrow> s ldiv r' \<subseteq> s ldiv r"
  by (meson dual_order.refl dual_order.trans ldiv_univ relcomp_mono)

definition rdiv :: "'a \<rightarrow> 'b \<Rightarrow> 'a \<rightarrow> 'c \<Rightarrow> 'c \<rightarrow> 'b" (infixl "rdiv" 55)
  where "s rdiv r = \<Union>{x. r \<diamondop> x \<subseteq> s}"

lemma rdiv_univ :
"(r \<diamondop> x \<subseteq> s) = (x \<subseteq> s rdiv r)"
  by(simp add: rdiv_def, rule iffI, blast+)

lemma ldiv_rdiv_comm :
"(r ldiv a) rdiv b = (r rdiv b) ldiv a"
  apply(rule equalityI)
   apply(subst ldiv_univ[THEN sym])
   apply(subst rdiv_univ[THEN sym])
   apply(subst O_assoc[THEN sym])
   apply(subst ldiv_univ)
   apply(subst rdiv_univ, simp)
  apply(subst rdiv_univ[THEN sym])
  apply(subst ldiv_univ[THEN sym])
  apply(subst O_assoc)
  apply(subst rdiv_univ)
  apply(subst ldiv_univ, simp)
  done

section "Functions as relations"

definition "graph_of f = {(a, f a) |a. a \<in> UNIV}"
definition "funct_of r = (\<lambda>u. THE v. (u, v) \<in> r)"

lemma graph_of_funct_of :
"funct_of(graph_of f) = f"
  by(simp add: graph_of_def funct_of_def)

lemma graph_of_inj :
"inj graph_of"
  by (metis graph_of_funct_of injI)

lemma graph_of_id :
"graph_of id = Id"
  by(simp add: graph_of_def, blast)

lemma graph_of_comp :
"graph_of(g \<circ> f) = graph_of f \<diamondop> graph_of g"
  by(simp add: graph_of_def, blast)

lemma graph_of_eqD :
"r = graph_of f \<Longrightarrow> (\<forall>x. (x, f x) \<in> r \<and> (\<forall>v. (x, v) \<in> r \<longrightarrow> v = f x))"
  by(clarsimp simp: graph_of_def)

lemma graph_of_sub :
"graph_of f \<subseteq> graph_of g \<Longrightarrow> f = g"
  using graph_of_def graph_of_eqD by blast

section "Simple and entire arrows"

definition "simple r = (r\<^sup>\<circ> \<diamondop> r \<subseteq> Id)"
definition "entire r = (Id \<subseteq> r \<diamondop> r\<^sup>\<circ>)"

lemma mapping :
"simple r \<Longrightarrow> entire r \<Longrightarrow> \<exists>f. r = graph_of f"
  apply(rule_tac x="\<lambda>x. (SOME v. (x, v) \<in> r)" in exI)
  apply(simp add: simple_def entire_def graph_of_def)
  apply(rule set_eqI, clarsimp)
  apply(rule iffI)
   apply(rule someI2, assumption)
   apply(drule_tac c="(b, v)" in subsetD, fast, simp)
  apply clarify
  apply(drule_tac c="(a, a)" in subsetD, rule IdI)
  apply clarsimp
  apply(erule someI)
  done

section "Monotype factor"

definition "monotypeF r s = (r \<diamondop> s) ldiv r"

lemma monotypeF_mono :
"mono (monotypeF r)"
  by (simp add: ldiv_mono monoI monotypeF_def relcomp_mono)

lemma monotypeF_univ :
"(x \<diamondop> r \<subseteq> r \<diamondop> s) = (x \<subseteq> monotypeF r s)"
  by(simp add: monotypeF_def, rule ldiv_univ)

lemma monotypeF1 :
"monotypeF r s \<diamondop> r \<subseteq> r \<diamondop> s"
  by(subst monotypeF_univ, simp)

section "A least fixed point fusion property"

lemma lfp_fusionG :
"\<forall>x. (F \<circ> H) x \<subseteq> (H \<circ> G) x \<Longrightarrow> G f = f \<Longrightarrow> lfp F \<subseteq> H f"
  by (metis comp_def lfp_lowerbound)

lemma lfp_fusion :
"mono G \<Longrightarrow> \<forall>x. (F \<circ> H) x \<subseteq> (H \<circ> G) x \<Longrightarrow> lfp F \<subseteq> H(lfp G)"
  by (metis lfp_fusionG lfp_unfold)

section "Sorted lists"

fun Sorted :: "('a \<Rightarrow> 'b :: linorder) \<Rightarrow> 'a list \<Rightarrow> bool"
where "Sorted f [] = True" |
      "Sorted f (x # xs) = (Sorted f xs \<and> (\<forall>z \<in> set xs. f x \<le> f z))"

lemma Sorted_append:
  "Sorted f (xs@ys) = (Sorted f xs \<and> Sorted f ys \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. f x \<le> f y))"
  by(induct xs arbitrary:ys, simp+, blast)

lemma Sorted_rem1 :
"Sorted f xs \<Longrightarrow> Sorted f (remove1 x xs)"
  apply(induct xs, simp_all)
  apply clarsimp
  apply(drule_tac x=z in bspec)
   apply(erule subsetD[OF set_remove1_subset])
  by assumption

lemma Sorted_filter :
"Sorted f xs \<Longrightarrow> Sorted f (filter P xs)"
  by(induct xs, simp_all)

lemma Sorted_nth :
"j < length xs \<Longrightarrow> i \<le> j \<Longrightarrow> Sorted f xs \<Longrightarrow> f(xs!i) \<le> f(xs!j)"
  apply(induct xs arbitrary:i j, clarsimp+)
  apply(case_tac j, clarsimp+)
  apply(case_tac i, clarsimp+)
  done

section "A few more auxiliaries"

definition monotype :: "'a set \<Rightarrow> 'a \<rightarrow> 'a"
  where "monotype A = {(x,x) |x. x\<in>A}"

lemma monotype_eq :
"((a, b) \<in> monotype A) = (a = b \<and> a \<in> A)"
  by(simp add: monotype_def, fast)

lemma singleton_eq :
"(a \<in> A) = ({a} \<subseteq> A)"
  by fast

lemma mem_nth :
"x \<in> set xs \<Longrightarrow> \<exists>i<length xs. xs!i = x"
  by(induct xs, fastforce+)

lemma set_drop :
"set(drop k xs) = {xs!i |i. k \<le> i \<and> i < length xs}"
  apply(induct xs arbitrary:k, simp)
  apply(case_tac k, simp)
   apply(subst set_conv_nth)
   apply(rule set_eqI, simp)
   apply(rule iffI)
    apply(erule disjE, rule_tac x=0 in exI, simp)
    apply clarify
    apply(rule_tac x="i+1" in exI, simp)
   apply (metis Suc_length_conv in_set_conv_nth set_ConsD)
  apply clarsimp
  apply(rename_tac n)
  apply(rule set_eqI, simp)
  apply(rule iffI)
   apply clarify
   apply(rule_tac x="i+1" in exI, simp)
  apply clarsimp
  by(case_tac i, simp, fastforce)

corollary set_dropI :
"i < length xs \<Longrightarrow> n \<le> i \<Longrightarrow> xs!i \<in> set(drop n xs)"
  by(subst set_drop, fast)

lemma card_less_diff :
"card A < card B \<Longrightarrow> C \<subseteq> A \<Longrightarrow> D \<subseteq> B \<Longrightarrow> card C = card D \<Longrightarrow> finite A \<Longrightarrow> finite B \<Longrightarrow>
 card (A - C) < card (B - D)"
  by (metis card_Diff_subset card_mono diff_less_mono finite_subset)

end


(*  File:       Elimination_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Elimination Module\<close>

theory Elimination_Module
  imports Evaluation_Function
          Electoral_Module
begin

text \<open>
  This is the elimination module. It rejects a set of alternatives only if
  these are not all alternatives. The alternatives potentially to be rejected
  are put in a so-called elimination set. These are all alternatives that score
  below a preset threshold value that depends on the specific voting rule.
\<close>

subsection \<open>Definition\<close>

type_synonym Threshold_Value = nat

type_synonym Threshold_Relation = "nat \<Rightarrow> nat \<Rightarrow> bool"

type_synonym 'a Electoral_Set = "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a set"

fun elimination_set :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            Threshold_Relation \<Rightarrow> 'a Electoral_Set" where
 "elimination_set e t r A p = {a \<in> A . r (e a A p) t }"

fun elimination_module :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            Threshold_Relation \<Rightarrow> 'a Electoral_Module" where
  "elimination_module e t r A p =
      (if (elimination_set e t r A p) \<noteq> A
        then ({}, (elimination_set e t r A p), A - (elimination_set e t r A p))
        else ({},{},A))"

subsection \<open>Common Eliminators\<close>

fun less_eliminator :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            'a Electoral_Module" where
  "less_eliminator e t A p = elimination_module e t (<) A p"

fun max_eliminator :: "'a Evaluation_Function \<Rightarrow> 'a Electoral_Module" where
  "max_eliminator e A p =
    less_eliminator e (Max {e x A p | x. x \<in> A}) A p"

fun leq_eliminator :: "'a Evaluation_Function \<Rightarrow> Threshold_Value \<Rightarrow>
                            'a Electoral_Module" where
  "leq_eliminator e t A p = elimination_module e t (\<le>) A p"

fun min_eliminator :: "'a Evaluation_Function \<Rightarrow> 'a Electoral_Module" where
  "min_eliminator e A p =
    leq_eliminator e (Min {e x A p | x. x \<in> A}) A p"

fun average :: "'a Evaluation_Function \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow>
                    Threshold_Value" where
  "average e A p = (\<Sum> x \<in> A. e x A p) div (card A)"

fun less_average_eliminator :: "'a Evaluation_Function \<Rightarrow>
                                'a Electoral_Module" where
  "less_average_eliminator e A p = less_eliminator e (average e A p) A p"

fun leq_average_eliminator :: "'a Evaluation_Function \<Rightarrow>
                                'a Electoral_Module" where
  "leq_average_eliminator e A p = leq_eliminator e (average e A p) A p"

subsection \<open>Soundness\<close>

lemma elim_mod_sound[simp]: "electoral_module (elimination_module e t r)"
proof (unfold electoral_module_def, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  have "set_equals_partition A (elimination_module e t r A p)"
    by auto
  thus "well_formed A (elimination_module e t r A p)"
    by simp
qed

lemma less_elim_sound[simp]: "electoral_module (less_eliminator e t)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p < t} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p < t} \<union> A = A"
    by safe
qed

lemma leq_elim_sound[simp]: "electoral_module (leq_eliminator e t)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p \<le> t} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p \<le> t} \<union> A = A"
    by safe
qed

lemma max_elim_sound[simp]: "electoral_module (max_eliminator e)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p < Max {e x A p |x. x \<in> A}} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p < Max {e x A p |x. x \<in> A}} \<union> A = A"
    by safe
qed

lemma min_elim_sound[simp]: "electoral_module (min_eliminator e)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p \<le> Min {e x A p |x. x \<in> A}} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p \<le> Min {e x A p |x. x \<in> A}} \<union> A = A"
    by safe
qed

lemma less_avg_elim_sound[simp]: "electoral_module (less_average_eliminator e)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p < (\<Sum>x\<in>A. e x A p) div card A} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p < (\<Sum>x\<in>A. e x A p) div card A} \<union> A = A"
    by safe
qed

lemma leq_avg_elim_sound[simp]: "electoral_module (leq_average_eliminator e)"
proof (unfold electoral_module_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  show
    "{a \<in> A. e a A p \<le> (\<Sum>x\<in>A. e x A p) div card A} \<noteq> A \<longrightarrow>
      {a \<in> A. e a A p \<le> (\<Sum>x\<in>A. e x A p) div card A} \<union> A = A"
    by safe
qed

subsection \<open>Non-Electing\<close>

lemma elim_mod_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (elimination_module e t r )"
  unfolding non_electing_def
  by simp

lemma less_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (less_eliminator e t)"
  using elim_mod_non_electing profile less_elim_sound
  unfolding non_electing_def
  by simp

lemma leq_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (leq_eliminator e t)"
  unfolding non_electing_def
  by simp

lemma max_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (max_eliminator e)"
  unfolding non_electing_def
  by simp

lemma min_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (min_eliminator e)"
  unfolding non_electing_def
  by simp

lemma less_avg_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (less_average_eliminator e)"
proof (unfold non_electing_def, safe)
  show "electoral_module (less_average_eliminator e)"
    by simp
next
  fix
    A :: "'b set" and
    p :: "'b Profile" and
    x :: "'b"
  assume
    fin_A: "finite A" and
    prof_p: "profile A p" and
    elect_x: "x \<in> elect (less_average_eliminator e) A p"
  hence fin_prof: "finite_profile A p"
    by metis
  have "non_electing (less_average_eliminator e)"
    unfolding non_electing_def
    by simp
  hence "{} = elect (less_average_eliminator e) A p"
    using fin_prof
    unfolding non_electing_def
    by metis
  thus "x \<in> {}"
    using elect_x
    by metis
qed

lemma leq_avg_elim_non_electing:
  assumes profile: "finite_profile A p"
  shows "non_electing (leq_average_eliminator e)"
proof (unfold non_electing_def, safe)
  show "electoral_module (leq_average_eliminator e)"
    by simp
next
  fix
    A :: "'b set" and
    p :: "'b Profile" and
    x :: "'b"
  assume
    fin_A: "finite A" and
    prof_p: "profile A p" and
    elect_x: "x \<in> elect (leq_average_eliminator e) A p"
  hence fin_prof: "finite_profile A p"
    by metis
  have "non_electing (leq_average_eliminator e)"
    unfolding non_electing_def
    by simp
  hence "{} = elect (leq_average_eliminator e) A p"
    using fin_prof
    unfolding non_electing_def
    by metis
  thus "x \<in> {}"
    using elect_x
    by metis
qed

subsection \<open>Inference Rules\<close>

text \<open>
  If the used evaluation function is Condorcet rating,
    max-eliminator is Condorcet compatible.
\<close>

theorem cr_eval_imp_ccomp_max_elim[simp]:
  assumes
    profile: "finite_profile A p" and
    rating: "condorcet_rating e"
  shows "condorcet_compatibility (max_eliminator e)"
proof (unfold condorcet_compatibility_def, safe)
  show "electoral_module (max_eliminator e)"
    by simp
next
  fix
    A :: "'b set" and
    p :: "'b Profile" and
    w :: "'b"
  assume
    c_win: "condorcet_winner A p w" and
    rej_w: "w \<in> reject (max_eliminator e) A p"
  have "e w A p = Max {e a A p | a. a \<in> A}"
    using c_win cond_winner_imp_max_eval_val rating
    by fastforce
  hence "w \<notin> reject (max_eliminator e) A p"
    by simp
  thus "False"
    using rej_w
    by linarith
next
  fix
    A :: "'b set" and
    p :: "'b Profile" and
    l :: "'b"
  assume elect_l: "l \<in> elect (max_eliminator e) A p"
  have "l \<notin> elect (max_eliminator e) A p"
    by simp
  thus False
    using elect_l
    by linarith
next
  fix
    A :: "'b set" and
    p :: "'b Profile" and
    w :: "'b" and
    l :: "'b"
  assume
    "condorcet_winner A p w" and
    "w \<in> elect (max_eliminator e) A p"
  thus "l \<in> reject (max_eliminator e) A p"
    using profile rating condorcet_winner.elims(2)
          empty_iff max_elim_non_electing
    unfolding non_electing_def
    by metis
qed

lemma cr_eval_imp_dcc_max_elim_helper1:
  assumes
    f_prof: "finite_profile A p" and
    rating: "condorcet_rating e" and
    winner: "condorcet_winner A p w"
  shows "elimination_set e (Max {e x A p | x. x \<in> A}) (<) A p = A - {w}"
proof (safe, simp_all, safe)
  assume
    "e w A p < Max {e x A p |x. x \<in> A}"
  thus False
    using cond_winner_imp_max_eval_val
          rating winner f_prof
    by fastforce
next
  fix x :: "'a"
  assume
    x_in_A: "x \<in> A" and
    not_max: "\<not> e x A p < Max {e y A p |y. y \<in> A}"
  show "x = w"
    using non_cond_winner_not_max_eval x_in_A
          rating winner f_prof not_max
    by (metis (mono_tags, lifting))
qed

text \<open>
  If the used evaluation function is Condorcet rating, max-eliminator
  is defer-Condorcet-consistent.
\<close>

theorem cr_eval_imp_dcc_max_elim[simp]:
  assumes rating: "condorcet_rating e"
  shows "defer_condorcet_consistency (max_eliminator e)"
proof (unfold defer_condorcet_consistency_def, safe, simp)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    winner: "condorcet_winner A p w" and
    finite: "finite A"
  hence profile: "finite_profile A p"
    by simp
  let ?trsh = "(Max {e y A p | y. y \<in> A})"
  show
    "max_eliminator e A p =
      ({},
        A - defer (max_eliminator e) A p,
        {a \<in> A. condorcet_winner A p a})"
  proof (cases "elimination_set e (?trsh) (<) A p \<noteq> A")
    case True
    from profile rating winner
    have 0: "(elimination_set e ?trsh (<) A p) = A - {w}"
      using cr_eval_imp_dcc_max_elim_helper1
      by (metis (mono_tags, lifting))
    have
      "max_eliminator e A p =
        ({},
          (elimination_set e ?trsh (<) A p),
          A - (elimination_set e ?trsh (<) A p))"
      using True
      by simp
    also have "... = ({}, A - {w}, {w})"
      using 0 winner
      by auto
    also have "... = ({},A - defer (max_eliminator e) A p, {w})"
      using calculation
      by simp
    also have
      "... =
        ({},
          A - defer (max_eliminator e) A p,
          {d \<in> A. condorcet_winner A p d})"
      using cond_winner_unique3 winner Collect_cong
      by (metis (no_types, lifting))
    finally show ?thesis
      using finite winner
      by metis
  next
    case False
    have "?trsh = e w A p"
      using rating winner
      by (simp add: cond_winner_imp_max_eval_val)
    thus ?thesis
      using winner False
      by auto
  qed
qed

end


(* Title: Program Correctness Component Based on Kleene Algebra with Domain
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

subsection\<open>Component Based on Kleene Algebra with Domain\<close>

text \<open>This component supports the verification and step-wise refinement of simple while programs
in a partial correctness setting.\<close>

theory VC_KAD_scratch
  imports Main
begin

subsubsection \<open>KAD: Definitions and Basic Properties\<close>

notation times (infixl "\<cdot>" 70)

class plus_ord = plus + ord +
  assumes less_eq_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and less_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"

class dioid = semiring + one + zero + plus_ord +
  assumes add_idem [simp]: "x + x = x"
  and mult_onel [simp]: "1 \<cdot> x = x"
  and mult_oner [simp]: "x \<cdot> 1 = x"
  and add_zerol [simp]: "0 + x = x"
  and annil [simp]: "0 \<cdot> x = 0"
  and annir [simp]: "x \<cdot> 0 = 0"

begin

subclass monoid_mult
  by (standard, simp_all)

subclass order
  by (standard, simp_all add: less_def less_eq_def add_commute, auto, metis add_assoc)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis distrib_right less_eq_def)

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis distrib_left less_eq_def)

lemma add_iso: "x \<le> y \<Longrightarrow> z + x \<le> z + y"
  by (metis add.semigroup_axioms add_idem less_eq_def semigroup.assoc)

lemma add_ub: "x \<le> x + y"
  by (metis add_assoc add_idem less_eq_def)

lemma add_lub: "x + y \<le> z \<longleftrightarrow> x \<le> z \<and> y \<le> z"
  by (metis add_assoc add_commute less_eq_def order.ordering_axioms ordering.refl)

end

class kleene_algebra  = dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

begin

lemma star_sim: "x \<cdot> y \<le> z \<cdot> x \<Longrightarrow> x \<cdot> y\<^sup>\<star> \<le> z\<^sup>\<star> \<cdot> x"
proof -
  assume "x \<cdot> y \<le> z \<cdot> x"
  hence "x + z\<^sup>\<star> \<cdot> x \<cdot> y \<le> x + z\<^sup>\<star> \<cdot> z \<cdot> x"
    by (metis add_lub distrib_left eq_refl less_eq_def mult_assoc)
  also have  "... \<le> z\<^sup>\<star> \<cdot> x"
    using add_lub mult_isor star_unfoldr by fastforce
  finally show ?thesis
    by (simp add: star_inductr)
qed

end

class antidomain_kleene_algebra = kleene_algebra +
  fixes ad :: "'a \<Rightarrow> 'a" ("ad")
  assumes as1 [simp]: "ad x \<cdot> x = 0"
  and as2 [simp]: "ad (x \<cdot> y) + ad (x \<cdot> ad (ad y)) = ad (x \<cdot> ad (ad y))"
  and as3 [simp]: "ad (ad x) + ad x = 1"

begin

definition dom_op :: "'a \<Rightarrow> 'a" ("d") where
  "d x = ad (ad x)"

lemma a_subid_aux: "ad x \<cdot> y \<le> y"
  by (metis add_commute add_ub as3 mult_1_left mult_isor)

lemma d1_a [simp]: "d x \<cdot> x = x"
  by (metis add_commute dom_op_def add_zerol as1 as3 distrib_right mult_1_left)

lemma a_idem [simp]: "ad x \<cdot> ad x = ad x"
  by (metis a_d_closed d1_a)

lemma meet_ord: "ad x \<le> ad y \<longleftrightarrow> ad x \<cdot> ad y = ad x"
  by (metis a_d_closed a_subid_aux d1_a antisym mult_1_right mult_isol)

lemma d_wloc: "x \<cdot> y = 0 \<longleftrightarrow> x \<cdot> d y = 0"
  by (metis a_subid_aux d1_a dom_op_def add_ub antisym as1 as2 mult_1_right mult_assoc)

lemma gla_1: "ad x \<cdot> y = 0 \<Longrightarrow> ad x \<le> ad y"
  by (metis a_subid_aux d_wloc dom_op_def add_zerol as3 distrib_left mult_1_right)

lemma a2_eq [simp]: "ad (x \<cdot> d y) = ad (x \<cdot> y)"
  by (metis a_mul_d d1_a dom_op_def gla_1 add_ub antisym as1 as2 mult_assoc)

lemma a_supdist: "ad (x + y) \<le> ad x"
  by (metis add_commute gla_1 add_ub add_zerol as1 distrib_left less_eq_def)

lemma a_antitone: "x \<le> y \<Longrightarrow> ad y \<le> ad x"
  by (metis a_supdist less_eq_def)

lemma a_comm: "ad x \<cdot> ad y = ad y \<cdot> ad x"
proof -
{ fix x y
  have "ad x \<cdot> ad y = d (ad x \<cdot> ad y) \<cdot> ad x \<cdot> ad y"
    by (simp add: mult_assoc)
  also have "... \<le> d (ad y) \<cdot> ad x"
    by (metis a_antitone a_d_closed a_subid_aux mult_oner a_subid_aux dom_op_def mult_isol mult_isor meet_ord)
  finally have "ad x \<cdot> ad y \<le> ad y \<cdot> ad x"
    by simp }
  thus ?thesis
    by (simp add: antisym)
qed

lemma a_closed [simp]: "d (ad x \<cdot> ad y) = ad x \<cdot> ad y"
proof -
  have f1: "\<And>x y. ad x \<le> ad (ad y \<cdot> x)"
    by (simp add: a_antitone a_subid_aux)
  have "\<And>x y. d (ad x \<cdot> y) \<le> ad x"
    by (metis a2_eq a_antitone a_comm a_d_closed dom_op_def f1)
  hence "\<And>x y. d (ad x \<cdot> y) \<cdot> y = ad x \<cdot> y"
    by (metis d1_a dom_op_def meet_ord mult_assoc)
  thus ?thesis
    by (metis a_comm a_idem dom_op_def)
qed

lemma d1_sum_var: "x + y \<le> (d x + d y) \<cdot> (x + y)"
proof -
  have "x + y = d x \<cdot> x + d y \<cdot> y"
    by simp
  also have "... \<le> (d x + d y) \<cdot> x + (d x + d y) \<cdot> y"
    by (metis add_commute add_lub add_ub combine_common_factor)
  finally show ?thesis
    by (simp add: distrib_left)
qed

lemma a4: "ad (x + y) = ad x \<cdot> ad y"
proof (rule antisym)
  show "ad (x + y) \<le> ad x \<cdot> ad y"
    by (metis a_supdist add_commute mult_isor meet_ord)
  hence "ad x \<cdot> ad y = ad x \<cdot> ad y + ad (x + y)"
    using less_eq_def add_commute by simp
  also have "... = ad (ad (ad x \<cdot> ad y) \<cdot> (x + y))"
    by (metis a_closed a_exp)
  finally show "ad x \<cdot> ad y \<le> ad (x + y)"
    using a_antitone d1_sum_var dom_op_def by auto
qed

lemma kat_prop: "d x \<cdot> y \<le> y \<cdot> d z \<longleftrightarrow> d x \<cdot> y \<cdot> ad z = 0"
proof
  show  "d x \<cdot> y \<le> y \<cdot> d z \<Longrightarrow> d x \<cdot> y \<cdot> ad z = 0"
    by (metis add_commute dom_op_def add_zerol annir as1 less_eq_def mult_isor mult_assoc)
next
  assume h: "d x \<cdot> y \<cdot> ad z = 0"
  hence "d x \<cdot> y = d x \<cdot> y \<cdot> d z + d x \<cdot> y \<cdot> ad z"
    by (metis dom_op_def as3 distrib_left mult_1_right)
  thus  "d x \<cdot> y \<le> y \<cdot> d z"
    by (metis a_subid_aux add_commute dom_op_def h add_zerol mult_assoc)
qed

lemma shunt: "ad x \<le> ad y + ad z \<longleftrightarrow> ad x \<cdot> d y \<le> ad z"
proof
  assume "ad x \<le> ad y + ad z"
  hence "ad x \<cdot> d y \<le> ad y \<cdot> d y + ad z \<cdot> d y"
    by (metis distrib_right mult_isor)
  thus " ad x \<cdot> d y \<le> ad z"
    by (metis a_closed a_d_closed a_exp a_mul_d a_supdist dom_op_def dual_order.trans less_eq_def)
next
  assume h: "ad x \<cdot> d y \<le> ad z"
  have "ad x = ad x \<cdot> ad y + ad x \<cdot> d y"
    by (metis add_commute dom_op_def as3 distrib_left mult_1_right)
  also have "... \<le> ad x \<cdot> ad y + ad z"
    using h add_lub dual_order.trans by blast
  also have "... \<le> ad y + ad z"
    by (metis a_subid_aux add_commute add_lub add_ub dual_order.trans)
  finally show "ad x \<le> ad y + ad z"
    by simp
qed

subsubsection \<open>wp Calculus\<close>

definition if_then_else :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = d p \<cdot> x + ad p \<cdot> y"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while p do x od = (d p \<cdot> x)\<^sup>\<star> \<cdot> ad p"

definition while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

definition wp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "wp x p = ad (x \<cdot> ad p)"

lemma demod: " d p \<le> wp x q \<longleftrightarrow> d p \<cdot> x \<le> x \<cdot> d q"
  by (metis as1 dom_op_def gla_1 kat_prop meet_ord mult_assoc wp_def)

lemma wp_weaken: "wp x p \<le> wp (x \<cdot> ad q) (d p \<cdot> ad q)"
  by (metis a4 a_antitone a_d_closed a_mul_d dom_op_def gla_1 mult_isol mult_assoc wp_def)

lemma wp_seq [simp]: "wp (x \<cdot> y) q = wp x (wp y q)"
  using a2_eq dom_op_def mult_assoc wp_def by auto

lemma wp_seq_var: "p \<le> wp x r \<Longrightarrow> r \<le> wp y q \<Longrightarrow> p \<le> wp (x \<cdot> y) q"
proof -
  assume a1: "p \<le> wp x r"
  assume a2: "r \<le> wp y q"
  have "\<forall>z. \<not> wp x r \<le> z \<or> p \<le> z"
    using a1 dual_order.trans by blast
  then show ?thesis
    using a2 a_antitone mult_isol wp_def wp_seq by auto
qed

lemma wp_cond_var [simp]: "wp (if p then x else y fi) q = (ad p + wp x q) \<cdot> (d p + wp y q)"
  using a4 a_d_closed dom_op_def if_then_else_def distrib_right mult_assoc wp_def by auto

lemma wp_cond_aux1 [simp]: "d p \<cdot> wp (if p then x else y fi) q = d p \<cdot> wp x q"
proof -
  have "d p \<cdot> wp (if p then x else y fi) q = ad (ad p) \<cdot> (ad p + wp x q) \<cdot> (d p + wp y q)"
    using dom_op_def mult.semigroup_axioms semigroup.assoc wp_cond_var by fastforce
  also have "... = wp x q \<cdot> d p \<cdot> (d p + d (wp y q))"
    using a_comm a_d_closed dom_op_def distrib_left wp_def by auto
  also have "... = wp x q \<cdot> d p"
    by (metis a_exp dom_op_def add_ub meet_ord mult_assoc)
  finally show ?thesis
    by (simp add: a_comm dom_op_def wp_def)
qed

lemma wp_cond_aux2 [simp]: "ad p \<cdot> wp (if p then x else y fi) q = ad p \<cdot> wp y q"
  by (metis (no_types) abel_semigroup.commute if_then_else_def a_d_closed add.abel_semigroup_axioms dom_op_def wp_cond_aux1)

lemma wp_cond [simp]: "wp (if p then x else y fi) q = (d p \<cdot> wp x q) + (ad p \<cdot> wp y q)"
  by (metis as3 distrib_right dom_op_def mult_1_left wp_cond_aux2 wp_cond_aux1)

lemma wp_star_induct_var: "d q \<le> wp x q \<Longrightarrow> d q \<le> wp (x\<^sup>\<star>) q"
  using demod star_sim by blast

lemma wp_while: "d p \<cdot> d r \<le> wp x p \<Longrightarrow> d p \<le> wp (while r do x od) (d p \<cdot> ad r)"
proof -
  assume "d p \<cdot> d r \<le> wp x p"
  hence "d p \<le> wp (d r \<cdot> x) p"
    using dom_op_def mult.semigroup_axioms semigroup.assoc shunt wp_def by fastforce
  hence "d p \<le> wp ((d r \<cdot> x)\<^sup>\<star>) p"
    using wp_star_induct_var by blast
  thus ?thesis
    by (metis order.ordering_axioms ordering.trans while_def wp_weaken)
qed

lemma wp_while_inv: "d p \<le> d i \<Longrightarrow> d i \<cdot> ad r \<le> d q \<Longrightarrow> d i \<cdot> d r \<le> wp x i \<Longrightarrow> d p \<le> wp (while r inv i do x od) q"
proof -
  assume a1: "d p \<le> d i" and a2: "d i \<cdot> ad r \<le> d q" and "d i \<cdot> d r \<le> wp x i"
  hence "d i \<le> wp (while r inv i do x od) (d i \<cdot> ad r)"
    by (simp add: while_inv_def wp_while)
  also have "... \<le>  wp (while r inv i do x od) q"
    by (metis a2 a_antitone a_d_closed dom_op_def mult_isol wp_def)
  finally show ?thesis
    using a1 dual_order.trans by blast
qed

lemma wp_while_inv_break: "d p \<le> wp y i \<Longrightarrow> d i \<cdot> ad r \<le> d q \<Longrightarrow> d i \<cdot> d r \<le> wp x i \<Longrightarrow> d p \<le> wp (y \<cdot> (while r inv i do x od)) q"
  by (metis dom_op_def eq_refl mult_1_left mult_1_right wp_def wp_seq wp_seq_var wp_while_inv)

end

subsubsection \<open>Soundness and Relation KAD\<close>

notation relcomp (infixl ";" 70)

interpretation rel_d: dioid Id "{}" "(\<union>)" "(;)" "(\<subseteq>)" "(\<subset>)"
  by (standard, auto)

lemma (in dioid) pow_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x ^ i \<cdot> z \<le> y"
  apply (induct i; clarsimp simp add: add_lub)
  by (metis local.dual_order.trans local.mult_isol mult_assoc)

lemma (in dioid) pow_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ i \<le> y"
  apply (induct i; clarsimp simp add: add_lub)
  proof -
    fix i
    assume "z \<cdot> x ^ i \<le> y" "z \<le> y" "y \<cdot> x \<le> y"
    hence "(z \<cdot> x ^ i) \<cdot> x \<le> y"
      using local.dual_order.trans local.mult_isor by blast
    thus "z \<cdot> (x \<cdot> x ^ i) \<le> y"
      by (simp add: mult_assoc local.power_commutes)
  qed

lemma power_is_relpow: "rel_d.power X i = X ^^ i"
  by (induct i, simp_all add: relpow_commute)

lemma rel_star_def: "X^* = (\<Union>i. rel_d.power X i)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "X ; Y^* = (\<Union>i. X ; rel_d.power Y i)"
  by (simp add: rel_star_def relcomp_UNION_distrib)

lemma rel_star_contr: "X^* ; Y = (\<Union>i. (rel_d.power X i) ; Y)"
  by (simp add: rel_star_def relcomp_UNION_distrib2)

definition rel_ad :: "'a rel \<Rightarrow> 'a rel" where
  "rel_ad R = {(x,x) | x. \<not> (\<exists>y. (x,y) \<in> R)}"

interpretation rel_aka: antidomain_kleene_algebra Id "{}" "(\<union>)"  "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl rel_ad
  apply standard
  apply auto[2]
  by (auto simp: rel_star_contr rel_d.pow_inductl rel_star_contl SUP_least rel_d.pow_inductr rel_ad_def)

subsubsection \<open>Embedding Predicates in Relations\<close>

type_synonym 'a pred = "'a \<Rightarrow> bool"

abbreviation p2r :: "'a pred \<Rightarrow> 'a rel" ("\<lceil>_\<rceil>") where
  "\<lceil>P\<rceil> \<equiv> {(s,s) |s. P s}"

lemma d_p2r [simp]: "rel_aka.dom_op \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (auto simp: rel_aka.dom_op_def rel_ad_def)

lemma p2r_neg_hom [simp]: "rel_ad \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<not>P s\<rceil>"
  by (auto simp: rel_ad_def)

lemma p2r_conj_hom [simp]: "\<lceil>P\<rceil> \<inter> \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>"
  by auto

lemma p2r_conj_hom_var [simp]: "\<lceil>P\<rceil> ; \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>"
  by auto

lemma p2r_disj_hom [simp]: "\<lceil>P\<rceil> \<union> \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<or> Q s\<rceil>"
  by auto

subsubsection \<open>Store and Assignment\<close>

type_synonym 'a store = "string  \<Rightarrow> 'a"

definition gets :: "string \<Rightarrow> ('a store \<Rightarrow> 'a) \<Rightarrow> 'a store rel" ("_ ::= _" [70, 65] 61) where
  "v ::= e = {(s,s (v := e s)) |s. True}"

lemma wp_assign [simp]: "rel_aka.wp (v ::= e) \<lceil>Q\<rceil> = \<lceil>\<lambda>s. Q (s (v := e s))\<rceil>"
  by (auto simp: rel_aka.wp_def gets_def rel_ad_def)

abbreviation spec_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("PRE _ _ POST _" [64,64,64] 63) where
  "PRE P X POST Q \<equiv> rel_aka.dom_op \<lceil>P\<rceil> \<subseteq> rel_aka.wp X \<lceil>Q\<rceil>"

abbreviation if_then_else_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("IF _ THEN _ ELSE _ FI" [64,64,64] 63) where
  "IF P THEN X ELSE Y FI \<equiv> rel_aka.if_then_else \<lceil>P\<rceil> X Y"

abbreviation while_inv_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("WHILE _ INV _ DO _ OD" [64,64,64] 63) where
  "WHILE P INV I DO X OD \<equiv> rel_aka.while_inv \<lceil>P\<rceil> \<lceil>I\<rceil> X"

subsubsection \<open>Verification Example\<close>

lemma euclid:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule rel_aka.wp_while_inv, simp_all) using gcd_red_nat by auto

context antidomain_kleene_algebra
begin

subsubsection\<open>Propositional Hoare Logic\<close>

definition H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "H p x q \<longleftrightarrow> d p \<le> wp x q"

lemma H_skip: "H p 1 p"
  by (simp add: H_def dom_op_def wp_def)

lemma H_cons: "d p \<le> d p' \<Longrightarrow> d q' \<le> d q \<Longrightarrow> H p' x q' \<Longrightarrow> H p x q"
  by (meson H_def demod mult_isol order_trans)

lemma H_seq: "H p x r \<Longrightarrow> H r y q \<Longrightarrow> H p (x \<cdot> y) q"
  by (metis H_def a_d_closed demod dom_op_def wp_seq_var)

lemma H_cond: "H (d p \<cdot> d r) x q \<Longrightarrow> H (d p \<cdot> ad r) y q \<Longrightarrow> H p (if r then x else y fi) q"
proof -
  assume  h1: "H (d p \<cdot> d r) x q" and h2: "H (d p \<cdot> ad r) y q"
  hence h3: "d p \<cdot> d r \<le> wp x q" and h4: "d p \<cdot> ad r \<le> wp y q"
    using H_def a_closed dom_op_def apply auto[1]
    using H_def h2 a_closed dom_op_def by auto
  hence h5: "d p  \<le> ad r + wp x q" and h6: "d p  \<le> d r + wp y q"
    apply (simp add: dom_op_def shunt wp_def)
    using h4 a_d_closed dom_op_def shunt wp_def by auto
  hence "d p \<le> d p  \<cdot> (d r + wp y q)"
    by (metis a_idem distrib_left dom_op_def less_eq_def)
  also have  "... \<le> (ad r + wp x q) \<cdot> (d r + wp y q)"
    by (simp add: h5 mult_isor)
  finally show ?thesis
    by (simp add: H_def)
qed

lemma H_loop: "H (d p \<cdot> d r) x p \<Longrightarrow> H p (while r do x od) (d p \<cdot> ad r)"
  by (metis (full_types) H_def a_closed dom_op_def wp_while)

lemma H_while_inv: "d p \<le> d i \<Longrightarrow> d i \<cdot> ad r \<le> d q \<Longrightarrow> H (d i \<cdot> d r) x i \<Longrightarrow> H p (while r inv i do x od) q"
  using H_def a_closed dom_op_def wp_while_inv by auto

end

subsubsection\<open>Definition of Refinement KAD\<close>

class rkad = antidomain_kleene_algebra +
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes R_def: "x \<le> R p q \<longleftrightarrow> d p \<le> wp x q"

begin

subsubsection \<open>Propositional Refinement Calculus\<close>

lemma HR: "H p x q \<longleftrightarrow> x \<le> R p q"
  by (simp add: H_def R_def)

lemma wp_R2: "x \<le> R (wp x q) q"
  by (simp add: R_def wp_def)

lemma wp_R3: "d p \<le> wp x q \<Longrightarrow> x \<le> R p q"
  by (simp add: R_def)

lemma H_R1: "H p (R p q) q"
  by (simp add: HR)

lemma R_skip: "1 \<le> R p p"
  by (simp add: H_R2 H_skip)

lemma R_cons: "d p \<le> d p' \<Longrightarrow> d q' \<le> d q \<Longrightarrow> R p' q' \<le> R p q"
  by (simp add: H_R1 H_R2 H_cons)

lemma R_seq: "(R p r) \<cdot> (R r q) \<le> R p q"
  using H_R1 H_R2 H_seq by blast

lemma R_cond: "if v then (R (d v \<cdot> d p) q) else (R (ad v \<cdot> d p) q) fi \<le> R p q"
  by (simp add: H_R1 H_R2 H_cond a_comm dom_op_def)

lemma R_loop: "while q do (R (d p \<cdot> d q) p) od \<le> R p (d p \<cdot> ad q)"
  by (simp add: H_R1 H_R2 H_loop)

end

subsubsection \<open>Soundness and Relation RKAD\<close>

definition rel_R :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_R P Q = \<Union>{X. rel_aka.dom_op P \<subseteq> rel_aka.wp X Q}"

interpretation rel_rkad: rkad Id "{}" "(\<union>)"  "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl rel_ad rel_R
  by (standard, auto simp: rel_R_def rel_aka.dom_op_def rel_ad_def rel_aka.wp_def, blast)

subsubsection \<open>Assignment Laws\<close>

lemma R_assign: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (auto simp: rel_rkad.R_def)

lemma H_assign_var: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> rel_aka.H \<lceil>P\<rceil> (v ::= e) \<lceil>Q\<rceil>"
  by (auto simp: rel_aka.H_def rel_aka.dom_op_def rel_ad_def gets_def rel_aka.wp_def)

lemma R_assignr: "(\<forall>s. Q' s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (rel_R \<lceil>P\<rceil> \<lceil>Q'\<rceil>) ; (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply (subst rel_rkad.HR[symmetric], rule rel_aka.H_seq) defer
  by (erule H_assign_var, simp add: rel_rkad.H_R1)

lemma R_assignl: "(\<forall>s. P s \<longrightarrow> P' (s (v := e s))) \<Longrightarrow> (v ::= e) ; (rel_R \<lceil>P'\<rceil> \<lceil>Q\<rceil>) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (subst rel_rkad.HR[symmetric], rule rel_aka.H_seq, erule H_assign_var, simp add: rel_rkad.H_R1)

subsubsection \<open>Refinement Example\<close>

lemma var_swap_ref1:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref2:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''x'' ::= (\<lambda>s. s ''y'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref3:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''y'' ::= (\<lambda>s. s ''z'')); rel_R \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref_var:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); (''x'' ::= (\<lambda>s. s ''y'')); (''y'' ::= (\<lambda>s. s ''z''))"
  using var_swap_ref1 var_swap_ref2 var_swap_ref3 rel_rkad.R_skip  by fastforce

end