(* Title: Vector_Matrix_Mod.thy
   Author: Chelsea Edmonds
*)

section \<open> Matrices/Vectors mod x \<close>
text \<open> This section formalises operations and properties mod some integer x on integer matrices and
vectors. Much of this file was no longer needed for fishers once the generic idea of lifting a 0-1 matrix
was introduced, however it is left as an example for future work on matrices mod n, beyond 0-1 matrices  \<close>
theory Vector_Matrix_Mod imports Matrix_Vector_Extras
Berlekamp_Zassenhaus.Finite_Field Berlekamp_Zassenhaus.More_Missing_Multiset
begin

text \<open>Simple abbreviations for main mapping functions \<close>
abbreviation to_int_mat :: "'a :: finite mod_ring mat \<Rightarrow> int mat" where
  "to_int_mat \<equiv> map_mat to_int_mod_ring"

abbreviation to_int_vec :: "'a :: finite mod_ring vec \<Rightarrow> int vec" where
"to_int_vec \<equiv> map_vec to_int_mod_ring"

interpretation of_int_mod_ring_hom_sr: semiring_hom of_int_mod_ring
proof (unfold_locales)
  show "\<And>x y. of_int_mod_ring (x + y) = of_int_mod_ring x + of_int_mod_ring y"
    by (transfer,presburger)
  show "of_int_mod_ring 1 = 1" by (metis of_int_hom.hom_one of_int_of_int_mod_ring)
  show "\<And>x y. of_int_mod_ring (x * y) = of_int_mod_ring x * of_int_mod_ring y"
    by (transfer, simp add: mod_mult_eq)
qed

text \<open>NOTE: The context directly below is copied from Matrix Vector Extras, as for some reason
they can't be used locally if not? Ideally remove in future if possible \<close>

context inj_zero_hom
begin

lemma  vec_hom_zero_iff[simp]: "(map_vec hom x = 0\<^sub>v n) = (x = 0\<^sub>v n)"
proof -
  {
    fix i
    assume i: "i < n" "dim_vec x = n"
    hence "map_vec hom x $ i = 0 \<longleftrightarrow> x $ i = 0"
      using index_map_vec(1)[of i x] by simp
  } note main = this
  show ?thesis unfolding vec_eq_iff by (simp, insert main, auto)
qed

lemma  mat_hom_inj: "map_mat hom A = map_mat hom B \<Longrightarrow> A = B"
  unfolding mat_eq_iff by auto

lemma  vec_hom_inj: "map_vec hom v = map_vec hom w \<Longrightarrow> v = w"
  unfolding vec_eq_iff by auto

lemma  vec_hom_set_distinct_iff:
  fixes xs :: "'a vec list"
  shows "distinct xs \<longleftrightarrow> distinct (map (map_vec hom) xs)"
  using vec_hom_inj by (induct xs) (auto)
end

subsection \<open> Basic Mod Context \<close>

locale mat_mod = fixes m :: int
assumes non_triv_m: "m > 1"
begin

text \<open>First define the mod operations on vectors \<close>
definition vec_mod :: "int vec \<Rightarrow> int vec" where
"vec_mod v \<equiv> map_vec (\<lambda> x . x mod m) v"

(* Parse tree ambiguity is caused by bad definitions in the MPoly theory files. Issue raised
on Isabelle Mailing List *)

lemma vec_mod_dim[simp]: "dim_vec (vec_mod v) = dim_vec v"
  using vec_mod_def by simp

lemma vec_mod_index[simp]: "i < dim_vec v \<Longrightarrow> (vec_mod v) $ i = (v $ i) mod m"
  using vec_mod_def by simp

lemma vec_mod_index_same[simp]: "i < dim_vec v \<Longrightarrow> v $ i < m \<Longrightarrow> v $ i \<ge> 0 \<Longrightarrow> (vec_mod v) $ i = v $ i"
  by simp

lemma vec_setI2: "i < dim_vec v \<Longrightarrow> v $ i \<in> set\<^sub>v v"
  by (simp add: vec_setI)

lemma vec_mod_eq: "set\<^sub>v v \<subseteq> {0..<m} \<Longrightarrow> vec_mod v = v"
  apply (intro eq_vecI, simp_all)
  using vec_setI2 vec_mod_index_same by (metis atLeastLessThan_iff subset_iff zmod_trivial_iff)

lemma vec_mod_set_vec_same:"set\<^sub>v v \<subseteq> {0..<m} \<Longrightarrow> set\<^sub>v (vec_mod v) = set\<^sub>v v"
  using vec_mod_eq by auto

text \<open>Define the mod operation on matrices \<close>

definition mat_mod :: "int mat \<Rightarrow> int mat"  where
"mat_mod M \<equiv> map_mat (\<lambda> x. x mod m) M"

lemma mat_mod_dim[simp]: "dim_row (mat_mod M) = dim_row M" "dim_col (mat_mod M) = dim_col M"
  using mat_mod_def by simp_all

lemma mat_mod_index [simp]:  "i < dim_row M \<Longrightarrow> j < dim_col M \<Longrightarrow> (mat_mod M) $$ (i, j) = (M $$ (i, j)) mod m"
  by(simp add: mat_mod_def)

lemma mat_mod_index_same[simp]: "i < dim_row M \<Longrightarrow> j < dim_col M \<Longrightarrow> M $$ (i, j) < m \<Longrightarrow>
    M $$ (i, j) \<ge> 0 \<Longrightarrow> mat_mod M $$ (i, j) = M $$ (i, j)"
  by (simp add: mat_mod_def)

lemma elements_matI2: "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> A $$ (i, j) \<in> elements_mat A"
  by auto

lemma mat_mod_elements_in:
  assumes "x \<in> elements_mat M"
  shows "x mod m \<in> elements_mat (mat_mod M)"
proof -
  obtain i j where "M $$ (i, j) = x" and ilt: "i < dim_row M" and jlt: "j < dim_col M" using assms by auto
  then have "mat_mod M $$ (i, j) = x mod m" by simp
  thus ?thesis using ilt jlt
    by (metis elements_matI2 mat_mod_dim(1) mat_mod_dim(2))
qed

lemma mat_mod_elements_map:
  assumes "x \<in> elements_mat M"
  shows "elements_mat (mat_mod M) = (\<lambda> x. x mod m) ` (elements_mat M)"
proof (auto simp add: mat_mod_elements_in)
  fix x assume "x \<in> elements_mat (local.mat_mod M)"
  then obtain i j where "(mat_mod M) $$ (i, j) = x" and "i < dim_row (mat_mod M)" and "j < dim_col (mat_mod M)" by auto
  then show "x \<in> (\<lambda>x. x mod m) ` elements_mat M"
    by auto
qed

lemma mat_mod_eq_cond:
  assumes "elements_mat M \<subseteq> {0..<m}"
  shows "mat_mod M = M"
proof (intro eq_matI, simp_all)
  fix i j assume "i < dim_row M" "j < dim_col M"
  then have "M $$ (i, j) \<in> {0..<m}"
    using assms elements_matI2 by blast
  then show "M $$ (i, j) mod m = M $$ (i, j)"
    by (simp)
qed

lemma mat_mod_eq_elements_cond: "elements_mat M \<subseteq> {0..<m} \<Longrightarrow> elements_mat (mat_mod M) = elements_mat M"
  using mat_mod_eq_cond by auto

lemma mat_mod_vec_mod_row:  "i < dim_row A \<Longrightarrow> row (mat_mod A) i = vec_mod (row A i)"
  unfolding mat_mod_def vec_mod_def by (simp)

lemma mat_mod_vec_mod_col:  "j < dim_col A \<Longrightarrow> col (mat_mod A) j = vec_mod (col A j)"
  unfolding mat_mod_def vec_mod_def by (simp)

lemma count_vec_mod_eq: "set\<^sub>v v \<subseteq> {0..<m} \<Longrightarrow> count_vec v x = count_vec (vec_mod v) x"
  using vec_mod_eq by (simp)

lemma elems_mat_setv_row_0m: "i < dim_row M \<Longrightarrow> elements_mat M \<subseteq> {0..<m} \<Longrightarrow> set\<^sub>v (row M i) \<subseteq> {0..<m}"
  by (metis row_elems_subset_mat subset_trans)

lemma elems_mat_setv_col_0m: "j < dim_col M \<Longrightarrow> elements_mat M \<subseteq> {0..<m} \<Longrightarrow> set\<^sub>v (col M j) \<subseteq> {0..<m}"
  by (metis col_elems_subset_mat subset_trans)

lemma mat_mod_count_row_eq:  "i < dim_row M \<Longrightarrow> elements_mat M \<subseteq> {0..<m} \<Longrightarrow>
    count_vec (row (mat_mod M) i) x = count_vec (row M i) x"
  using count_vec_mod_eq mat_mod_vec_mod_row elems_mat_setv_row_0m by simp

lemma mat_mod_count_col_eq: "j < dim_col M \<Longrightarrow> elements_mat M \<subseteq> {0..<m} \<Longrightarrow>
    count_vec (col (mat_mod M) j) x = count_vec (col M j) x"
  using count_vec_mod_eq mat_mod_vec_mod_col elems_mat_setv_col_0m by simp

lemma mod_mat_one: "mat_mod (1\<^sub>m n) = (1\<^sub>m n)"
  by (intro eq_matI, simp_all add: mat_mod_def non_triv_m)

lemma mod_mat_zero: "mat_mod (0\<^sub>m nr nc) = (0\<^sub>m nr nc)"
  by (intro eq_matI, simp_all add: mat_mod_def non_triv_m)

lemma vec_mod_unit: "vec_mod (unit_vec n i) = (unit_vec n i)"
  by (intro eq_vecI, simp_all add: unit_vec_def vec_mod_def non_triv_m)

lemma vec_mod_zero: "vec_mod (0\<^sub>v n) = (0\<^sub>v n)"
  by (intro eq_vecI, simp_all add: non_triv_m)

lemma mat_mod_cond_iff: "elements_mat M \<subseteq> {0..<m} \<Longrightarrow> P M \<longleftrightarrow> P (mat_mod M)"
  by (simp add: mat_mod_eq_cond)

end

subsection \<open>Mod Type \<close>
text \<open> The below locale takes lemmas from the Poly Mod Finite Field theory in the Berlekamp Zassenhaus
AFP entry, however has removed any excess material on polynomials mod, and only included the general
factors. Ideally, this could be used as the base locale for both in the future \<close>

locale mod_type =
  fixes m :: int and ty :: "'a :: nontriv itself"
  assumes m: "m = CARD('a)"
begin

lemma m1: "m > 1" using nontriv[where 'a = 'a] by (auto simp:m)

definition M :: "int \<Rightarrow> int" where "M x = x mod m"

lemma M_0[simp]: "M 0 = 0"
  by (auto simp add: M_def)

lemma M_M[simp]: "M (M x) = M x"
  by (auto simp add: M_def)

lemma M_plus[simp]: "M (M x + y) = M (x + y)" "M (x + M y) = M (x + y)"
  by (auto simp add: M_def mod_simps)

lemma M_minus[simp]: "M (M x - y) = M (x - y)" "M (x - M y) = M (x - y)"
  by (auto simp add: M_def mod_simps)

lemma M_times[simp]: "M (M x * y) = M (x * y)" "M (x * M y) = M (x * y)"
  by (auto simp add: M_def mod_simps)

lemma M_1[simp]: "M 1 = 1" unfolding M_def
  using m1 by auto

lemma M_sum: "M (sum (\<lambda> x. M (f x)) A) = M (sum f A)"
proof (induct A rule: infinite_finite_induct)
  case (insert x A)
  from insert(1-2) have "M (\<Sum>x\<in>insert x A. M (f x)) = M (f x + M ((\<Sum>x\<in>A. M (f x))))" by simp
  also have "M ((\<Sum>x\<in>A. M (f x))) = M ((\<Sum>x\<in>A. f x))" using insert by simp
  finally show ?case using insert by simp
qed auto

definition inv_M :: "int \<Rightarrow> int" where
  "inv_M x = (if x + x \<le> m then x else x - m)"

lemma M_inv_M_id[simp]: "M (inv_M x) = M x"
  unfolding inv_M_def M_def by simp

definition M_Rel :: "int \<Rightarrow> 'a mod_ring \<Rightarrow> bool"
  where "M_Rel x x' \<equiv> (M x = to_int_mod_ring x')"

lemma to_int_mod_ring_plus: "to_int_mod_ring ((x :: 'a mod_ring) + y) = M (to_int_mod_ring x + to_int_mod_ring y)"
  unfolding M_def using m by (transfer, auto)

lemma to_int_mod_ring_times: "to_int_mod_ring ((x :: 'a mod_ring) * y) = M (to_int_mod_ring x * to_int_mod_ring y)"
  unfolding M_def using m by (transfer, auto)

lemma eq_M_Rel[transfer_rule]: "(M_Rel ===> M_Rel ===> (=)) (\<lambda> x y. M x = M y) (=)"
  unfolding M_Rel_def rel_fun_def by auto

lemma one_M_Rel[transfer_rule]: "M_Rel 1 1"
  unfolding M_Rel_def M_def
  unfolding m by auto

lemma zero_M_Rel[transfer_rule]: "M_Rel 0 0"
  unfolding M_Rel_def M_def
  unfolding m by auto

lemma M_to_int_mod_ring: "M (to_int_mod_ring (x :: 'a mod_ring)) = to_int_mod_ring x"
  unfolding M_def unfolding m by (transfer, auto)

lemma right_total_M_Rel[transfer_rule]: "right_total M_Rel"
  unfolding right_total_def M_Rel_def using M_to_int_mod_ring by blast

lemma left_total_M_Rel[transfer_rule]: "left_total M_Rel"
  unfolding left_total_def M_Rel_def[abs_def]
proof
  fix x
  show "\<exists> x' :: 'a mod_ring. M x = to_int_mod_ring x'"  unfolding M_def unfolding m
    by (rule exI[of _ "of_int x"], transfer, simp)
qed

lemma bi_total_M_Rel[transfer_rule]: "bi_total M_Rel"
  using right_total_M_Rel left_total_M_Rel by (metis bi_totalI)

lemma to_int_mod_ring_of_int_M: "to_int_mod_ring (of_int x :: 'a mod_ring) = M x" unfolding M_def
  unfolding m by transfer auto

lemma UNIV_M_Rel[transfer_rule]: "rel_set M_Rel {0..<m} UNIV"
  unfolding rel_set_def M_Rel_def[abs_def] M_def
  by (auto simp: M_def m, goal_cases, metis to_int_mod_ring_of_int_mod_ring, (transfer, auto)+)

end

subsection \<open> Mat mod type \<close>
text \<open> Define a context to work on matrices and vectors of type @{typ "'a mod_ring"} \<close>

locale mat_mod_type = mat_mod + mod_type
begin

lemma to_int_mod_ring_plus: "to_int_mod_ring ((x :: 'a mod_ring) + y) = (to_int_mod_ring x + to_int_mod_ring y) mod m"
   using m by (transfer, auto)

lemma to_int_mod_ring_times: "to_int_mod_ring ((x :: 'a mod_ring) * y) = (to_int_mod_ring x * to_int_mod_ring y) mod m"
  using m by (transfer, auto)

text \<open> Set up transfer relation for matrices and vectors \<close>
definition MM_Rel :: "int mat \<Rightarrow> 'a mod_ring mat \<Rightarrow> bool"
  where "MM_Rel f f' \<equiv> (mat_mod f = to_int_mat f')"

definition MV_Rel :: "int vec \<Rightarrow> 'a mod_ring vec \<Rightarrow> bool"
  where "MV_Rel v v' \<equiv> (vec_mod v = to_int_vec v')"

lemma to_int_mat_index[simp]: "i < dim_row N \<Longrightarrow> j < dim_col N \<Longrightarrow> (to_int_mat N $$ (i, j)) = to_int_mod_ring (N $$ (i, j))"
  by simp

lemma to_int_vec_index[simp]: "i < dim_vec v  \<Longrightarrow> (to_int_vec v $i) = to_int_mod_ring (v $i)"
  by simp

lemma eq_dim_row_MM_Rel[transfer_rule]: "(MM_Rel ===> (=)) dim_row dim_row "
  by (metis (mono_tags) MM_Rel_def index_map_mat(2) mat_mod_dim(1) rel_funI)

lemma lt_dim_row_MM_Rel[transfer_rule]: "(MM_Rel ===> (=) ===> (=)) (\<lambda> M i. i < dim_row M) (\<lambda> M i. i < dim_row M)"
  using eq_dim_row_MM_Rel unfolding MM_Rel_def rel_fun_def by auto

lemma eq_dim_col_MM_Rel[transfer_rule]: "(MM_Rel ===> (=)) dim_col dim_col "
  unfolding MM_Rel_def rel_fun_def
  by (metis index_map_mat(3) mat_mod_dim(2))

lemma lt_dim_col_MM_Rel[transfer_rule]: "(MM_Rel ===> (=) ===> (=)) (\<lambda> M j. j < dim_col M) (\<lambda> M j. j < dim_col M)"
  using eq_dim_col_MM_Rel unfolding MM_Rel_def rel_fun_def by auto

lemma eq_dim_vec_MV_Rel[transfer_rule]: "(MV_Rel ===> (=)) dim_vec dim_vec"
  unfolding MV_Rel_def rel_fun_def using index_map_vec(2) vec_mod_dim by metis

lemma lt_dim_vec_MV_Rel[transfer_rule]: "(MV_Rel ===> (=) ===> (=)) (\<lambda> v j. j < dim_vec v) (\<lambda> v j. j < dim_vec v)"
  unfolding MV_Rel_def rel_fun_def using index_map_vec(2) vec_mod_dim by metis

lemma eq_MM_Rel[transfer_rule]: "(MM_Rel ===> MM_Rel ===> (=)) (\<lambda> f f' . mat_mod f = mat_mod f') (=) "
  unfolding MM_Rel_def rel_fun_def using to_int_mod_ring_hom.mat_hom_inj by (auto)

lemma eq_MV_Rel[transfer_rule]: "(MV_Rel ===> MV_Rel ===> (=)) (\<lambda> v v' . vec_mod v = vec_mod v') (=) "
  unfolding MV_Rel_def rel_fun_def using to_int_mod_ring_hom.vec_hom_inj by auto

lemma index_MV_Rel[transfer_rule]: "(MV_Rel ===> (=) ===> M_Rel)
    (\<lambda> v i. if i < dim_vec v then v $ i else 0) (\<lambda> v i. if i < dim_vec v then v $ i else 0)"
  using lt_dim_vec_MV_Rel unfolding MV_Rel_def M_Rel_def M_def rel_fun_def
  by (simp, metis to_int_vec_index vec_mod_index)

lemma index_MM_Rel[transfer_rule]: "(MM_Rel ===> (=) ===> (=) ===> M_Rel)
    (\<lambda> M i j. if (i < dim_row M \<and> j < dim_col M) then M $$ (i, j) else 0)
   (\<lambda> M i j. if (i < dim_row M \<and> j < dim_col M) then M $$ (i, j) else 0)"
  using lt_dim_row_MM_Rel lt_dim_col_MM_Rel unfolding  M_Rel_def M_def rel_fun_def
  by (simp, metis mat_mod_index to_int_mat_index MM_Rel_def)

lemma index_MM_Rel_explicit:
  assumes "MM_Rel N N'"
  assumes "i < dim_row N" "j < dim_col N"
  shows "(N $$ (i, j)) mod m = to_int_mod_ring (N' $$ (i, j))"
proof -
  have eq: "(to_int_mat N') $$ (i, j) = to_int_mod_ring (N' $$ (i, j))"
    by (metis MM_Rel_def assms(1) assms(2) assms(3) index_map_mat mat_mod.mat_mod_dim mat_mod_axioms)
  have "mat_mod N = to_int_mat N'" using assms by (simp add: MM_Rel_def)
  then have "(mat_mod N) $$ (i, j) = (to_int_mat N') $$ (i, j)"
    by simp
  thus ?thesis using mat_mod_index eq
    using assms(2) assms(3) by auto
qed

lemma one_MV_Rel[transfer_rule]: "MV_Rel (unit_vec n i) (unit_vec n i)"
  unfolding MV_Rel_def vec_mod_unit non_triv_m unit_vec_def
  by (intro eq_vecI, simp_all add: non_triv_m)

lemma one_MM_Rel[transfer_rule]: "MM_Rel (1\<^sub>m n) (1\<^sub>m n)"
  unfolding MM_Rel_def mod_mat_one
  by (intro eq_matI, simp_all)

lemma zero_MM_Rel[transfer_rule]: "MM_Rel (0\<^sub>m nr nc) (0\<^sub>m nr nc)"
  unfolding MM_Rel_def
  by (intro eq_matI, simp_all)

lemma zero_MV_Rel[transfer_rule]: "MV_Rel (0\<^sub>v n) (0\<^sub>v n)"
  unfolding MV_Rel_def by (intro eq_vecI, simp_all)

lemma right_unique_MV_Rel[transfer_rule]: "right_unique MV_Rel"
  unfolding right_unique_def MV_Rel_def
  using to_int_mod_ring_hom.vec_hom_inj by auto

lemma right_unique_MM_Rel[transfer_rule]: "right_unique MM_Rel"
  unfolding right_unique_def MM_Rel_def
  using to_int_mod_ring_hom.mat_hom_inj by auto

lemma mod_to_int_mod_ring: "(to_int_mod_ring (x :: 'a mod_ring)) mod m = to_int_mod_ring x"
  unfolding m by (transfer, auto)

lemma mat_mod_to_int_mat: "mat_mod (to_int_mat (N :: 'a mod_ring mat)) = to_int_mat N"
  using mod_to_int_mod_ring by (intro eq_matI, simp_all)

lemma vec_mod_to_int_vec: "vec_mod (to_int_vec (v :: 'a mod_ring vec)) = to_int_vec v"
  using mod_to_int_mod_ring by (intro eq_vecI, simp_all)

lemma right_total_MM_Rel[transfer_rule]: "right_total MM_Rel"
  unfolding right_total_def MM_Rel_def
proof
  fix M :: "'a mod_ring mat"
  show "\<exists>x. mat_mod x = to_int_mat M"
    by (intro exI[of _ "to_int_mat M"], simp add: mat_mod_to_int_mat)
qed

lemma right_total_MV_Rel[transfer_rule]: "right_total MV_Rel"
  unfolding right_total_def MV_Rel_def
proof
  fix v :: "'a mod_ring vec"
  show "\<exists>x. vec_mod x = to_int_vec v"
    by (intro exI[of _ "to_int_vec v"], simp add: vec_mod_to_int_vec)
qed

lemma to_int_mod_ring_of_int_mod: "to_int_mod_ring (of_int x :: 'a mod_ring) = x mod m"
  unfolding m by transfer auto

lemma vec_mod_v_representative: "vec_mod v = to_int_vec (map_vec of_int v :: 'a mod_ring vec)"
  unfolding mat_mod_def by (auto simp: to_int_mod_ring_of_int_mod)

lemma mat_mod_N_representative: "mat_mod N = to_int_mat (map_mat of_int N :: 'a mod_ring mat)"
  unfolding mat_mod_def by (auto simp: to_int_mod_ring_of_int_mod)

lemma left_total_MV_Rel[transfer_rule]: "left_total MV_Rel"
  unfolding left_total_def MV_Rel_def[abs_def] using vec_mod_v_representative by blast

lemma left_total_MM_Rel[transfer_rule]: "left_total MM_Rel"
  unfolding left_total_def MM_Rel_def[abs_def] using mat_mod_N_representative by blast

lemma bi_total_MV_Rel[transfer_rule]: "bi_total MV_Rel"
  using right_total_MV_Rel left_total_MV_Rel by (metis bi_totalI)

lemma bi_total_MM_Rel[transfer_rule]: "bi_total MM_Rel"
  using right_total_MM_Rel left_total_MM_Rel by (metis bi_totalI)

lemma domain_MV_rel[transfer_domain_rule]: "Domainp MV_Rel = (\<lambda> f. True)"
proof
  fix v :: "int vec"
  show "Domainp MV_Rel v = True" unfolding MV_Rel_def[abs_def] Domainp.simps
    by (auto simp: vec_mod_v_representative)
qed

lemma domain_MM_rel[transfer_domain_rule]: "Domainp MM_Rel = (\<lambda> f. True)"
proof
  fix N :: "int mat"
  show "Domainp MM_Rel N = True" unfolding MM_Rel_def[abs_def] Domainp.simps
    by (auto simp: mat_mod_N_representative)
qed

lemma mem_MV_Rel[transfer_rule]:
  "(MV_Rel ===> rel_set MV_Rel ===> (=)) (\<lambda> x Y. \<exists>y \<in> Y. vec_mod x = vec_mod y) (\<in>)"
proof (intro rel_funI iffI)
  fix x y X Y assume xy: "MV_Rel x y" and XY: "rel_set MV_Rel X Y"
  { assume "\<exists>x' \<in> X. vec_mod x = vec_mod x'"
    then obtain x' where x'X: "x' \<in> X" and xx': "vec_mod x = vec_mod x'" by auto
    with xy have x'y: "MV_Rel x' y" by (auto simp: MV_Rel_def)
    from rel_setD1[OF XY x'X] obtain y' where "MV_Rel x' y'" and "y' \<in> Y" by auto
    with x'y
     show "y \<in> Y" using to_int_mod_ring_hom.vec_hom_inj by (auto simp: MV_Rel_def)
  }
  assume "y \<in> Y"
  from rel_setD2[OF XY this] obtain x' where x'X: "x' \<in> X" and x'y: "MV_Rel x' y" by auto
  from xy x'y have "vec_mod x = vec_mod x'" by (auto simp: MV_Rel_def)
  with x'X show "\<exists>x' \<in> X. vec_mod x = vec_mod x'" by auto
qed

lemma mem_MM_Rel[transfer_rule]:
  "(MM_Rel ===> rel_set MM_Rel ===> (=)) (\<lambda> x Y. \<exists>y \<in> Y. mat_mod x = mat_mod y) (\<in>)"
proof (intro rel_funI iffI)
  fix x y X Y assume xy: "MM_Rel x y" and XY: "rel_set MM_Rel X Y"
  { assume "\<exists>x' \<in> X. mat_mod x = mat_mod x'"
    then obtain x' where x'X: "x' \<in> X" and xx': "mat_mod x = mat_mod x'" by auto
    with xy have x'y: "MM_Rel x' y" by (auto simp: MM_Rel_def)
    from rel_setD1[OF XY x'X] obtain y' where "MM_Rel x' y'" and "y' \<in> Y" by auto
    with x'y
     show "y \<in> Y" using to_int_mod_ring_hom.mat_hom_inj by (auto simp: MM_Rel_def)
  }
  assume "y \<in> Y"
  from rel_setD2[OF XY this] obtain x' where x'X: "x' \<in> X" and x'y: "MM_Rel x' y" by auto
  from xy x'y have "mat_mod x = mat_mod x'" by (auto simp: MM_Rel_def)
  with x'X show "\<exists>x' \<in> X. mat_mod x = mat_mod x'" by auto
qed

lemma conversep_MM_Rel_OO_MM_Rel [simp]: "MM_Rel\<inverse>\<inverse> OO MM_Rel = (=)"
  using mat_mod_to_int_mat apply (intro ext, auto simp: OO_def MM_Rel_def)
  using to_int_mod_ring_hom.mat_hom_inj by auto

lemma MM_Rel_OO_conversep_MM_Rel [simp]: "MM_Rel OO MM_Rel\<inverse>\<inverse> = (\<lambda> M M' . mat_mod M = mat_mod M')"
  by (intro ext, auto simp: OO_def MM_Rel_def mat_mod_N_representative)

lemma conversep_MM_Rel_OO_eq_m [simp]: "MM_Rel\<inverse>\<inverse> OO (\<lambda> M M' . mat_mod M = mat_mod M') = MM_Rel\<inverse>\<inverse>"
  by (intro ext, auto simp: OO_def MM_Rel_def)

lemma eq_m_OO_MM_Rel [simp]: "(\<lambda> M M' . mat_mod M = mat_mod M') OO MM_Rel = MM_Rel"
  by (intro ext, auto simp: OO_def MM_Rel_def)

lemma eq_mset_MM_Rel [transfer_rule]:
  "(rel_mset MM_Rel ===> rel_mset MM_Rel ===> (=)) (rel_mset (\<lambda> M M' . mat_mod M = mat_mod M')) (=)"
proof (intro rel_funI iffI)
  fix A B X Y
  assume AX: "rel_mset MM_Rel A X" and BY: "rel_mset MM_Rel B Y"
  {
    assume AB: "rel_mset (\<lambda> M M' . mat_mod M = mat_mod M') A B"
    from AX have "rel_mset MM_Rel\<inverse>\<inverse> X A" by (simp add: multiset.rel_flip)
    note rel_mset_OO[OF this AB]
    note rel_mset_OO[OF this BY]
    then show "X = Y" by (simp add: multiset.rel_eq)
  }
  assume "X = Y"
  with BY have "rel_mset MM_Rel\<inverse>\<inverse> X B" by (simp add: multiset.rel_flip)
  from rel_mset_OO[OF AX this]
  show "rel_mset (\<lambda> M M' . mat_mod M = mat_mod M') A B" by simp
qed

lemma vec_mset_MV_Rel[transfer_rule]:
  "(MV_Rel  ===> (=)) (\<lambda> v. vec_mset (vec_mod v)) (\<lambda> v. image_mset (to_int_mod_ring) (vec_mset v))"
  unfolding MV_Rel_def rel_fun_def
proof (intro allI impI subset_antisym subsetI)
  fix x :: "int vec" fix  y :: "'a mod_ring vec"
  assume assm: "vec_mod x = to_int_vec y"
  have "image_mset to_int_mod_ring (vec_mset y) = vec_mset (to_int_vec y)"
    using inj_zero_hom.vec_hom_mset to_int_mod_ring_hom.inj_zero_hom_axioms by auto
  then show " vec_mset (vec_mod x) = image_mset to_int_mod_ring (vec_mset y)" using assm by simp
qed

lemma vec_count_MV_Rel_direct:
  assumes "MV_Rel v1 v2"
  shows "count_vec v2 i = count_vec (vec_mod v1) (to_int_mod_ring i)"
proof-
  have eq_vecs: "to_int_vec v2 = vec_mod v1" using assms unfolding MV_Rel_def by simp
  have "count_vec v2 i = count (vec_mset v2) i" by simp
  also have 1: "... = count (image_mset to_int_mod_ring (vec_mset v2)) (to_int_mod_ring i)"
    using count_image_mset_inj by (metis to_int_mod_ring_hom.inj_f)
  also have 2: "... = count (vec_mset (vec_mod v1)) (to_int_mod_ring i)" using assms
    by (simp add: eq_vecs inj_zero_hom.vec_hom_mset to_int_mod_ring_hom.inj_zero_hom_axioms)
  finally show "count_vec v2 i = count_vec (vec_mod v1) (to_int_mod_ring i)"
    by (simp add: 1 2 )
qed

lemma MM_Rel_MV_Rel_row: "MM_Rel A B \<Longrightarrow> i < dim_row A \<Longrightarrow> MV_Rel (row A i) (row B i)"
  unfolding MM_Rel_def MV_Rel_def
  by (metis index_map_mat(2) mat_mod_dim(1) mat_mod_vec_mod_row row_map_mat)

lemma MM_Rel_MV_Rel_col:  "MM_Rel A B \<Longrightarrow> j < dim_col A \<Longrightarrow> MV_Rel (col A j) (col B j)"
  unfolding MM_Rel_def MV_Rel_def
  using  index_map_mat(3) mat_mod_dim(2) mat_mod_vec_mod_col col_map_mat by (metis)

end
end


(*  Title:      HOL/ex/List_to_Set_Comprehension_Examples.thy
    Author:     Lukas Bulwahn
    Copyright   2011 TU Muenchen
*)

section \<open>Examples for the list comprehension to set comprehension simproc\<close>

theory List_to_Set_Comprehension_Examples
imports MainRLT
begin

text \<open>
Examples that show and test the simproc that rewrites list comprehensions
applied to List.set to set comprehensions.
\<close>

subsection \<open>Some own examples for set (case ..) simpproc\<close>

lemma "set [(x, xs). x # xs <- as] = {(x, xs). x # xs \<in> set as}"
by auto

lemma "set [(x, y, ys). x # y # ys <- as] = {(x, y, ys). x # y # ys \<in> set as}"
by auto

lemma "set [(x, y, z, zs). x # y # z # zs <- as] = {(x, y, z, zs). x # y # z # zs \<in> set as}"
by auto

lemma "set [(zs, x, z, y). x # (y, z) # zs <- as] = {(zs, x, z, y). x # (y, z) # zs \<in> set as}"
by auto

lemma "set [(x, y). x # y <- zs, x = x'] = {(x, y). x # y \<in> set zs & x = x'}"
by auto

subsection \<open>Existing examples from the List theory\<close>

lemma "set [(x,y,z). b] = {(x', y', z'). x = x' & y = y' & z = z' & b}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs] = {(x, y', z'). x \<in> set xs & y' = y & z = z'}"
by auto

lemma "set [e x y. x\<leftarrow>xs, y\<leftarrow>ys] = {z. \<exists> x y. z = e x y & x \<in> set xs & y \<in> set ys}"
by auto

lemma "set [(x,y,z). x<a, x>b] = {(x', y', z'). x' = x & y' = y & z = z' & x < a & x>b}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, x>b] = {(x', y', z'). y = y' & z = z' & x' \<in> set xs & x' > b}"
by auto

lemma "set [(x,y,z). x<a, x\<leftarrow>xs] = {(x', y', z'). y = y' & z = z' & x' \<in> set xs & x < a}"
by auto

lemma "set [(x,y). Cons True x \<leftarrow> xs] = {(x, y'). y = y' & Cons True x \<in> set xs}"
by auto

lemma "set [(x,y,z). Cons x [] \<leftarrow> xs] = {(x, y', z'). y = y' & z = z' & Cons x [] \<in> set xs}"
by auto

lemma "set [(x,y,z). x<a, x>b, x=d] = {(x', y', z'). x = x' & y = y' & z = z' & x < a & x > b & x = d}"
by auto

lemma "set [(x,y,z). x<a, x>b, y\<leftarrow>ys] = {(x', y, z'). x = x' & y \<in> set ys & z = z' & x < a & x > b}"
by auto

lemma "set [(x,y,z). x<a, x\<leftarrow>xs,y>b] = {(x',y',z'). x' \<in> set xs & y = y' & z = z' & x < a & y > b}"
by auto

lemma "set [(x,y,z). x<a, x\<leftarrow>xs, y\<leftarrow>ys] = {(x', y', z'). z = z' & x < a & x' \<in> set xs & y' \<in> set ys}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, x>b, y<a] = {(x', y', z'). y = y' & z = z' & x' \<in> set xs & x' > b & y < a}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, x>b, y\<leftarrow>ys] = {(x', y', z'). z = z' & x' \<in> set xs & x' > b & y' \<in> set ys}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,y>x] = {(x', y', z'). z = z' & x' \<in> set xs & y' \<in> set ys & y' > x'}"
by auto

lemma "set [(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,z\<leftarrow>zs] = {(x', y', z'). x' \<in> set xs & y' \<in> set ys & z' \<in> set zs}"
by auto

end


header "IMP --- A Simple Imperative Language"

theory tut05_2 imports "~~/src/HOL/IMP/BExp" begin

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
      | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
      | Or com com              ("_ OR/ _" [55,56] 55)
      | ASSUME bexp

subsection "Big-Step Semantics of Commands"

text {*
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first paramenter is a tuple,
so the syntax becomes @{text "(c,s) \<Rightarrow> s'"}.
*}

text_raw{*\snip{BigStepdef}{0}{1}{% *}
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"
| Or1: "\<lbrakk> (c1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (c1 OR c2,s) \<Rightarrow> t"
| Or2: "\<lbrakk> (c2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (c1 OR c2,s) \<Rightarrow> t"
| Assume: "\<lbrakk>bval b s\<rbrakk> \<Longrightarrow> (ASSUME b,s) \<Rightarrow> s"

text_raw{*}%endsnip*}

text_raw{*\snip{BigStepEx}{1}{2}{% *}
schematic_lemma ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq)
apply(rule Assign)
apply simp
apply(rule Assign)
done
text_raw{*}%endsnip*}

thm ex[simplified]

text{* We want to execute the big-step rules: *}

code_pred big_step .

text{* For inductive definitions we need command
       \texttt{values} instead of \texttt{value}. *}

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text{* We need to translate the result state into a list
to display it. *}

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

text{* Proof automation: *}

text {* The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules. *}
declare big_step.intros [intro]

text{* The standard induction rule
@{thm [display] big_step.induct [no_vars]} *}

thm big_step.induct

text{*
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:
*}
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text {*
@{thm [display] big_step_induct [no_vars]}
*}

subsection "Rule inversion"

text{* What can we deduce from @{prop "(SKIP,s) \<Rightarrow> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text{* This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands: *}

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text{* Only [elim]: [elim!] would not terminate. *}

inductive_cases OrE[elim!]: "(Or c1 c2,s) \<Rightarrow> t"
thm OrE

inductive_cases AssumeE[elim!]: "(ASSUME b,s) \<Rightarrow> t"
thm AssumeE

text{* An automatic example: *}

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

text{* Rule inversion by hand via the ``cases'' method: *}

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  --"inverting assms"
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text {* An example combining rule inversion and derivations *}
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text {*
  We call two statements @{text c} and @{text c'} equivalent wrt.\ the
  big-step semantics when \emph{@{text c} started in @{text s} terminates
  in @{text s'} iff @{text c'} started in the same @{text s} also terminates
  in the same @{text s'}}. Formally:
*}
text_raw{*\snip{BigStepEquiv}{0}{1}{% *}
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw{*}%endsnip*}

text {*
Warning: @{text"\<sim>"} is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
*}
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  -- "to show the equivalence, we look at the derivation tree for"
  -- "each side and from that construct a derivation tree for the other side"
  { fix s t assume "(?w, s) \<Rightarrow> t"
    -- "as a first thing we note that, if @{text b} is @{text False} in state @{text s},"
    -- "then both statements do nothing:"
    { assume "\<not>bval b s"
      hence "t = s" using `(?w,s) \<Rightarrow> t` by blast
      hence "(?iw, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then only the @{text WhileTrue} rule can have been used to derive @{text "(?w, s) \<Rightarrow> t"} *}
    { assume "bval b s"
      with `(?w, s) \<Rightarrow> t` obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "now we can build a derivation tree for the @{text IF}"
      -- "first, the body of the True-branch:"
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      -- "then the whole @{text IF}"
      with `bval b s` have "(?iw, s) \<Rightarrow> t" by (rule IfTrue)
    }
    ultimately
    -- "both cases together give us what we want:"
    have "(?iw, s) \<Rightarrow> t" by blast
  }
  moreover
  -- "now the other direction:"
  { fix s t assume "(?iw, s) \<Rightarrow> t"
    -- "again, if @{text b} is @{text False} in state @{text s}, then the False-branch"
    -- "of the @{text IF} is executed, and both statements do nothing:"
    { assume "\<not>bval b s"
      hence "s = t" using `(?iw, s) \<Rightarrow> t` by blast
      hence "(?w, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then this time only the @{text IfTrue} rule can have be used *}
    { assume "bval b s"
      with `(?iw, s) \<Rightarrow> t` have "(c;; ?w, s) \<Rightarrow> t" by auto
      -- "and for this, only the Seq-rule is applicable:"
      then obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "with this information, we can build a derivation tree for the @{text WHILE}"
      with `bval b s`
      have "(?w, s) \<Rightarrow> t" by (rule WhileTrue)
    }
    ultimately
    -- "both cases together again give us what we want:"
    have "(?w, s) \<Rightarrow> t" by blast
  }
  ultimately
  show ?thesis by blast
qed

text {* Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.  *}

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
 apply blast
apply blast
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

text {* Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically. *}

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

lemma "c1 OR c2 \<sim> c2 OR c1"
proof (intro allI iffI)
  fix s t
  assume "(c1 OR c2,s) \<Rightarrow> t"
  thus "(c2 OR c1,s) \<Rightarrow> t"
  proof cases
    case Or1 thus ?thesis by (rule Or2)
  next
    case Or2 thus ?thesis by (rule Or1)
  qed
qed auto (* Other direction symmetrically*)

lemma "\<forall>s. s<s+s \<longrightarrow> s>4" (is "\<forall>s. ?P s \<longrightarrow> ?Q s")
proof -
  (* Pattern matching, even higher-order*)
  term ?P
  term ?Q
oops

lemma
  "IF b THEN c1 ELSE c2 \<sim> ASSUME b;;c1 OR ASSUME (Not b);;c2"
  (is "?l \<sim> ?r")
proof (intro allI iffI)
  fix s t
  assume A: "(?l,s) \<Rightarrow> t"
  thus "(?r,s) \<Rightarrow> t"
  proof cases
    (* Forward-Style*)
    case IfTrue
    hence "(ASSUME b,s) \<Rightarrow> s" by auto
    from this `(c1,s) \<Rightarrow> t` have "(ASSUME b;;c1,s) \<Rightarrow> t"
      by (rule Seq)
    thus ?thesis by (rule Or1)
  next
    case IfFalse
    hence A: "(ASSUME (Not b),s) \<Rightarrow> s" by auto
    (* Backward style *)
    show ?thesis
      apply (rule Or2)
      apply (rule Seq)
      apply (rule A)
      apply (rule `(c2,s) \<Rightarrow> t`)
      done
  qed
qed fastforce

end


section \<open>Generic laws about registers\<close>

theory Laws
  imports Axioms
begin

text \<open>This notation is only used inside this file\<close>
notation comp_update (infixl "*\<^sub>u" 55)
notation tensor_update (infixr "\<otimes>\<^sub>u" 70)
notation register_pair ("'(_;_')")

subsection \<open>Elementary facts\<close>

declare id_preregister[simp]
declare id_update_left[simp]
declare id_update_right[simp]
declare register_preregister[simp]
declare register_comp[simp]
declare register_of_id[simp]
declare register_tensor_left[simp]
declare register_tensor_right[simp]
declare preregister_mult_right[simp]
declare preregister_mult_left[simp]
declare register_id[simp]

subsection \<open>Preregisters\<close>

lemma preregister_tensor_left[simp]: \<open>preregister (\<lambda>b::'b::domain update. tensor_update a b)\<close>
  for a :: \<open>'a::domain update\<close>
proof -
  have \<open>preregister ((\<lambda>b1::('a\<times>'b) update. (a \<otimes>\<^sub>u id_update) *\<^sub>u b1) o (\<lambda>b. tensor_update id_update b))\<close>
    by (rule comp_preregister; simp)
  then show ?thesis
    by (simp add: o_def tensor_update_mult)
qed

lemma preregister_tensor_right[simp]: \<open>preregister (\<lambda>a::'a::domain update. tensor_update a b)\<close>
  for b :: \<open>'b::domain update\<close>
proof -
  have \<open>preregister ((\<lambda>a1::('a\<times>'b) update. (id_update \<otimes>\<^sub>u b) *\<^sub>u a1) o (\<lambda>a. tensor_update a id_update))\<close>
    by (rule comp_preregister, simp_all)
  then show ?thesis
    by (simp add: o_def tensor_update_mult)
qed

subsection \<open>Registers\<close>

lemma id_update_tensor_register[simp]:
  assumes \<open>register F\<close>
  shows \<open>register (\<lambda>a::'a::domain update. id_update \<otimes>\<^sub>u F a)\<close>
  using assms apply (rule register_comp[unfolded o_def])
  by simp

lemma register_tensor_id_update[simp]:
  assumes \<open>register F\<close>
  shows \<open>register (\<lambda>a::'a::domain update. F a \<otimes>\<^sub>u id_update)\<close>
  using assms apply (rule register_comp[unfolded o_def])
  by simp

subsection \<open>Tensor product of registers\<close>

definition register_tensor  (infixr "\<otimes>\<^sub>r" 70) where
  "register_tensor F G = register_pair (\<lambda>a. tensor_update (F a) id_update) (\<lambda>b. tensor_update id_update (G b))"

lemma register_tensor_is_register:
  fixes F :: "'a::domain update \<Rightarrow> 'b::domain update" and G :: "'c::domain update \<Rightarrow> 'd::domain update"
  shows "register F \<Longrightarrow> register G \<Longrightarrow> register (F \<otimes>\<^sub>r G)"
  unfolding register_tensor_def
  apply (rule register_pair_is_register)
  by (simp_all add: tensor_update_mult)

lemma register_tensor_apply[simp]:
  fixes F :: "'a::domain update \<Rightarrow> 'b::domain update" and G :: "'c::domain update \<Rightarrow> 'd::domain update"
  assumes \<open>register F\<close> and \<open>register G\<close>
  shows "(F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) = F a \<otimes>\<^sub>u G b"
  unfolding register_tensor_def
  apply (subst register_pair_apply)
  unfolding register_tensor_def
  by (simp_all add: assms tensor_update_mult)

definition "separating (_::'b::domain itself) A \<longleftrightarrow>
  (\<forall>F G :: 'a::domain update \<Rightarrow> 'b update. preregister F \<longrightarrow> preregister G \<longrightarrow> (\<forall>x\<in>A. F x = G x) \<longrightarrow> F = G)"

lemma separating_UNIV[simp]: \<open>separating TYPE(_) UNIV\<close>
  unfolding separating_def by auto

lemma separating_mono: \<open>A \<subseteq> B \<Longrightarrow> separating TYPE('a::domain) A \<Longrightarrow> separating TYPE('a) B\<close>
  unfolding separating_def by (meson in_mono)

lemma register_eqI: \<open>separating TYPE('b::domain) A \<Longrightarrow> preregister F \<Longrightarrow> preregister G \<Longrightarrow> (\<And>x. x\<in>A \<Longrightarrow> F x = G x) \<Longrightarrow> F = (G::_ \<Rightarrow> 'b update)\<close>
  unfolding separating_def by auto

lemma separating_tensor:
  fixes A :: \<open>'a::domain update set\<close> and B :: \<open>'b::domain update set\<close>
  assumes [simp]: \<open>separating TYPE('c::domain) A\<close>
  assumes [simp]: \<open>separating TYPE('c) B\<close>
  shows \<open>separating TYPE('c) {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
proof (unfold separating_def, intro allI impI)
  fix F G :: \<open>('a\<times>'b) update \<Rightarrow> 'c update\<close>
  assume [simp]: \<open>preregister F\<close> \<open>preregister G\<close>
  have [simp]: \<open>preregister (\<lambda>x. F (a \<otimes>\<^sub>u x))\<close> for a
    using _ \<open>preregister F\<close> apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: \<open>preregister (\<lambda>x. G (a \<otimes>\<^sub>u x))\<close> for a
    using _ \<open>preregister G\<close> apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: \<open>preregister (\<lambda>x. F (x \<otimes>\<^sub>u b))\<close> for b
    using _ \<open>preregister F\<close> apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: \<open>preregister (\<lambda>x. G (x \<otimes>\<^sub>u b))\<close> for b
    using _ \<open>preregister G\<close> apply (rule comp_preregister[unfolded o_def])
    by simp

  assume \<open>\<forall>x\<in>{a \<otimes>\<^sub>u b |a b. a\<in>A \<and> b\<in>B}. F x = G x\<close>
  then have EQ: \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> and \<open>b \<in> B\<close> for a b
    using that by auto
  then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> for a b
    apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
    using that by auto
  then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> for a b
    apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
    by auto
  then show "F = G"
    apply (rule tensor_extensionality[rotated -1])
    by auto
qed

lemma register_tensor_distrib:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close> \<open>register L\<close>
  shows \<open>(F \<otimes>\<^sub>r G) o (H \<otimes>\<^sub>r L) = (F o H) \<otimes>\<^sub>r (G o L)\<close>
  apply (rule tensor_extensionality)
  by (auto intro!: register_comp register_preregister register_tensor_is_register)

text \<open>The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}\<close>
lemma separating_tensor':
  fixes A :: \<open>'a::domain update set\<close> and B :: \<open>'b::domain update set\<close>
  assumes \<open>separating TYPE('c::domain) A\<close>
  assumes \<open>separating TYPE('c) B\<close>
  assumes \<open>C = {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
  shows \<open>separating TYPE('c) C\<close>
  using assms
  by (simp add: separating_tensor)

lemma tensor_extensionality3:
  fixes F G :: \<open>('a::domain\<times>'b::domain\<times>'c::domain) update \<Rightarrow> 'd::domain update\<close>
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  assumes "\<And>f g h. F (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = G (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)"
  shows "F = G"
proof (rule register_eqI[where A=\<open>{a\<otimes>\<^sub>ub\<otimes>\<^sub>uc| a b c. True}\<close>])
  have \<open>separating TYPE('d) {b \<otimes>\<^sub>u c |b c. True}\<close>
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show \<open>separating TYPE('d) {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True}\<close>
    apply (rule_tac separating_tensor'[where A=UNIV and B=\<open>{b\<otimes>\<^sub>uc| b c. True}\<close>])
    by auto
  show \<open>preregister F\<close> \<open>preregister G\<close> by auto
  show \<open>x \<in> {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
    using assms(3) by auto
qed

lemma tensor_extensionality3':
  fixes F G :: \<open>(('a::domain\<times>'b::domain)\<times>'c::domain) update \<Rightarrow> 'd::domain update\<close>
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  assumes "\<And>f g h. F ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = G ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)"
  shows "F = G"
proof (rule register_eqI[where A=\<open>{(a\<otimes>\<^sub>ub)\<otimes>\<^sub>uc| a b c. True}\<close>])
  have \<open>separating TYPE('d) {a \<otimes>\<^sub>u b | a b. True}\<close>
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show \<open>separating TYPE('d) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True}\<close>
    apply (rule_tac separating_tensor'[where B=UNIV and A=\<open>{a\<otimes>\<^sub>ub| a b. True}\<close>])
    by auto
  show \<open>preregister F\<close> \<open>preregister G\<close> by auto
  show \<open>x \<in> {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
    using assms(3) by auto
qed

lemma register_tensor_id[simp]: \<open>id \<otimes>\<^sub>r id = id\<close>
  apply (rule tensor_extensionality)
  by (auto simp add: register_tensor_is_register)

subsection \<open>Pairs and compatibility\<close>

definition compatible :: \<open>('a::domain update \<Rightarrow> 'c::domain update)
                       \<Rightarrow> ('b::domain update \<Rightarrow> 'c update) \<Rightarrow> bool\<close> where
  \<open>compatible F G \<longleftrightarrow> register F \<and> register G \<and> (\<forall>a b. F a *\<^sub>u G b = G b *\<^sub>u F a)\<close>

lemma compatibleI:
  assumes "register F" and "register G"
  assumes \<open>\<And>a b. (F a) *\<^sub>u (G b) = (G b) *\<^sub>u (F a)\<close>
  shows "compatible F G"
  using assms unfolding compatible_def by simp

lemma swap_registers:
  assumes "compatible R S"
  shows "R a *\<^sub>u S b = S b *\<^sub>u R a"
  using assms unfolding compatible_def by metis

lemma compatible_sym: "compatible x y \<Longrightarrow> compatible y x"
  by (simp add: compatible_def)

lemma pair_is_register[simp]:
  assumes "compatible F G"
  shows "register (F; G)"
  by (metis assms compatible_def register_pair_is_register)

lemma register_pair_apply:
  assumes \<open>compatible F G\<close>
  shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (F a) *\<^sub>u (G b)\<close>
  apply (rule register_pair_apply)
  using assms unfolding compatible_def by metis+

lemma register_pair_apply':
  assumes \<open>compatible F G\<close>
  shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (G b) *\<^sub>u (F a)\<close>
  apply (subst register_pair_apply)
  using assms by (auto simp: compatible_def intro: register_preregister)

lemma compatible_comp_left[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (F \<circ> H) G"
  by (simp add: compatible_def)

lemma compatible_comp_right[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible F (G \<circ> H)"
  by (simp add: compatible_def)

lemma compatible_comp_inner[simp]:
  "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (H \<circ> F) (H \<circ> G)"
  by (smt (verit, best) comp_apply compatible_def register_comp register_mult)

lemma compatible_register1: \<open>compatible F G \<Longrightarrow> register F\<close>
  by (simp add: compatible_def)
lemma compatible_register2: \<open>compatible F G \<Longrightarrow> register G\<close>
  by (simp add: compatible_def)

lemma pair_o_tensor:
  assumes "compatible A B" and [simp]: \<open>register C\<close> and [simp]: \<open>register D\<close>
  shows "(A; B) o (C \<otimes>\<^sub>r D) = (A o C; B o D)"
  apply (rule tensor_extensionality)
  using assms by (simp_all add: register_tensor_is_register register_pair_apply comp_preregister)

lemma compatible_tensor_id_update_left[simp]:
  fixes F :: "'a::domain update \<Rightarrow> 'c::domain update" and G :: "'b::domain update \<Rightarrow> 'c::domain update"
  assumes "compatible F G"
  shows "compatible (\<lambda>a. id_update \<otimes>\<^sub>u F a) (\<lambda>a. id_update \<otimes>\<^sub>u G a)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_right[simp]:
  fixes F :: "'a::domain update \<Rightarrow> 'c::domain update" and G :: "'b::domain update \<Rightarrow> 'c::domain update"
  assumes "compatible F G"
  shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u id_update) (\<lambda>a. G a \<otimes>\<^sub>u id_update)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_rl[simp]:
  assumes "register F" and "register G"
  shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u id_update) (\<lambda>a. id_update \<otimes>\<^sub>u G a)"
  apply (rule compatibleI)
  using assms by (auto simp: tensor_update_mult)

lemma compatible_tensor_id_update_lr[simp]:
  assumes "register F" and "register G"
  shows "compatible (\<lambda>a. id_update \<otimes>\<^sub>u F a) (\<lambda>a. G a \<otimes>\<^sub>u id_update)"
  apply (rule compatibleI)
  using assms by (auto simp: tensor_update_mult)

lemma register_comp_pair:
  assumes [simp]: \<open>register F\<close> and [simp]: \<open>compatible G H\<close>
  shows "(F o G; F o H) = F o (G; H)"
proof (rule tensor_extensionality)
  show \<open>preregister (F \<circ> G;F \<circ> H)\<close> and \<open>preregister (F \<circ> (G;H))\<close>
    by simp_all

  have [simp]: \<open>compatible (F o G) (F o H)\<close>
    apply (rule compatible_comp_inner, simp)
    by simp
  then have [simp]: \<open>register (F \<circ> G)\<close> \<open>register (F \<circ> H)\<close>
    unfolding compatible_def by auto
  from assms have [simp]: \<open>register G\<close> \<open>register H\<close>
    unfolding compatible_def by auto
  fix a b
  show \<open>(F \<circ> G;F \<circ> H) (a \<otimes>\<^sub>u b) = (F \<circ> (G;H)) (a \<otimes>\<^sub>u b)\<close>
    by (auto simp: register_pair_apply register_mult tensor_update_mult)
qed

lemma swap_registers_left:
  assumes "compatible R S"
  shows "R a *\<^sub>u S b *\<^sub>u c = S b *\<^sub>u R a *\<^sub>u c"
  using assms unfolding compatible_def by metis

lemma swap_registers_right:
  assumes "compatible R S"
  shows "c *\<^sub>u R a *\<^sub>u S b = c *\<^sub>u S b *\<^sub>u R a"
  by (metis assms comp_update_assoc compatible_def)

lemmas compatible_ac_rules = swap_registers comp_update_assoc[symmetric] swap_registers_right

subsection \<open>Fst and Snd\<close>

definition Fst where \<open>Fst a = a \<otimes>\<^sub>u id_update\<close>
definition Snd where \<open>Snd a = id_update \<otimes>\<^sub>u a\<close>

lemma register_Fst[simp]: \<open>register Fst\<close>
  unfolding Fst_def by (rule register_tensor_left)

lemma register_Snd[simp]: \<open>register Snd\<close>
  unfolding Snd_def by (rule register_tensor_right)

lemma compatible_Fst_Snd[simp]: \<open>compatible Fst Snd\<close>
  apply (rule compatibleI, simp, simp)
  by (simp add: Fst_def Snd_def tensor_update_mult)

lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]

definition \<open>swap = (Snd; Fst)\<close>

lemma swap_apply[simp]: "swap (a \<otimes>\<^sub>u b) = (b \<otimes>\<^sub>u a)"
  unfolding swap_def
  by (simp add: Axioms.register_pair_apply Fst_def Snd_def tensor_update_mult)

lemma swap_o_Fst: "swap o Fst = Snd"
  by (auto simp add: Fst_def Snd_def)
lemma swap_o_Snd: "swap o Snd = Fst"
  by (auto simp add: Fst_def Snd_def)

lemma register_swap[simp]: \<open>register swap\<close>
  by (simp add: swap_def)

lemma pair_Fst_Snd: \<open>(Fst; Snd) = id\<close>
  apply (rule tensor_extensionality)
  by (simp_all add: register_pair_apply Fst_def Snd_def tensor_update_mult)

lemma swap_o_swap[simp]: \<open>swap o swap = id\<close>
  by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)

lemma swap_swap[simp]: \<open>swap (swap x) = x\<close>
  by (simp add: pointfree_idE)

lemma inv_swap[simp]: \<open>inv swap = swap\<close>
  by (meson inv_unique_comp swap_o_swap)

lemma register_pair_Fst:
  assumes \<open>compatible F G\<close>
  shows \<open>(F;G) o Fst = F\<close>
  using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)

lemma register_pair_Snd:
  assumes \<open>compatible F G\<close>
  shows \<open>(F;G) o Snd = G\<close>
  using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)

lemma register_Fst_register_Snd[simp]:
  assumes \<open>register F\<close>
  shows \<open>(F o Fst; F o Snd) = F\<close>
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)

lemma register_Snd_register_Fst[simp]:
  assumes \<open>register F\<close>
  shows \<open>(F o Snd; F o Fst) = F o swap\<close>
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)

lemma compatible3[simp]:
  assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible (F; G) H"
proof (rule compatibleI)
  have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close>
    using assms compatible_def by auto
  then have [simp]: \<open>preregister F\<close> \<open>preregister G\<close> \<open>preregister H\<close>
    using register_preregister by blast+
  have [simp]: \<open>preregister (\<lambda>a. (F;G) a *\<^sub>u z)\<close> for z
    apply (rule comp_preregister[unfolded o_def, of \<open>(F;G)\<close>])
    by simp_all
  have [simp]: \<open>preregister (\<lambda>a. z *\<^sub>u (F;G) a)\<close> for z
    apply (rule comp_preregister[unfolded o_def, of \<open>(F;G)\<close>])
    by simp_all
  have "(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u H h = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)" for f g h
  proof -
    have FH: "F f *\<^sub>u H h = H h *\<^sub>u F f"
      using assms compatible_def by metis
    have GH: "G g *\<^sub>u H h = H h *\<^sub>u G g"
      using assms compatible_def by metis
    have \<open>(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u (H h) = F f *\<^sub>u G g *\<^sub>u H h\<close>
      using \<open>compatible F G\<close> by (subst register_pair_apply, auto)
    also have \<open>\<dots> = H h *\<^sub>u F f *\<^sub>u G g\<close>
      using FH GH by (metis comp_update_assoc)
    also have \<open>\<dots> = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)\<close>
      using \<open>compatible F G\<close> by (subst register_pair_apply, auto simp: comp_update_assoc)
    finally show ?thesis
      by -
  qed
  then show "(F; G) fg *\<^sub>u (H h) = (H h) *\<^sub>u (F; G) fg" for fg h
    apply (rule_tac tensor_extensionality[THEN fun_cong])
    by auto
  show "register H" and  "register (F; G)"
    by simp_all
qed

lemma compatible3'[simp]:
  assumes "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible F (G; H)"
  apply (rule compatible_sym)
  apply (rule compatible3)
  using assms by (auto simp: compatible_sym)

lemma pair_o_swap[simp]:
  assumes [simp]: "compatible A B"
  shows "(A; B) o swap = (B; A)"
proof (rule tensor_extensionality)
  have [simp]: "preregister A" "preregister B"
     apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
    by (metis (full_types) assms compatible_register2 register_preregister)
  then show \<open>preregister ((A; B) \<circ> swap)\<close>
    by simp
  show \<open>preregister (B; A)\<close>
    by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
  show \<open>((A; B) \<circ> swap) (a \<otimes>\<^sub>u b) = (B; A) (a \<otimes>\<^sub>u b)\<close> for a b
    (* Without the "only:", we would not need the "apply subst",
       but that proof fails when instantiated in Classical.thy *)
    apply (simp only: o_def swap_apply)
    apply (subst register_pair_apply, simp)
    apply (subst register_pair_apply, simp add: compatible_sym)
    by (metis (no_types, lifting) assms compatible_def)
qed

subsection \<open>Compatibility of register tensor products\<close>

lemma compatible_register_tensor:
  fixes F :: \<open>'a::domain update \<Rightarrow> 'e::domain update\<close> and G :: \<open>'b::domain update \<Rightarrow> 'f::domain update\<close>
    and F' :: \<open>'c::domain update \<Rightarrow> 'e update\<close> and G' :: \<open>'d::domain update \<Rightarrow> 'f update\<close>
  assumes [simp]: \<open>compatible F F'\<close>
  assumes [simp]: \<open>compatible G G'\<close>
  shows \<open>compatible (F \<otimes>\<^sub>r G) (F' \<otimes>\<^sub>r G')\<close>
proof -
  note [intro!] =
    comp_preregister[OF _ preregister_mult_right, unfolded o_def]
    comp_preregister[OF _ preregister_mult_left, unfolded o_def]
    comp_preregister
    register_tensor_is_register
  have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register F'\<close> \<open>register G'\<close>
    using assms compatible_def by blast+
  have [simp]: \<open>register (F \<otimes>\<^sub>r G)\<close> \<open>register (F' \<otimes>\<^sub>r G')\<close>
    by (auto simp add: register_tensor_def)
  have [simp]: \<open>register (F;F')\<close> \<open>register (G;G')\<close>
    by auto
  define reorder :: \<open>(('a\<times>'b) \<times> ('c\<times>'d)) update \<Rightarrow> (('a\<times>'c) \<times> ('b\<times>'d)) update\<close>
    where \<open>reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
  have [simp]: \<open>preregister reorder\<close>
    by (auto simp: reorder_def)
  have [simp]: \<open>reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close> for a b c d
    apply (simp add: reorder_def register_pair_apply)
    by (simp add: Fst_def Snd_def tensor_update_mult)
  define \<Phi> where \<open>\<Phi> c d = ((F;F') \<otimes>\<^sub>r (G;G')) o reorder o (\<lambda>\<sigma>. \<sigma> \<otimes>\<^sub>u (c \<otimes>\<^sub>u d))\<close> for c d
  have [simp]: \<open>preregister (\<Phi> c d)\<close> for c d
    unfolding \<Phi>_def
    by (auto intro: register_preregister)
  have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for a b c d
    unfolding \<Phi>_def by (auto simp: register_pair_apply tensor_update_mult)
  then have \<Phi>1: \<open>\<Phi> c d \<sigma> = (F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for c d \<sigma>
    apply (rule_tac fun_cong[of _ _ \<sigma>])
    apply (rule tensor_extensionality)
    by auto
  have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b)\<close> for a b c d
    unfolding \<Phi>_def apply (auto simp: register_pair_apply)
    by (metis assms(1) assms(2) compatible_def tensor_update_mult)
  then have \<Phi>2: \<open>\<Phi> c d \<sigma> = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for c d \<sigma>
    apply (rule_tac fun_cong[of _ _ \<sigma>])
    apply (rule tensor_extensionality)
    by auto
  from \<Phi>1 \<Phi>2 have \<open>(F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') \<tau> = (F' \<otimes>\<^sub>r G') \<tau> *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for \<tau> \<sigma>
    apply (rule_tac fun_cong[of _ _ \<tau>])
    apply (rule tensor_extensionality)
    by auto
  then show ?thesis
    apply (rule compatibleI[rotated -1])
    by auto
qed

subsection \<open>Associativity of the tensor product\<close>

definition assoc :: \<open>(('a::domain\<times>'b::domain)\<times>'c::domain) update \<Rightarrow> ('a\<times>('b\<times>'c)) update\<close> where
  \<open>assoc = ((Fst; Snd o Fst); Snd o Snd)\<close>

lemma assoc_is_hom[simp]: \<open>preregister assoc\<close>
  by (auto simp: assoc_def)

lemma assoc_apply[simp]: \<open>assoc ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c) = (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c))\<close>
  by (auto simp: assoc_def register_pair_apply Fst_def Snd_def tensor_update_mult)

definition assoc' :: \<open>('a\<times>('b\<times>'c)) update \<Rightarrow> (('a::domain\<times>'b::domain)\<times>'c::domain) update\<close> where
  \<open>assoc' = (Fst o Fst; (Fst o Snd; Snd))\<close>

lemma assoc'_is_hom[simp]: \<open>preregister assoc'\<close>
  by (auto simp: assoc'_def)

lemma assoc'_apply[simp]: \<open>assoc' (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c)) =  ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c)\<close>
  by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def tensor_update_mult)

lemma register_assoc[simp]: \<open>register assoc\<close>
  unfolding assoc_def
  by force

lemma register_assoc'[simp]: \<open>register assoc'\<close>
  unfolding assoc'_def
  by force

lemma pair_o_assoc[simp]:
  assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
  shows \<open>(F; (G; H)) \<circ> assoc = ((F; G); H)\<close>
proof (rule tensor_extensionality3')
  show \<open>register ((F; (G; H)) \<circ> assoc)\<close>
    by simp
  show \<open>register ((F; G); H)\<close>
    by simp
  show \<open>((F; (G; H)) \<circ> assoc) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = ((F; G); H) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)\<close> for f g h
    by (simp add: register_pair_apply assoc_apply comp_update_assoc)
qed

lemma pair_o_assoc'[simp]:
  assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
  shows \<open>((F; G); H) \<circ> assoc' = (F; (G; H))\<close>
proof (rule tensor_extensionality3)
  show \<open>register (((F; G); H) \<circ> assoc')\<close>
    by simp
  show \<open>register (F; (G; H))\<close>
    by simp
  show \<open>(((F; G); H) \<circ> assoc') (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = (F; (G; H)) (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)\<close> for f g h
    by (simp add: register_pair_apply assoc'_apply comp_update_assoc)
qed

lemma assoc'_o_assoc[simp]: \<open>assoc' o assoc = id\<close>
  apply (rule tensor_extensionality3')
  by auto

lemma assoc'_assoc[simp]: \<open>assoc' (assoc x) = x\<close>
  by (simp add: pointfree_idE)

lemma assoc_o_assoc'[simp]: \<open>assoc o assoc' = id\<close>
  apply (rule tensor_extensionality3)
  by auto

lemma assoc_assoc'[simp]: \<open>assoc (assoc' x) = x\<close>
  by (simp add: pointfree_idE)

lemma inv_assoc[simp]: \<open>inv assoc = assoc'\<close>
  using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast

lemma inv_assoc'[simp]: \<open>inv assoc' = assoc\<close>
  by (simp add: inv_equality)

lemma [simp]: \<open>bij assoc'\<close>
  using assoc'_o_assoc assoc_o_assoc' o_bij by blast

subsection \<open>Iso-registers\<close>

definition \<open>iso_register F \<longleftrightarrow> register F \<and> (\<exists>G. register G \<and> F o G = id \<and> G o F = id)\<close>
  for F :: \<open>_::domain update \<Rightarrow> _::domain update\<close>

lemma iso_registerI:
  assumes \<open>register F\<close> \<open>register G\<close> \<open>F o G = id\<close> \<open>G o F = id\<close>
  shows \<open>iso_register F\<close>
  using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast

lemma iso_register_inv: \<open>iso_register F \<Longrightarrow> iso_register (inv F)\<close>
  by (metis inv_unique_comp iso_register_def)

lemma iso_register_inv_comp1: \<open>iso_register F \<Longrightarrow> inv F o F = id\<close>
  using inv_unique_comp iso_register_def by blast

lemma iso_register_inv_comp2: \<open>iso_register F \<Longrightarrow> F o inv F = id\<close>
  using inv_unique_comp iso_register_def by blast

lemma iso_register_id[simp]: \<open>iso_register id\<close>
  by (simp add: iso_register_def)

lemma iso_register_is_register: \<open>iso_register F \<Longrightarrow> register F\<close>
  using iso_register_def by blast

lemma iso_register_comp[simp]:
  assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
  shows \<open>iso_register (F o G)\<close>
proof -
  from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
    \<open>G o G' = id\<close> \<open>G' o G = id\<close>
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=\<open>G' o F'\<close>])
       apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
     apply (metis \<open>F \<circ> F' = id\<close> \<open>G \<circ> G' = id\<close> fcomp_assoc fcomp_comp id_fcomp)
    by (metis (no_types, lifting) \<open>F \<circ> F' = id\<close> \<open>F' \<circ> F = id\<close> \<open>G' \<circ> G = id\<close> fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
qed

lemma iso_register_tensor_is_iso_register[simp]:
  assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
  shows \<open>iso_register (F \<otimes>\<^sub>r G)\<close>
proof -
  from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
    \<open>G o G' = id\<close> \<open>G' o G = id\<close>
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=\<open>F' \<otimes>\<^sub>r G'\<close>])
    by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
qed

lemma iso_register_bij: \<open>iso_register F \<Longrightarrow> bij F\<close>
  using iso_register_def o_bij by auto

lemma inv_register_tensor[simp]:
  assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
  shows \<open>inv (F \<otimes>\<^sub>r G) = inv F \<otimes>\<^sub>r inv G\<close>
  apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij
              simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
                    iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
  by (metis eq_id_iff register_tensor_id)

lemma iso_register_swap[simp]: \<open>iso_register swap\<close>
  apply (rule iso_registerI[of _ swap])
  by auto

lemma iso_register_assoc[simp]: \<open>iso_register assoc\<close>
  apply (rule iso_registerI[of _ assoc'])
  by auto

lemma iso_register_assoc'[simp]: \<open>iso_register assoc'\<close>
  apply (rule iso_registerI[of _ assoc])
  by auto

definition \<open>equivalent_registers F G \<longleftrightarrow> (register F \<and> (\<exists>I. iso_register I \<and> F o I = G))\<close>
  for F G :: \<open>_::domain update \<Rightarrow> _::domain update\<close>

lemma iso_register_equivalent_id[simp]: \<open>equivalent_registers id F \<longleftrightarrow> iso_register F\<close>
  by (simp add: equivalent_registers_def)

lemma equivalent_registersI:
  assumes \<open>register F\<close>
  assumes \<open>iso_register I\<close>
  assumes \<open>F o I = G\<close>
  shows \<open>equivalent_registers F G\<close>
  using assms unfolding equivalent_registers_def by blast

lemma equivalent_registers_register_left: \<open>equivalent_registers F G \<Longrightarrow> register F\<close>
  using equivalent_registers_def by auto

lemma equivalent_registers_register_right: \<open>register G\<close> if \<open>equivalent_registers F G\<close>
  by (metis equivalent_registers_def iso_register_def register_comp that)

lemma equivalent_registers_sym:
  assumes \<open>equivalent_registers F G\<close>
  shows \<open>equivalent_registers G F\<close>
  by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)

lemma equivalent_registers_trans[trans]:
  assumes \<open>equivalent_registers F G\<close> and \<open>equivalent_registers G H\<close>
  shows \<open>equivalent_registers F H\<close>
proof -
  from assms have [simp]: \<open>register F\<close> \<open>register G\<close>
    by (auto simp: equivalent_registers_def)
  from assms(1) obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = G\<close>
    using equivalent_registers_def by blast
  from assms(2) obtain J where [simp]: \<open>iso_register J\<close> and \<open>G o J = H\<close>
    using equivalent_registers_def by blast
  have \<open>register F\<close>
    by (auto simp: equivalent_registers_def)
  moreover have \<open>iso_register (I o J)\<close>
    using \<open>iso_register I\<close> \<open>iso_register J\<close> iso_register_comp by blast
  moreover have \<open>F o (I o J) = H\<close>
    by (simp add: \<open>F \<circ> I = G\<close> \<open>G \<circ> J = H\<close> o_assoc)
  ultimately show ?thesis
    by (rule equivalent_registersI)
qed

lemma equivalent_registers_assoc[simp]:
  assumes [simp]: \<open>compatible F G\<close> \<open>compatible F H\<close> \<open>compatible G H\<close>
  shows \<open>equivalent_registers (F;(G;H)) ((F;G);H)\<close>
  apply (rule equivalent_registersI[where I=assoc])
  by auto

lemma equivalent_registers_pair_right:
  assumes [simp]: \<open>compatible F G\<close>
  assumes eq: \<open>equivalent_registers G H\<close>
  shows \<open>equivalent_registers (F;G) (F;H)\<close>
proof -
  from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>G o I = H\<close>
    by (metis equivalent_registers_def)
  then have *: \<open>(F;G) \<circ> (id \<otimes>\<^sub>r I) = (F;H)\<close>
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r I\<close>])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_pair_left:
  assumes [simp]: \<open>compatible F G\<close>
  assumes eq: \<open>equivalent_registers F H\<close>
  shows \<open>equivalent_registers (F;G) (H;G)\<close>
proof -
  from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = H\<close>
    by (metis equivalent_registers_def)
  then have *: \<open>(F;G) \<circ> (I \<otimes>\<^sub>r id) = (H;G)\<close>
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=\<open>I \<otimes>\<^sub>r id\<close>])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_comp:
  assumes \<open>register H\<close>
  assumes \<open>equivalent_registers F G\<close>
  shows \<open>equivalent_registers (H o F) (H o G)\<close>
  by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)

subsection \<open>Compatibility simplification\<close>

text \<open>The simproc \<open>compatibility_warn\<close> produces helpful warnings for subgoals of the form
   \<^term>\<open>compatible x y\<close> that are probably unsolvable due to missing declarations of
   variable compatibility facts. Same for subgoals of the form \<^term>\<open>register x\<close>.\<close>
simproc_setup "compatibility_warn" ("compatible x y" | "register x") = \<open>
let val thy_string = Markup.markup (Theory.get_markup \<^theory>) (Context.theory_name \<^theory>)
in
fn m => fn ctxt => fn ct => let
  val (x,y) = case Thm.term_of ct of
                 Const(\<^const_name>\<open>compatible\<close>,_ ) $ x $ y => (x, SOME y)
               | Const(\<^const_name>\<open>register\<close>,_ ) $ x => (x, NONE)
  val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
  fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
  val _ = case (x,y) of
        (Free(n,T), SOME (Free(n',T'))) =>
            if String.isPrefix ":" n orelse String.isPrefix ":" n' then
                      w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else if n=n' then (if T=T' then ()
                          else w ("In simplification subgoal " ^ Lazy.force str ^
                               ", variables have same name and different types.\n" ^
                               "Probably something is wrong."))
                    else w ("Simplification subgoal " ^ Lazy.force str ^
                            " occurred but cannot be solved.\n" ^
                            "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^
                            "\<close>  somewhere.")
      | (Free(n,T), NONE) =>
            if String.isPrefix ":" n then
                      w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
                    "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^ "\<close>  somewhere.")
      | _ => ()
  in NONE end
end\<close>

named_theorems register_attribute_rule_immediate
named_theorems register_attribute_rule

lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
  asm_rl[of \<open>compatible _ _\<close>] asm_rl[of \<open>iso_register _\<close>] asm_rl[of \<open>register _\<close>] iso_register_inv

text \<open>The following declares an attribute \<open>[register]\<close>. When the attribute is applied to a fact
  of the form \<^term>\<open>register F\<close>, \<^term>\<open>iso_register F\<close>, \<^term>\<open>compatible F G\<close> or a conjunction of these,
  then those facts are added to the simplifier together with some derived theorems
  (e.g., \<^term>\<open>compatible F G\<close> also adds \<^term>\<open>register F\<close>).

  In theory \<open>Laws_Complement\<close>, support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> is
  added to this attribute.\<close>

setup \<open>
let
fun add thm results =
  Net.insert_term (K true) (Thm.concl_of thm, thm) results
  handle Net.INSERT => results
fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE  of
  NONE => state | SOME th => f th state
fun collect (rules,rules_immediate) thm results =
  results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
fun declare thm context = let
  val ctxt = Context.proof_of context
  val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
  val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
  val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
  (* val _ = \<^print> thms *)
  in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
in
Attrib.setup \<^binding>\<open>register\<close>
 (Scan.succeed (Thm.declaration_attribute declare))
  "Add register-related rules to the simplifier"
end
\<close>

subsection \<open>Notation\<close>

no_notation comp_update (infixl "*\<^sub>u" 55)
no_notation tensor_update (infixr "\<otimes>\<^sub>u" 70)

bundle register_notation begin
notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
notation register_pair ("'(_;_')")
end

bundle no_register_notation begin
no_notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
no_notation register_pair ("'(_;_')")
end

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Fragments on permuations\<close>

theory Perm_Fragments
imports "HOL-Library.Perm" "HOL-Library.Dlist"
begin

unbundle permutation_syntax

text \<open>On cycles\<close>

lemma cycle_prod_list:
  "\<langle>a # as\<rangle> = prod_list (map (\<lambda>b. \<langle>a\<leftrightarrow>b\<rangle>) (rev as))"
  by (induct as) simp_all

lemma cycle_append [simp]:
  "\<langle>a # as @ bs\<rangle> = \<langle>a # bs\<rangle> * \<langle>a # as\<rangle>"
proof (induct as rule: cycle.induct)
  case (3 b c as)
  then have "\<langle>a # (b # as) @ bs\<rangle> = \<langle>a # bs\<rangle> * \<langle>a # b # as\<rangle>"
    by simp
  then have "\<langle>a # as @ bs\<rangle> * \<langle>a\<leftrightarrow>b\<rangle> =
    \<langle>a # bs\<rangle> * \<langle>a # as\<rangle> * \<langle>a\<leftrightarrow>b\<rangle>"
    by (simp add: ac_simps)
  then have "\<langle>a # as @ bs\<rangle> * \<langle>a\<leftrightarrow>b\<rangle> * \<langle>a\<leftrightarrow>b\<rangle> =
    \<langle>a # bs\<rangle> * \<langle>a # as\<rangle> * \<langle>a\<leftrightarrow>b\<rangle> * \<langle>a\<leftrightarrow>b\<rangle>"
    by simp
  then have "\<langle>a # as @ bs\<rangle> = \<langle>a # bs\<rangle> * \<langle>a # as\<rangle>"
    by (simp add: ac_simps)
  then show "\<langle>a # (b # c # as) @ bs\<rangle> =
    \<langle>a # bs\<rangle> * \<langle>a # b # c # as\<rangle>"
    by (simp add: ac_simps)
qed simp_all

lemma affected_cycle:
  "affected \<langle>as\<rangle> \<subseteq> set as"
proof (induct as rule: cycle.induct)
  case (3 a b as)
  from affected_times
  have "affected (\<langle>a # as\<rangle> * \<langle>a\<leftrightarrow>b\<rangle>)
    \<subseteq> affected \<langle>a # as\<rangle> \<union> affected \<langle>a\<leftrightarrow>b\<rangle>" .
  moreover from 3
  have "affected (\<langle>a # as\<rangle>) \<subseteq> insert a (set as)"
    by simp
  moreover
  have "affected \<langle>a\<leftrightarrow>b\<rangle> \<subseteq> {a, b}"
    by (cases "a = b") (simp_all add: affected_swap)
  ultimately have "affected (\<langle>a # as\<rangle> * \<langle>a\<leftrightarrow>b\<rangle>)
    \<subseteq> insert a (insert b (set as))"
    by blast
  then show ?case by auto
qed simp_all

lemma orbit_cycle_non_elem:
  assumes "a \<notin> set as"
  shows "orbit \<langle>as\<rangle> a = {a}"
  unfolding not_in_affected_iff_orbit_eq_singleton [symmetric]
  using assms affected_cycle [of as] by blast

lemma inverse_cycle:
  assumes "distinct as"
  shows "inverse \<langle>as\<rangle> = \<langle>rev as\<rangle>"
using assms proof (induct as rule: cycle.induct)
  case (3 a b as)
  then have *: "inverse \<langle>a # as\<rangle> = \<langle>rev (a # as)\<rangle>"
    and distinct: "distinct (a # b # as)"
    by simp_all
  show " inverse \<langle>a # b # as\<rangle> = \<langle>rev (a # b # as)\<rangle>"
  proof (cases as rule: rev_cases)
    case Nil with * show ?thesis
      by (simp add: swap_sym)
  next
    case (snoc cs c)
    with distinct have "distinct (a # b # cs @ [c])"
      by simp
    then have **: "\<langle>a\<leftrightarrow>b\<rangle> * \<langle>c\<leftrightarrow>a\<rangle> = \<langle>c\<leftrightarrow>a\<rangle> * \<langle>c\<leftrightarrow>b\<rangle>"
      by transfer (auto simp add: comp_def Fun.swap_def)
    with snoc * show ?thesis
      by (simp add: mult.assoc [symmetric])
  qed
qed simp_all

lemma order_cycle_non_elem:
  assumes "a \<notin> set as"
  shows "order \<langle>as\<rangle> a = 1"
proof -
  from assms have "orbit \<langle>as\<rangle> a = {a}"
    by (rule orbit_cycle_non_elem)
  then have "card (orbit \<langle>as\<rangle> a) = card {a}"
    by simp
  then show ?thesis
    by simp
qed

lemma orbit_cycle_elem:
  assumes "distinct as" and "a \<in> set as"
  shows "orbit \<langle>as\<rangle> a = set as"
  oops \<comment> \<open>(we need rotation here\<close>

lemma order_cycle_elem:
  assumes "distinct as" and "a \<in> set as"
  shows "order \<langle>as\<rangle> a = length as"
  oops

text \<open>Adding fixpoints\<close>

definition fixate :: "'a \<Rightarrow> 'a perm \<Rightarrow> 'a perm"
where
  "fixate a f = (if a \<in> affected f then f * \<langle>apply (inverse f) a\<leftrightarrow>a\<rangle> else f)"

lemma affected_fixate_trivial:
  assumes "a \<notin> affected f"
  shows "affected (fixate a f) = affected f"
  using assms by (simp add: fixate_def)

lemma affected_fixate_binary_circle:
  assumes "order f a = 2"
  shows "affected (fixate a f) = affected f - {a, apply f a}" (is "?A = ?B")
proof (rule set_eqI)
  interpret bijection "apply f"
    by standard simp
  fix b
  from assms order_greater_eq_two_iff [of f a] have "a \<in> affected f"
    by simp
  moreover have "apply (f ^ 2) a = a"
    by (simp add: assms [symmetric])
  ultimately show "b \<in> ?A \<longleftrightarrow> b \<in> ?B"
    by (cases "b \<in> {a, apply (inverse f) a}")
      (auto simp add: in_affected power2_eq_square apply_inverse apply_times fixate_def)
qed

lemma affected_fixate_no_binary_circle:
  assumes "order f a > 2"
  shows "affected (fixate a f) = affected f - {a}" (is "?A = ?B")
proof (rule set_eqI)
  interpret bijection "apply f"
    by standard simp
  fix b
  from assms order_greater_eq_two_iff [of f a]
  have "a \<in> affected f"
    by simp
  moreover from assms
  have "apply f (apply f a) \<noteq> a"
    using apply_power_eq_iff [of f 2 a 0]
    by (simp add: power2_eq_square apply_times)
  ultimately show "b \<in> ?A \<longleftrightarrow> b \<in> ?B"
    by (cases "b \<in> {a, apply (inverse f) a}")
      (auto simp add: in_affected apply_inverse apply_times fixate_def)
qed

lemma affected_fixate:
  "affected (fixate a f) \<subseteq> affected f - {a}"
proof -
  have "a \<notin> affected f \<or> order f a = 2 \<or> order f a > 2"
    by (auto simp add: not_less dest: affected_order_greater_eq_two)
  then consider "a \<notin> affected f" | "order f a = 2" | "order f a > 2"
    by blast
  then show ?thesis apply cases
  using affected_fixate_trivial [of a f]
    affected_fixate_binary_circle [of f a]
    affected_fixate_no_binary_circle [of f a]
    by auto
qed

lemma orbit_fixate_self [simp]:
  "orbit (fixate a f) a = {a}"
proof -
  have "apply (f * inverse f) a = a"
    by simp
  then have "apply f (apply (inverse f) a) = a"
    by (simp only: apply_times comp_apply)
  then show ?thesis
    by (simp add: fixate_def not_in_affected_iff_orbit_eq_singleton [symmetric] in_affected apply_times)
qed

lemma order_fixate_self [simp]:
  "order (fixate a f) a = 1"
proof -
  have "card (orbit (fixate a f) a) = card {a}"
    by simp
  then show ?thesis
    by (simp only: card_orbit_eq) simp
qed

lemma
  assumes "b \<notin> orbit f a"
  shows "orbit (fixate b f) a = orbit f a"
  oops

lemma
  assumes "b \<in> orbit f a" and "b \<noteq> a"
  shows "orbit (fixate b f) a = orbit f a - {b}"
  oops

text \<open>Distilling cycles from permutations\<close>

inductive_set orbits :: "'a perm \<Rightarrow> 'a set set" for f
where
  in_orbitsI: "a \<in> affected f \<Longrightarrow> orbit f a \<in> orbits f"

lemma orbits_unfold:
  "orbits f = orbit f ` affected f"
  by (auto intro: in_orbitsI elim: orbits.cases)

lemma in_orbit_affected:
  assumes "b \<in> orbit f a"
  assumes "a \<in> affected f"
  shows "b \<in> affected f"
proof (cases "a = b")
  case True with assms show ?thesis by simp
next
  case False with assms have "{a, b} \<subseteq> orbit f a"
    by auto
  also from assms have "orbit f a \<subseteq> affected f"
    by (blast intro!: orbit_subset_eq_affected)
  finally show ?thesis by simp
qed

lemma Union_orbits [simp]:
  "\<Union>(orbits f) = affected f"
  by (auto simp add: orbits.simps intro: in_orbitsI in_orbit_affected)

lemma finite_orbits [simp]:
  "finite (orbits f)"
  by (simp add: orbits_unfold)

lemma card_in_orbits:
  assumes "A \<in> orbits f"
  shows "card A \<ge> 2"
  using assms by cases
    (auto dest: affected_order_greater_eq_two)

lemma disjoint_orbits:
  assumes "A \<in> orbits f" and "B \<in> orbits f" and "A \<noteq> B"
  shows "A \<inter> B = {}"
  using \<open>A \<in> orbits f\<close> apply cases
  using \<open>B \<in> orbits f\<close> apply cases
  using \<open>A \<noteq> B\<close> apply (simp_all add: orbit_disjoint)
  done

definition trace :: "'a \<Rightarrow> 'a perm \<Rightarrow> 'a list"
where
  "trace a f = map (\<lambda>n. apply (f ^ n) a) [0..<order f a]"

lemma set_trace_eq [simp]:
  "set (trace a f) = orbit f a"
  by (auto simp add: trace_def orbit_unfold_image)

definition seeds :: "'a perm \<Rightarrow> 'a::linorder list"
where
  "seeds f = sorted_list_of_set (Min ` orbits f)"

definition cycles :: "'a perm \<Rightarrow> 'a::linorder list list"
where
  "cycles f = map (\<lambda>a. trace a f) (seeds f)"

lemma (in comm_monoid_list_set) sorted_list_of_set:
  assumes "finite A"
  shows "list.F (map h (sorted_list_of_set A)) = set.F h A"
proof -
  from distinct_sorted_list_of_set
  have "set.F h (set (sorted_list_of_set A)) = list.F (map h (sorted_list_of_set A))"
    by (rule distinct_set_conv_list)
  with \<open>finite A\<close> show ?thesis
    by (simp)
qed

text \<open>Misc\<close>

primrec subtract :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "subtract [] ys = ys"
| "subtract (x # xs) ys = subtract xs (removeAll x ys)"

lemma length_subtract_less_eq [simp]:
  "length (subtract xs ys) \<le> length ys"
proof (induct xs arbitrary: ys)
  case Nil then show ?case by simp
next
  case (Cons x xs)
  then have "length (subtract xs (removeAll x ys)) \<le> length (removeAll x ys)" .
  also have "length (removeAll x ys) \<le> length ys"
    by simp
  finally show ?case
    by simp
qed

end